PackageEntry and peWanted (fixes #219), progress for #199

src/Stack/Build.hs

@@ -26,7 +26,7 @@ import           Control.Monad.Trans.Resource
 import           Data.Either
 import           Data.Function
 import           Data.Map.Strict (Map)
-import qualified Data.Set as S
+import qualified Data.Map as Map
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path.IO
 import           Prelude hiding (FilePath, writeFile)
@@ -115,7 +115,7 @@ clean = do
     menv <- getMinimalEnvOverride
     cabalPkgVer <- getCabalPkgVer menv
     forM_
-        (S.toList (bcPackages bconfig))
+        (Map.keys (bcPackages bconfig))
         (distDirFromDir cabalPkgVer >=> removeTreeIfExists)
 
 ----------------------------------------------------------

src/Stack/Build/Source.hs

@@ -104,10 +104,10 @@ loadLocals bopts = do
     let names = Set.fromList names0
 
     bconfig <- asks getBuildConfig
-    lps <- forM (Set.toList $ bcPackages bconfig) $ \dir -> do
+    lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do
         cabalfp <- getCabalFileName dir
         name <- parsePackageNameFromFilePath cabalfp
-        let wanted = isWanted dirs names dir name
+        let wanted = validWanted && isWanted dirs names dir name
         pkg <- readPackage
             PackageConfig
                 { packageConfigEnableTests = wanted && boptsFinalAction bopts == DoTests

src/Stack/Config.hs

@@ -93,7 +93,7 @@ data ProjectAndConfigMonoid
 
 instance FromJSON ProjectAndConfigMonoid where
     parseJSON = withObject "Project, ConfigMonoid" $ \o -> do
-        dirs <- o .:? "packages" .!= ["."]
+        dirs <- o .:? "packages" .!= [packageEntryCurrDir]
         extraDeps' <- o .:? "extra-deps" .!= []
         extraDeps <-
             case partitionEithers $ goDeps extraDeps' of
@@ -224,6 +224,14 @@ loadConfig configArgs = do
         , lcProjectRoot     = fmap (\(_, fp, _) -> parent fp) mproject
         }
 
+-- | A PackageEntry for the current directory, used as a default
+packageEntryCurrDir :: PackageEntry
+packageEntryCurrDir = PackageEntry
+    { peValidWanted = True
+    , peLocation = PLFilePath "."
+    , peSubdirs = []
+    }
+
 -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
 -- values.
 loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)
@@ -253,7 +261,7 @@ loadBuildConfig mproject config noConfigStrat = do
             let p = Project
                     { projectPackages =
                         if cabalFileExists
-                            then ["."]
+                            then [packageEntryCurrDir]
                             else []
                     , projectExtraDeps = Map.empty
                     , projectFlags = flags
@@ -270,8 +278,8 @@ loadBuildConfig mproject config noConfigStrat = do
             ResolverGhc m -> return $ fromMajorVersion m
 
     let root = parent stackYamlFP
-    packages' <- mapM (resolveDir root) (projectPackages project)
-    let packages = S.fromList packages'
+    packages' <- mapM (resolvePackageEntry root) (projectPackages project)
+    let packages = Map.fromList $ concat packages'
 
     return BuildConfig
         { bcConfig = config
@@ -284,6 +292,30 @@ loadBuildConfig mproject config noConfigStrat = do
         , bcFlags = projectFlags project
         }
 
+-- | Resolve a PackageEntry into a list of paths, downloading and cloning as
+-- necessary.
+resolvePackageEntry :: (MonadIO m, MonadThrow m)
+                    => Path Abs Dir -- ^ project root
+                    -> PackageEntry
+                    -> m [(Path Abs Dir, Bool)]
+resolvePackageEntry projRoot pe = do
+    entryRoot <- resolvePackageLocation projRoot (peLocation pe)
+    paths <-
+        case peSubdirs pe of
+            [] -> return [entryRoot]
+            subs -> mapM (resolveDir projRoot) subs
+    return $ map (, peValidWanted pe) paths
+
+-- | Resolve a PackageLocation into a path, downloading and cloning as
+-- necessary.
+resolvePackageLocation :: (MonadIO m, MonadThrow m)
+                       => Path Abs Dir -- ^ project root
+                       -> PackageLocation
+                       -> m (Path Abs Dir)
+resolvePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp
+resolvePackageLocation _projRoot (PLHttpTarball _url) = error "resolvePackageLocation not implemented for HTTP tarballs"
+resolvePackageLocation _projRoot (PLGit _url _commit) = error "resolvePackageLocation not implemented for Git URLs"
+
 -- | Get the stack root, e.g. ~/.stack
 determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)
 determineStackRoot = do

