WIP Allow installation of local folders as packages

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 $

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 <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
-          \and PROJECT is the repo you want to upload."
+          \and PROJECT is the repo you want to upload."

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

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) =

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) ]

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 =

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

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
+