Merge pull request #753 from commercialhaskell/651-target-parse-overhaul

651 target parse overhaul

Author: snoyberg

ChangeLog.md

@@ -1,6 +1,10 @@
 ## Unreleased changes
 
 * Detect unlisted modules and TemplateHaskell dependent files (#32, #105)
+* Overhauled target parsing, added `--test` and `--bench` options [#651](https://github.com/commercialhaskell/stack/issues/651)
+    * For details, see [Build commands Wiki page](https://github.com/commercialhaskell/stack/wiki/Build-command)
+* `--exec` option [#651](https://github.com/commercialhaskell/stack/issues/651)
+* `--only-dependencies` implemented correctly [#387](https://github.com/commercialhaskell/stack/issues/387)
 
 ## 0.1.2.2
 

src/Options/Applicative/Args.hs

@@ -5,6 +5,7 @@
 module Options.Applicative.Args
     (argsArgument
     ,argsOption
+    ,cmdOption
     ,parseArgsFromString)
     where
 
@@ -27,6 +28,16 @@ argsOption =
         (do string <- O.str
             either O.readerError return (parseArgsFromString string))
 
+-- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@
+cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String])
+cmdOption =
+    O.option
+        (do string <- O.str
+            xs <- either O.readerError return (parseArgsFromString string)
+            case xs of
+                [] -> O.readerError "Must provide a command"
+                x:xs' -> return (x, xs'))
+
 -- | Parse from a string.
 parseArgsFromString :: String -> Either String [String]
 parseArgsFromString = P.parseOnly (argsParser Escaping) . T.pack

src/Stack/Build.hs

@@ -97,7 +97,7 @@ build setLocalFiles mbuildLk bopts = do
         preFetch plan
 
     if boptsDryrun bopts
-        then printPlan (boptsFinalAction bopts) plan
+        then printPlan plan
         else executePlan menv bopts baseConfigOpts locals sourceMap plan
   where
     profiling = boptsLibProfile bopts || boptsExeProfile bopts

src/Stack/Build/ConstructPlan.hs

@@ -74,12 +74,22 @@ data AddDepRes
     | ADRFound InstallLocation Version Installed
     deriving Show
 
+data W = W
+    { wFinals :: !(Map PackageName (Either ConstructPlanException (Task, LocalPackageTB)))
+    , wInstall :: !(Map Text InstallLocation)
+    -- ^ executable to be installed, and location where the binary is placed
+    , wDirty :: !(Map PackageName Text)
+    -- ^ why a local package is considered dirty
+    , wDeps :: !(Set PackageName)
+    -- ^ Packages which count as dependencies
+    }
+instance Monoid W where
+    mempty = W mempty mempty mempty mempty
+    mappend (W a b c d) (W w x y z) = W (mappend a w) (mappend b x) (mappend c y) (mappend d z)
+
 type M = RWST
     Ctx
-    ( Map PackageName (Either ConstructPlanException Task) -- finals
-    , Map Text InstallLocation -- executable to be installed, and location where the binary is placed
-    , Map PackageName Text -- why a local package is considered dirty
-    )
+    W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
 
@@ -121,14 +131,25 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPa
     let latest = Map.fromListWith max $ map toTuple $ Map.keys caches
 
     econfig <- asks getEnvConfig
-    let onWanted =
-            case boptsFinalAction $ bcoBuildOpts baseConfigOpts0 of
-                DoNothing -> void . addDep . packageName . lpPackage
-                _ -> addFinal
+    let onWanted lp = do
+            {-
+             - Arguably this is the right thing to do. However, forcing the
+             - library to rebuild causes the cabal_macros.h file to change,
+             - which makes GHC rebuild everything...
+
+            case lpExeComponents lp of
+                Nothing -> return ()
+                Just _ -> void $ addDep $ packageName $ lpPackage lp
+            -}
+
+            case lpTestBench lp of
+                Just tb -> addFinal lp tb
+                -- See comment above
+                Nothing -> void $ addDep False $ packageName $ lpPackage lp
     let inner = do
             mapM_ onWanted $ filter lpWanted locals
-            mapM_ addDep $ Set.toList extraToBuild0
-    ((), m, (efinals, installExes, dirtyReason)) <- liftIO $ runRWST inner (ctx econfig latest) M.empty
+            mapM_ (addDep False) $ Set.toList extraToBuild0
+    ((), m, W efinals installExes dirtyReason deps) <- liftIO $ runRWST inner (ctx econfig latest) M.empty
     let toEither (_, Left e)  = Left e
         toEither (k, Right v) = Right (k, v)
         (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m
@@ -139,11 +160,12 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPa
             let toTask (_, ADRFound _ _ _) = Nothing
                 toTask (name, ADRToInstall task) = Just (name, task)
                 tasks = M.fromList $ mapMaybe toTask adrs
-                maybeStripLocals
-                    | boptsOnlySnapshot $ bcoBuildOpts baseConfigOpts0 =
-                        stripLocals
-                    | otherwise = id
-            return $ maybeStripLocals Plan
+                takeSubset =
+                    case boptsBuildSubset $ bcoBuildOpts baseConfigOpts0 of
+                        BSAll -> id
+                        BSOnlySnapshot -> stripLocals
+                        BSOnlyDependencies -> stripNonDeps deps
+            return $ takeSubset Plan
                 { planTasks = tasks
                 , planFinals = M.fromList finals
                 , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered
@@ -192,14 +214,14 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered =
         ident = ghcPkgIdPackageIdentifier gid
         name = packageIdentifierName ident
 
-addFinal :: LocalPackage -> M ()
-addFinal lp = do
-    depsRes <- addPackageDeps package
+addFinal :: LocalPackage -> LocalPackageTB -> M ()
+addFinal lp lptb = do
+    depsRes <- addPackageDeps False package
     res <- case depsRes of
         Left e -> return $ Left e
         Right (missing, present, _minLoc) -> do
             ctx <- ask
-            return $ Right Task
+            return $ Right (Task
                 { taskProvides = PackageIdentifier
                     (packageName package)
                     (packageVersion package)
@@ -214,32 +236,38 @@ addFinal lp = do
                             package
                 , taskPresent = present
                 , taskType = TTLocal lp
-                }
-    tell (Map.singleton (packageName package) res, mempty, mempty)
+                }, lptb)
+    tell mempty { wFinals = Map.singleton (packageName package) res }
   where
-    package = lpPackageFinal lp
+    package = lptbPackage lptb
 
-addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep name = do
+addDep :: Bool -- ^ is this being used by a dependency?
+       -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep treatAsDep' name = do
+    ctx <- ask
+    let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx
+    when treatAsDep $ markAsDep name
     m <- get
     case Map.lookup name m of
         Just res -> return res
         Nothing -> do
-            res <- addDep' name
+            res <- addDep' treatAsDep name
             modify $ Map.insert name res
             return res
 
-addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep' name = do
+addDep' :: Bool -- ^ is this being used by a dependency?
+        -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep' treatAsDep name = do
     ctx <- ask
     if name `elem` callStack ctx
         then return $ Left $ DependencyCycleDetected $ name : callStack ctx
         else local
             (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do
-            (addDep'' name)
+            (addDep'' treatAsDep name)
 
-addDep'' :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep'' name = do
+addDep'' :: Bool -- ^ is this being used by a dependency?
+         -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep'' treatAsDep name = do
     ctx <- ask
     case Map.lookup name $ combinedMap ctx of
         -- TODO look up in the package index and see if there's a
@@ -250,12 +278,12 @@ addDep'' name = do
             return $ Right $ ADRFound loc version installed
         Just (PIOnlySource ps) -> do
             tellExecutables name ps
-            installPackage name ps
+            installPackage treatAsDep name ps
         Just (PIBoth ps installed) -> do
             tellExecutables name ps
-            needInstall <- checkNeedInstall name ps installed (wanted ctx)
+            needInstall <- checkNeedInstall treatAsDep name ps installed (wanted ctx)
             if needInstall
-                then installPackage name ps
+                then installPackage treatAsDep name ps
                 else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed
 
 tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above?
@@ -283,10 +311,10 @@ tellExecutablesPackage loc p = do
                 Just (PIOnlySource ps) -> goSource ps
                 Just (PIBoth ps _) -> goSource ps
 
-        goSource (PSLocal lp) = lpComponents lp
+        goSource (PSLocal lp) = fromMaybe Set.empty $ lpExeComponents lp
         goSource (PSUpstream _ _ _) = Set.empty
 
-    tell (Map.empty, m myComps, Map.empty)
+    tell mempty { wInstall = m myComps }
   where
     m myComps = Map.fromList $ map (, loc) $ Set.toList
               $ filterComps myComps $ packageExes p
@@ -300,11 +328,12 @@ tellExecutablesPackage loc p = do
 -- TODO There are a lot of duplicated computations below. I've kept that for
 -- simplicity right now
 
-installPackage :: PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)
-installPackage name ps = do
+installPackage :: Bool -- ^ is this being used by a dependency?
+               -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)
+installPackage treatAsDep name ps = do
     ctx <- ask
     package <- psPackage name ps
-    depsRes <- addPackageDeps package
+    depsRes <- addPackageDeps treatAsDep package
     case depsRes of
         Left e -> return $ Left e
         Right (missing, present, minLoc) -> do
@@ -331,29 +360,31 @@ installPackage name ps = do
                         PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc
                 }
 
-checkNeedInstall :: PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool
-checkNeedInstall name ps installed wanted = assert (piiLocation ps == Local) $ do
+checkNeedInstall :: Bool
+                 -> PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool
+checkNeedInstall treatAsDep name ps installed wanted = assert (piiLocation ps == Local) $ do
     package <- psPackage name ps
-    depsRes <- addPackageDeps package
+    depsRes <- addPackageDeps treatAsDep package
     case depsRes of
         Left _e -> return True -- installPackage will find the error again
         Right (missing, present, _loc)
             | Set.null missing -> checkDirtiness ps installed package present wanted
             | otherwise -> do
-                tell (Map.empty, Map.empty, Map.singleton name $
+                tell mempty { wDirty = Map.singleton name $
                     let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing)
                      in T.append "missing dependencies: " $
                             if T.length t < 100
                                 then t
-                                else T.take 97 t <> "...")
+                                else T.take 97 t <> "..." }
                 return True
 
-addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))
-addPackageDeps package = do
+addPackageDeps :: Bool -- ^ is this being used by a dependency?
+               -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))
+addPackageDeps treatAsDep package = do
     ctx <- ask
     deps' <- packageDepsWithTools package
     deps <- forM (Map.toList deps') $ \(depname, range) -> do
-        eres <- addDep depname
+        eres <- addDep treatAsDep depname
         let mlatest = Map.lookup depname $ latestVersions ctx
         case eres of
             Left e ->
@@ -403,7 +434,7 @@ checkDirtiness ps installed package present wanted = do
             , configCacheDeps = present
             , configCacheComponents =
                 case ps of
-                    PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp
+                    PSLocal lp -> Set.map renderComponent $ lpComponents lp
                     PSUpstream _ _ _ -> Set.empty
             , configCacheHaddock =
                 shouldHaddockPackage buildOpts wanted (packageName package) ||
@@ -420,7 +451,7 @@ checkDirtiness ps installed package present wanted = do
     case mreason of
         Nothing -> return False
         Just reason -> do
-            tell (Map.empty, Map.empty, Map.singleton (packageName package) reason)
+            tell mempty { wDirty = Map.singleton (packageName package) reason }
             return True
 
 describeConfigDiff :: ConfigCache -> ConfigCache -> Text
@@ -493,3 +524,15 @@ stripLocals plan = plan
             TTLocal _ -> False
             TTUpstream _ Local -> False
             TTUpstream _ Snap -> True
+
+stripNonDeps :: Set PackageName -> Plan -> Plan
+stripNonDeps deps plan = plan
+    { planTasks = Map.filter checkTask $ planTasks plan
+    , planFinals = Map.empty
+    , planInstallExes = Map.empty -- TODO maybe don't disable this?
+    }
+  where
+    checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps
+
+markAsDep :: PackageName -> M ()
+markAsDep name = tell mempty { wDeps = Set.singleton name }