diff --git a/src/CommandLine/Arguments.hs b/src/CommandLine/Arguments.hs index 04ee212..c182eb7 100644 --- a/src/CommandLine/Arguments.hs +++ b/src/CommandLine/Arguments.hs @@ -125,18 +125,18 @@ installInfo = Opt.info args infoModifier where args = - installWith <$> optional package <*> optional version <*> yes + installWith <$> optional packageOrFolder <*> optional version <*> yes installWith maybeName maybeVersion autoYes = case (maybeName, maybeVersion) of (Nothing, Nothing) -> Install.install autoYes Install.Everything - (Just name, Nothing) -> - Install.install autoYes (Install.Latest name) + (Just str, Nothing) -> + Install.install autoYes (Install.Latest str) - (Just name, Just version) -> - Install.install autoYes (Install.Exactly name version) + (Just str, Just version) -> + Install.install autoYes (Install.Exactly str version) (Nothing, Just version) -> throwError $ @@ -169,6 +169,14 @@ package = , Opt.help "A specific package name (e.g. evancz/automaton)" ] +packageOrFolder :: Opt.Parser String +packageOrFolder = + Opt.argument (Just . id) $ + mconcat + [ Opt.metavar "PACKAGE or FOLDER" + , Opt.help "A specific package name (e.g. evancz/automaton) or a local folder" + ] + version :: Opt.Parser V.Version version = Opt.argument V.fromString $ diff --git a/src/Elm/Package/Description.hs b/src/Elm/Package/Description.hs index bebc152..734ae20 100644 --- a/src/Elm/Package/Description.hs +++ b/src/Elm/Package/Description.hs @@ -41,7 +41,7 @@ data Description = Description defaultDescription :: Description defaultDescription = Description - { name = N.Name "USER" "PROJECT" + { name = N.Remote "USER" "PROJECT" , repo = "https://github.com/USER/PROJECT.git" , version = V.initialVersion , summary = "helpful summary of your project, less than 80 characters" @@ -243,4 +243,4 @@ repoToName repo = msg = "the 'repository' field must point to a GitHub project for now, something\n\ \like where USER is your GitHub name\n\ - \and PROJECT is the repo you want to upload." \ No newline at end of file + \and PROJECT is the repo you want to upload." diff --git a/src/Elm/Package/Name.hs b/src/Elm/Package/Name.hs index 9c5819b..2ec6a9b 100644 --- a/src/Elm/Package/Name.hs +++ b/src/Elm/Package/Name.hs @@ -10,38 +10,44 @@ import qualified Data.Maybe as Maybe import System.FilePath (()) -data Name = Name - { user :: String - , project :: String - } +data Name = + Remote + { user :: String + , project :: String + } + | Local + { absolutePath :: FilePath } deriving (Eq, Ord) - dummyName :: Name dummyName = - Name "USER" "PROJECT" + Remote "USER" "PROJECT" toString :: Name -> String -toString name = - user name ++ "/" ++ project name +toString name = case name of + Remote user project -> user ++ "/" ++ project + Local path -> "local://" ++ path toUrl :: Name -> String -toUrl name = - user name ++ "/" ++ project name +toUrl name = case name of + Remote user project -> user ++ "/" ++ project + Local path -> "local://" ++ path toFilePath :: Name -> FilePath -toFilePath name = - user name project name +toFilePath name = case name of + Remote user project -> user project + Local path -> path fromString :: String -> Maybe Name fromString string = case break (=='/') string of + ( "local:", '/':'/': path@(_:_)) -> Just (Local path) ( user@(_:_), '/' : project@(_:_) ) - | all (/='/') project -> Just (Name user project) + | all (/='/') project -> Just (Remote user project) _ -> Nothing @@ -51,10 +57,16 @@ fromString' string = instance Binary Name where - get = Name <$> get <*> get - put (Name user project) = + get = do t <- get :: Get String + case t of + ("local://") -> Local <$> get + user -> Remote user <$> get + put (Remote user project) = do put user put project + put (Local path) = + do put ("local://" :: String) + put path instance FromJSON Name where diff --git a/src/GitHub.hs b/src/GitHub.hs index 512d51b..9c716f5 100644 --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -23,7 +23,7 @@ getVersionTags :: (MonadIO m, MonadError String m) => Name.Name -> m [Version.Version] -getVersionTags (Name.Name user project) = +getVersionTags (Name.Remote user project) = do response <- Http.send url $ \request manager -> httpLbs (request {requestHeaders = headers}) manager @@ -38,6 +38,8 @@ getVersionTags (Name.Name user project) = [("User-Agent", "elm-package")] <> [("Accept", "application/json")] +getVersionTags (Name.Local _) = throwError "Local repository given to GitHub.getVersionTags" + instance FromJSON Tags where parseJSON (Array arr) = diff --git a/src/Install.hs b/src/Install.hs index bda96d5..b9a4dff 100644 --- a/src/Install.hs +++ b/src/Install.hs @@ -3,7 +3,7 @@ module Install where import Control.Monad.Error import qualified Data.List as List import qualified Data.Map as Map -import System.Directory (doesFileExist, removeDirectoryRecursive) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, removeDirectoryRecursive) import System.FilePath (()) import qualified CommandLine.Helpers as Cmd @@ -22,31 +22,42 @@ import qualified Store data Args = Everything - | Latest N.Name - | Exactly N.Name V.Version + | Latest String + | Exactly String V.Version install :: Bool -> Args -> Manager.Manager () install autoYes args = - do exists <- liftIO (doesFileExist Path.description) + do exists <- liftIO (doesFileExist Path.description) description <- case exists of True -> Desc.read Path.description False -> initialDescription + let install' name version = + do newDescription <- addConstraint autoYes name version description + upgrade autoYes newDescription + getName str = + do isFolder <- liftIO (doesDirectoryExist str) + case isFolder of + True -> do cPath <- liftIO (canonicalizePath str) + N.fromString'("local://" ++ cPath) + False -> N.fromString' str + case args of Everything -> upgrade autoYes description - Latest name -> - do version <- latestVersion name - newDescription <- addConstraint autoYes name version description - upgrade autoYes newDescription + Latest str -> + do name <- getName str + version <- latestVersion name + install' name version + + Exactly str version -> + do name <- getName str + install' name version - Exactly name version -> - do newDescription <- addConstraint autoYes name version description - upgrade autoYes newDescription -- INSTALL EVERYTHING @@ -113,18 +124,25 @@ runPlan solution plan = -- MODIFY DESCRIPTION latestVersion :: N.Name -> Manager.Manager V.Version -latestVersion name = - do versionCache <- Store.readVersionCache - case Map.lookup name versionCache of - Just versions -> - return $ maximum versions - - Nothing -> - throwError $ - unlines - [ "No versions of package '" ++ N.toString name ++ "' were found!" - , "Is it spelled correctly?" - ] +latestVersion name = case name of + N.Remote _ _ -> + do versionCache <- Store.readVersionCache + case Map.lookup name versionCache of + Just versions -> + return $ maximum versions + + Nothing -> + throwError $ + unlines + [ "No versions of package '" ++ N.toString name ++ "' were found!" + , "Is it spelled correctly?" + ] + N.Local path -> + do exists <- liftIO $ doesFileExist (path Path.description) + case exists of + True -> do description <- Desc.read (path Path.description) + return $ Desc.version description + False -> return $ Desc.version Desc.defaultDescription addConstraint :: Bool -> N.Name -> V.Version -> Desc.Description -> Manager.Manager Desc.Description @@ -196,7 +214,7 @@ showDependency name constraint = initialDescription :: Manager.Manager Desc.Description initialDescription = - do let core = N.Name "elm-lang" "core" + do let core = N.Remote "elm-lang" "core" version <- latestVersion core let desc = Desc.defaultDescription { Desc.dependencies = [ (core, Constraint.minimalRangeFrom version) ] diff --git a/src/Install/Fetch.hs b/src/Install/Fetch.hs index a971b93..ed631b3 100644 --- a/src/Install/Fetch.hs +++ b/src/Install/Fetch.hs @@ -15,7 +15,7 @@ import qualified Utils.Http as Http package :: (MonadIO m, MonadError String m) => N.Name -> V.Version -> m () -package name@(N.Name user _) version = +package name@(N.Remote user _) version = ifNotExists name version $ do Http.send zipball extract files <- liftIO $ getDirectoryContents "." @@ -28,6 +28,8 @@ package name@(N.Name user _) version = zipball = "http://github.com/" ++ N.toUrl name ++ "/zipball/" ++ V.toString version ++ "/" +package name@(N.Local path) version = undefined + ifNotExists :: (MonadIO m, MonadError String m) => N.Name -> V.Version -> m () -> m () ifNotExists name version command = diff --git a/src/Install/Solver.hs b/src/Install/Solver.hs index 0c9e11b..b637e7a 100644 --- a/src/Install/Solver.hs +++ b/src/Install/Solver.hs @@ -94,7 +94,8 @@ addConstraints :: Packages -> [(N.Name, C.Constraint)] -> Explorer (Maybe Packag addConstraints packages constraints = case constraints of [] -> return (Just packages) - (name, constraint) : rest -> + ((N.Local _), _) : rest -> addConstraints packages rest + (name@(N.Remote _ _), constraint) : rest -> do versions <- Store.getVersions name case filter (C.isSatisfied constraint) versions of [] -> return Nothing diff --git a/src/Store.hs b/src/Store.hs index 4dd7c6f..55bddd2 100644 --- a/src/Store.hs +++ b/src/Store.hs @@ -106,12 +106,15 @@ getConstraints name version = -- VERSIONS getVersions :: (MonadIO m, MonadError String m, MonadState Store m) => N.Name -> m [V.Version] -getVersions name = - do cache <- gets versionCache - case Map.lookup name cache of - Just versions -> return versions - Nothing -> - throwError noLocalVersions - where - noLocalVersions = - "There are no versions of package '" ++ N.toString name ++ "' on your computer." +getVersions name = case name of + N.Remote _ _ -> + do cache <- gets versionCache + case Map.lookup name cache of + Just versions -> return versions + Nothing -> + throwError noLocalVersions + where + noLocalVersions = + "There are no versions of package '" ++ N.toString name ++ "' on your computer." + N.Local path -> undefined +