src/Stack/Types/Config.hs

@@ -9,27 +9,27 @@
 
 module Stack.Types.Config where
 
-import           Control.Applicative ((<|>))
+import           Control.Applicative ((<|>), (<$>), (<*>), pure)
 import           Control.Exception
-import           Control.Monad (liftM)
+import           Control.Monad (liftM, mzero)
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
 import           Data.Aeson (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object
-                            ,(.=), (.:?), (.!=), (.:))
+                            ,(.=), (.:?), (.!=), (.:), Value (String))
 import           Data.Binary (Binary)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import           Data.Hashable (Hashable)
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Monoid
-import           Data.Set (Set)
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import           Data.Typeable
 import           Distribution.System (Platform)
 import qualified Distribution.Text
+import           Network.HTTP.Client (parseUrl)
 import           Path
 import           Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
 import           Stack.Types.Docker
@@ -150,8 +150,9 @@ data BuildConfig = BuildConfig
     , bcGhcVersion :: !Version
       -- ^ Version of GHC we'll be using for this build, @Nothing@ if no
       -- preference
-    , bcPackages   :: !(Set (Path Abs Dir))
-      -- ^ Local packages identified by a path
+    , bcPackages   :: !(Map (Path Abs Dir) Bool)
+      -- ^ Local packages identified by a path, Bool indicates whether it is
+      -- allowed to be wanted (see 'peValidWanted')
     , bcExtraDeps  :: !(Map PackageName Version)
       -- ^ Extra dependencies specified in configuration.
       --
@@ -184,14 +185,66 @@ data NoBuildConfigStrategy
     | ExecStrategy
     deriving (Show, Eq, Ord)
 
+data PackageEntry = PackageEntry
+    { peValidWanted :: !Bool
+    -- ^ Can this package be considered wanted? Useful to disable when simply
+    -- modifying an upstream package, see:
+    -- https://github.com/commercialhaskell/stack/issues/219
+    , peLocation :: !PackageLocation
+    , peSubdirs :: ![FilePath]
+    }
+    deriving Show
+instance ToJSON PackageEntry where
+    toJSON pe | peValidWanted pe && null (peSubdirs pe) =
+        toJSON $ peLocation pe
+    toJSON pe = object
+        [ "valid-wanted" .= peValidWanted pe
+        , "location" .= peLocation pe
+        , "subdirs" .= peSubdirs pe
+        ]
+instance FromJSON PackageEntry where
+    parseJSON (String t) = do
+        loc <- parseJSON $ String t
+        return PackageEntry
+            { peValidWanted = True
+            , peLocation = loc
+            , peSubdirs = []
+            }
+    parseJSON v = withObject "PackageEntry" (\o -> PackageEntry
+        <$> o .:? "valid-wanted" .!= True
+        <*> o .: "location"
+        <*> o .:? "subdirs" .!= []) v
+
+data PackageLocation
+    = PLFilePath FilePath
+    -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse
+    -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.
+    | PLHttpTarball Text
+    | PLGit Text Text
+    -- ^ URL and commit
+    deriving Show
+instance ToJSON PackageLocation where
+    toJSON (PLFilePath fp) = toJSON fp
+    toJSON (PLHttpTarball t) = toJSON t
+    toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y]
+instance FromJSON PackageLocation where
+    parseJSON = withText "PackageLocation" $ \t ->
+        http t <|> git t <|> pure (PLFilePath $ T.unpack t)
+      where
+        http t =
+            case parseUrl $ T.unpack t of
+                Left _ -> mzero
+                Right _ -> return $ PLHttpTarball t
+        git t =
+            case T.words t of
+                ["git", x, y] -> return $ PLGit x y
+                _ -> mzero
+
 -- | A project is a collection of packages. We can have multiple stack.yaml
 -- files, but only one of them may contain project information.
 data Project = Project
-    { projectPackages :: ![FilePath]
-    -- ^ Components of the package list which refer to local directories
-    --
-    -- Note that we use @FilePath@ and not @Path@s. The goal is: first parse
-    -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.
+    { projectPackages :: ![PackageEntry]
+    -- ^ Components of the package list
     , projectExtraDeps :: !(Map PackageName Version)
     -- ^ Components of the package list referring to package/version combos,
     -- see: https://github.com/fpco/stack/issues/41