diff --git a/ChangeLog.md b/ChangeLog.md index 7f7b5d6fdb..0b336100b3 100644 --- a/ChangeLog.md +++ b/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 diff --git a/src/Options/Applicative/Args.hs b/src/Options/Applicative/Args.hs index fafbb1fb92..bc7a025a61 100644 --- a/src/Options/Applicative/Args.hs +++ b/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 diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 9bc32b76bf..bac962cb10 100644 --- a/src/Stack/Build.hs +++ b/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 diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 6a62b33b70..5b3b2f3e4d 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/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 } diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 42440250ae..1456ff16a9 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -13,11 +13,9 @@ module Stack.Build.Execute , ExecuteEnv , withExecuteEnv , withSingleContext - -- * Testing - , compareTestsComponents ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Concurrent.Execute import Control.Concurrent.Lifted (fork) import Control.Concurrent.MVar.Lifted @@ -81,6 +79,7 @@ import System.IO import System.IO.Temp (withSystemTempDirectory) import System.Process.Internals (createProcess_) import System.Process.Read +import System.Process.Run import System.Process.Log (showProcessArgDebug) type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) @@ -105,10 +104,9 @@ preFetch plan (packageVersion package) printPlan :: M env m - => FinalAction - -> Plan + => Plan -> m () -printPlan finalAction plan = do +printPlan plan = do case Map.toList $ planUnregisterLocal plan of [] -> $logInfo "No packages would be unregistered." xs -> do @@ -128,21 +126,19 @@ printPlan finalAction plan = do $logInfo "Would build:" mapM_ ($logInfo . displayTask) xs - let mfinalLabel = - case finalAction of - DoNothing -> Nothing - DoBenchmarks _ -> Just "benchmark" - DoTests _ -> Just "test" - case mfinalLabel of - Nothing -> return () - Just finalLabel -> do - $logInfo "" - - case Map.toList $ planFinals plan of - [] -> $logInfo $ "Nothing to " <> finalLabel <> "." - xs -> do - $logInfo $ "Would " <> finalLabel <> ":" - forM_ xs $ \(name, _) -> $logInfo $ packageNameText name + let hasTests = not . Set.null . lptbTests + hasBenches = not . Set.null . lptbBenches + tests = Map.elems $ fmap fst $ Map.filter (hasTests . snd) $ planFinals plan + benches = Map.elems $ fmap fst $ Map.filter (hasBenches . snd) $ planFinals plan + + unless (null tests) $ do + $logInfo "" + $logInfo "Would test:" + mapM_ ($logInfo . displayTask) tests + unless (null benches) $ do + $logInfo "" + $logInfo "Would benchmark:" + mapM_ ($logInfo . displayTask) benches $logInfo "" @@ -309,6 +305,10 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do , ":"] forM_ executables $ \exe -> $logInfo $ T.append "- " exe + forM_ (boptsExec bopts) $ \(cmd, args) -> do + $logProcessRun cmd args + callProcess Nothing menv cmd args + -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. windowsRenameCopy :: FilePath -> FilePath -> IO () @@ -356,14 +356,14 @@ executePlan' plan ee@ExecuteEnv {..} = do let keepGoing = case boptsKeepGoing eeBuildOpts of Just kg -> kg - Nothing -> - case boptsFinalAction eeBuildOpts of - DoNothing -> False - _ -> True + Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts concurrentFinal = - case boptsFinalAction eeBuildOpts of - DoTests _ -> concurrentTests - _ -> True + -- TODO it probably makes more sense to use a lock for test suites + -- and just have the execution blocked. Turning off all concurrency + -- on finals based on the --test option doesn't fit in well. + if boptsTests eeBuildOpts + then concurrentTests + else True terminal <- asks getTerminal errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do let total = length actions @@ -386,14 +386,12 @@ executePlan' plan ee@ExecuteEnv {..} = do generateLocalHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals generateDepsHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals generateSnapHaddockIndex eeEnvOverride eeBaseConfigOpts eeGlobalDB - case boptsFinalAction eeBuildOpts of - DoTests topts | toCoverage topts -> generateHpcMarkupIndex - _ -> return () + when (toCoverage $ boptsTestOpts eeBuildOpts) generateHpcMarkupIndex toActions :: M env m => (m () -> IO ()) -> ExecuteEnv - -> (Maybe Task, Maybe Task) -- build and final + -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final -> [Action] toActions runInBase ee (mbuild, mfinal) = abuild ++ afinal @@ -410,37 +408,29 @@ toActions runInBase ee (mbuild, mfinal) = } ] afinal = - case (,) <$> mfinal <*> mfunc of - Just (task@Task {..}, (func, checkTask)) | checkTask task -> + case mfinal of + Nothing -> [] + Just (task@Task {..}, lptb) -> [ Action { actionId = ActionId taskProvides ATFinal , actionDeps = addBuild taskProvides $ (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ func ac ee task + , actionDo = \ac -> runInBase $ do + unless (Set.null $ lptbTests lptb) $ do + singleTest topts lptb ac ee task + unless (Set.null $ lptbBenches lptb) $ do + singleBench beopts lptb ac ee task } ] - _ -> [] where addBuild ident = case mbuild of Nothing -> id Just _ -> Set.insert $ ActionId ident ATBuild - mfunc = - case boptsFinalAction $ eeBuildOpts ee of - DoNothing -> Nothing - DoTests topts -> Just (singleTest topts, checkTest) - DoBenchmarks beopts -> Just (singleBench beopts, checkBench) - - checkTest task = - case taskType task of - TTLocal lp -> not $ Set.null $ packageTests $ lpPackage lp - _ -> assert False False - - checkBench task = - case taskType task of - TTLocal lp -> not $ Set.null $ packageBenchmarks $ lpPackage lp - _ -> assert False False + bopts = eeBuildOpts ee + topts = boptsTestOpts bopts + beopts = boptsBenchmarkOpts bopts -- | Ensure that the configuration for the package matches what is given ensureConfig :: M env m @@ -475,7 +465,7 @@ ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do , configCacheDeps = allDeps , configCacheComponents = case taskType of - TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp + TTLocal lp -> Set.map renderComponent $ lpComponents lp TTUpstream _ _ -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) @@ -672,7 +662,11 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} = extraOpts <- extraBuildOptions cabal (console && configHideTHLoading config) $ (case taskType of - TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp) + TTLocal lp -> "build" + -- Cabal... There doesn't seem to be a way to call out the library component... + -- : "lib" + : map (T.unpack . T.append "exe:") + (maybe [] Set.toList $ lpExeComponents lp) TTUpstream _ _ -> ["build"]) ++ extraOpts let doHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageName package) && @@ -722,11 +716,12 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} = singleTest :: M env m => TestOpts + -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task -> m () -singleTest topts ac ee task = +singleTest topts lptb ac ee task = withSingleContext ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"] config <- asks getConfig @@ -741,11 +736,7 @@ singleTest topts ac ee task = needHpc = toCoverage topts - componentsRaw = - case taskType task of - TTLocal lp -> Set.toList $ lpComponents lp - TTUpstream _ _ -> assert False [] - testsToRun = compareTestsComponents componentsRaw $ Set.toList $ packageTests package + testsToRun = Set.toList $ lptbTests lptb components = map (T.unpack . T.append "test:") testsToRun when needBuild $ do @@ -864,29 +855,14 @@ singleTest topts ac ee task = setTestSuccess pkgDir --- | Determine the tests to be run based on the list of components. -compareTestsComponents :: [Text] -- ^ components - -> [Text] -- ^ all test names - -> [Text] -- ^ tests to be run -compareTestsComponents [] tests = tests -- no components -- all tests -compareTestsComponents comps tests2 = - Set.toList $ Set.intersection tests1 $ Set.fromList tests2 - where - tests1 = Set.unions $ map toSet comps - - toSet x = - case T.break (== ':') x of - (y, "") -> assert (x == y) (Set.singleton x) - ("test", y) -> Set.singleton $ T.drop 1 y - _ -> Set.empty - singleBench :: M env m => BenchmarkOpts + -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task -> m () -singleBench beopts ac ee task = +singleBench beopts _lptb ac ee task = withSingleContext ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"] diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index b64a19d4f4..5bec623fe9 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -10,12 +10,13 @@ module Stack.Build.Source , SourceMap , PackageSource (..) , localFlags - , loadLocals + , getLocalPackageViews + , loadLocalPackage ) where -import Control.Applicative ((<|>), (<$>), (<*>)) +import Control.Applicative ((<$>), (<*>)) import Control.Arrow ((&&&)) -import Control.Exception (catch) +import Control.Exception (assert, catch) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class @@ -30,7 +31,6 @@ import Data.Conduit (($$), ZipSink (..)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Either -import qualified Data.Foldable as F import Data.Function import qualified Data.HashSet as HashSet import Data.List @@ -42,10 +42,15 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Distribution.Package (pkgName, pkgVersion) +import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) +import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Path.IO import Prelude import Stack.Build.Cache +import Stack.Build.Target import Stack.Types.Build import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan, parseCustomMiniBuildPlan) @@ -78,29 +83,47 @@ loadSourceMap bopts = do stackYamlFP <- asks $ bcStackYaml . getBuildConfig parseCustomMiniBuildPlan stackYamlFP url + rawLocals <- getLocalPackageViews + workingDir <- getWorkingDir + (cliExtraDeps, targets) <- + parseTargets + (bcImplicitGlobal bconfig) + (boptsTests bopts) + (boptsBenchmarks bopts) + (mpiVersion <$> mbpPackages mbp0) + (bcExtraDeps bconfig) + (fst <$> rawLocals) + workingDir + (boptsTargets bopts) + menv <- getMinimalEnvOverride caches <- getPackageCaches menv - let latestVersion = Map.fromList $ map toTuple $ Map.keys caches - (locals, extraNames, extraIdents) <- loadLocals bopts latestVersion + let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches + + -- Extend extra-deps to encompass targets requested on the command line + -- that are not in the snapshot. + extraDeps0 <- extendExtraDeps + (bcExtraDeps bconfig) + cliExtraDeps + (Map.keysSet $ Map.filter (== STUnknown) targets) + latestVersion + + locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals + checkFlagsUsed bopts locals let -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; -- here we combine them into nonLocalTargets. This is one of the -- return values of this function. nonLocalTargets :: Set PackageName - nonLocalTargets = extraNames <> Set.map packageIdentifierName extraIdents + nonLocalTargets = + Map.keysSet $ Map.filter (not . isLocal) targets + where + isLocal (STLocal _) = True + isLocal STUnknown = False + isLocal STNonLocal = False - -- Extend extra-deps to encompass targets requested on the command line - -- that are not in the snapshot. - extraDeps0 = extendExtraDeps - (bcExtraDeps bconfig) - mbp0 - latestVersion - extraNames - extraIdents - - let shadowed = Set.fromList (map (packageName . lpPackage) locals) - <> Map.keysSet extraDeps0 + shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0 (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed -- Add the extra deps from the stack.yaml file to the deps grabbed from @@ -123,118 +146,123 @@ loadSourceMap bopts = do (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi)) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - let unknown = Set.difference nonLocalTargets $ Map.keysSet sourceMap - unless (Set.null unknown) $ do - let toEither name = - case Map.lookup name latestVersion of - Nothing -> Left name - Just version -> Right (name, version) - eithers = map toEither $ Set.toList unknown - (unknown', notInIndex) = partitionEithers eithers - throwM $ UnknownTargets - (Set.fromList unknown') - (Map.fromList notInIndex) - (bcStackYaml bconfig) - return (mbp, locals, nonLocalTargets, sourceMap) --- | 'loadLocals' combines two pieces of information: --- --- 1. Targets, i.e. arguments passed to stack such as @foo@ and @bar@ in the @stack foo bar@ invocation --- --- 2. Local packages listed in @stack.yaml@ --- --- It returns: --- --- 1. For every local package, a 'LocalPackage' structure --- --- 2. If a target does not correspond to a local package but is a valid --- 'PackageName' or 'PackageIdentifier', it is returned as such. --- --- NOTE: as the function is written right now, it may "drop" targets if --- they correspond to existing directories not listed in stack.yaml. This --- may be a bug. -loadLocals :: forall m env . - (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m,HasEnvConfig env) - => BuildOpts - -> Map PackageName Version - -> m ([LocalPackage], Set PackageName, Set PackageIdentifier) -loadLocals bopts latestVersion = do - (isWanted', names, idents) <- - case boptsTargets bopts of - -- If there are no targets specified: build all locals - [] -> return (\_ _ -> True, Map.empty, Set.empty) - _targets -> do - targets' <- mapM parseTarget $ boptsTargets bopts - -- Group targets by their kind - (dirs, names, idents) <- - case partitionEithers targets' of - ([], targets'') -> return $ partitionTargetSpecs targets'' - (bad, _) -> throwM $ Couldn'tParseTargets bad - return (isWanted dirs names, names, idents) - let identsMap = Map.fromList $ map toTuple $ Set.toList idents - +-- | Parse out the local package views for the current project +getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env) + => m (Map PackageName (LocalPackageView, GenericPackageDescription)) +getLocalPackageViews = do econfig <- asks getEnvConfig - bconfig <- asks getBuildConfig - -- Iterate over local packages declared in stack.yaml and turn them - -- into LocalPackage structures. The targets affect whether these - -- packages will be marked as wanted. - lps <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do + -- TODO ensure that there are no overlapping package names + liftM Map.fromList $ forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do cabalfp <- getCabalFileName dir + gpkg <- readPackageUnresolved cabalfp + let cabalID = package $ packageDescription gpkg name <- parsePackageNameFromFilePath cabalfp - let wanted = validWanted && isWanted' dir name - config = PackageConfig - { packageConfigEnableTests = False - , packageConfigEnableBenchmarks = False - , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name - , packageConfigGhcVersion = envConfigGhcVersion econfig - , packageConfigPlatform = configPlatform $ getConfig bconfig - } - configFinal = config - { packageConfigEnableTests = - case boptsFinalAction bopts of - DoTests _ -> wanted - _ -> False - , packageConfigEnableBenchmarks = wanted && case boptsFinalAction bopts of - (DoBenchmarks _) -> True - _ -> False + when (fromCabalPackageName (pkgName $ cabalID) /= name) + $ throwM $ MismatchedCabalName cabalfp name + let lpv = LocalPackageView + { lpvVersion = fromCabalVersion $ pkgVersion cabalID + , lpvRoot = dir + , lpvCabalFP = cabalfp + , lpvExtraDep = not validWanted + , lpvComponents = getNamedComponents gpkg } - pkg <- readPackage config cabalfp - pkgFinal <- readPackage configFinal cabalfp - when (packageName pkg /= name) $ throwM - $ MismatchedCabalName cabalfp (packageName pkg) - mbuildCache <- tryGetBuildCache dir - files <- getPackageFiles (packageFiles pkg) cabalfp - (isDirty, newBuildCache) <- checkBuildCache - (fromMaybe Map.empty mbuildCache) - (map toFilePath $ Set.toList files) + return (name, (lpv, gpkg)) + where + getNamedComponents gpkg = Set.fromList $ concat + [ maybe [] (const [CLib]) (C.condLibrary gpkg) + , go CExe C.condExecutables + , go CTest C.condTestSuites + , go CBench C.condBenchmarks + ] + where + go wrapper f = map (wrapper . T.pack . fst) $ f gpkg + +splitComponents :: [NamedComponent] + -> (Set Text, Set Text, Set Text) +splitComponents = + go id id id + where + go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c []) + go a b c (CLib:xs) = go a b c xs + go a b c (CExe x:xs) = go (a . (x:)) b c xs + go a b c (CTest x:xs) = go a (b . (x:)) c xs + go a b c (CBench x:xs) = go a b (c . (x:)) xs - case Map.lookup (packageName pkg) identsMap of - Just version | version /= packageVersion pkg -> - throwM $ LocalPackageDoesn'tMatchTarget - (packageName pkg) - (packageVersion pkg) - version - _ -> return () +-- | Upgrade the initial local package info to a full-blown @LocalPackage@ +-- based on the selected components +loadLocalPackage + :: forall m env. + (MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m) + => BuildOpts + -> Map PackageName SimpleTarget + -> (PackageName, (LocalPackageView, GenericPackageDescription)) + -> m LocalPackage +loadLocalPackage bopts targets (name, (lpv, gpkg)) = do + bconfig <- asks getBuildConfig + econfig <- asks getEnvConfig - return LocalPackage - { lpPackage = pkg - , lpPackageFinal = pkgFinal - , lpWanted = wanted - , lpFiles = files - , lpDirtyFiles = isDirty || boptsForceDirty bopts - , lpNewBuildCache = newBuildCache - , lpCabalFile = cabalfp - , lpDir = dir - , lpComponents = fromMaybe Set.empty $ Map.lookup name names + let mtarget = Map.lookup name targets + components = + case mtarget of + Just (STLocal comps) -> comps + Just STNonLocal -> assert False Set.empty + Just STUnknown -> assert False Set.empty + Nothing -> Set.empty + (exes, tests, benches) = splitComponents $ Set.toList components + config = PackageConfig + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = False + , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name + , packageConfigGhcVersion = envConfigGhcVersion econfig + , packageConfigPlatform = configPlatform $ getConfig bconfig } + btconfig = config + { packageConfigEnableTests = not $ Set.null tests + , packageConfigEnableBenchmarks = not $ Set.null benches + } + pkg = resolvePackage config gpkg + btpkg + | Set.null tests && Set.null benches = Nothing + | otherwise = Just $ LocalPackageTB + { lptbPackage = resolvePackage btconfig gpkg + , lptbTests = tests + , lptbBenches = benches + } + mbuildCache <- tryGetBuildCache $ lpvRoot lpv + files <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv) + (isDirty, newBuildCache) <- checkBuildCache + (fromMaybe Map.empty mbuildCache) + (map toFilePath $ Set.toList files) - let known = Set.fromList $ map (packageName . lpPackage) lps - unknown = Set.difference (Map.keysSet names) known + return LocalPackage + { lpPackage = pkg + , lpExeComponents = + case mtarget of + Nothing -> Nothing + Just _ -> Just exes + , lpTestBench = btpkg + , lpFiles = files + , lpDirtyFiles = isDirty || boptsForceDirty bopts + , lpNewBuildCache = newBuildCache + , lpCabalFile = lpvCabalFP lpv + , lpDir = lpvRoot lpv + , lpComponents = components + } + +-- | Ensure that the flags specified in the stack.yaml file and on the command +-- line are used. +checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) + => BuildOpts + -> [LocalPackage] + -> m () +checkFlagsUsed bopts lps = do + bconfig <- asks getBuildConfig -- Check if flags specified in stack.yaml and the command line are -- used, see https://github.com/commercialhaskell/stack/issues/617 - flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts] + let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts] ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig) localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps @@ -258,65 +286,10 @@ loadLocals bopts latestVersion = do unusedFlags = mapMaybe checkFlagUsed flags - unusedComponents = Set.difference (Map.keysSet names) known - - unless (null unusedFlags) $ throwM $ InvalidFlagSpecification $ Set.fromList unusedFlags - unless (Set.null unusedComponents) $ do - $logWarn "Warning: You've specified components for non-local packages" - $logWarn "Components for the following packages will be ignored:" - forM_ (Set.toList unusedComponents) $ \x -> do - $logWarn $ "* " <> T.pack (packageNameString x) - - return (lps, unknown, idents) - where - -- Attempt to parse a TargetSpec based on its textual form and on - -- whether it is a name of an existing directory. - -- - -- If a TargetSpec is not recognized, return it verbatim as Left. - parseTarget :: Text -> m (Either Text TargetSpec) - parseTarget t = do - let s = T.unpack t - isDir <- liftIO $ doesDirectoryExist s - if isDir - then liftM (Right . TSDir) $ liftIO (canonicalizePath s) >>= parseAbsDir - else return - $ maybe (Left t) Right - $ (flip TSName Set.empty <$> parsePackageNameFromString s) - <|> (TSIdent <$> parsePackageIdentifierFromString s) - <|> (do - t' <- T.stripSuffix ":latest" t - name <- parsePackageNameFromString $ T.unpack t' - version <- Map.lookup name latestVersion - Just $ TSIdent $ PackageIdentifier name version) - <|> (do - let (name', rest) = T.break (== ':') t - component <- T.stripPrefix ":" rest - name <- parsePackageNameFromString $ T.unpack name' - Just $ TSName name $ Set.singleton component) - isWanted dirs names dir name = - name `Map.member` names || - any (`isParentOf` dir) dirs || - any (== dir) dirs - -data TargetSpec - = TSName PackageName (Set Text) - | TSIdent PackageIdentifier - | TSDir (Path Abs Dir) - -partitionTargetSpecs :: [TargetSpec] -> ([Path Abs Dir], Map PackageName (Set Text), Set PackageIdentifier) -partitionTargetSpecs = - loop id Map.empty Set.empty - where - loop dirs names idents ts0 = - case ts0 of - [] -> (dirs [], names, idents) - TSName name comps:ts -> loop - dirs - (Map.insertWith Set.union name comps names) - idents - ts - TSIdent ident:ts -> loop dirs names (Set.insert ident idents) ts - TSDir dir:ts -> loop (dirs . (dir:)) names idents ts + unless (null unusedFlags) + $ throwM + $ InvalidFlagSpecification + $ Set.fromList unusedFlags -- | All flags for a local package localFlags :: (Map (Maybe PackageName) (Map FlagName Bool)) @@ -331,36 +304,34 @@ localFlags boptsflags bconfig name = Map.unions -- | Add in necessary packages to extra dependencies -- --- See https://github.com/commercialhaskell/stack/issues/272 for the requirements of this function -extendExtraDeps :: Map PackageName Version -- ^ original extra deps - -> MiniBuildPlan +-- Originally part of https://github.com/commercialhaskell/stack/issues/272, +-- this was then superseded by +-- https://github.com/commercialhaskell/stack/issues/651 +extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env) + => Map PackageName Version -- ^ original extra deps + -> Map PackageName Version -- ^ package identifiers from the command line + -> Set PackageName -- ^ all packages added on the command line -> Map PackageName Version -- ^ latest versions in indices - -> Set PackageName -- ^ extra package names desired - -> Set PackageIdentifier -- ^ extra package identifiers desired - -> Map PackageName Version -- ^ new extradeps -extendExtraDeps extraDeps0 mbp latestVersion extraNames extraIdents = - F.foldl' addIdent - (F.foldl' addName extraDeps0 extraNames) - extraIdents + -> m (Map PackageName Version) -- ^ new extradeps +extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion + | null errs = return $ Map.unions $ extraDeps1 : unknowns' + | otherwise = do + bconfig <- asks getBuildConfig + throwM $ UnknownTargets + (Set.fromList errs) + Map.empty -- TODO check the cliExtraDeps for presence in index + (bcStackYaml bconfig) where - snapshot = fmap mpiVersion $ mbpPackages mbp + extraDeps1 = Map.union extraDeps0 cliExtraDeps - addName m name = - case Map.lookup name m <|> Map.lookup name snapshot of - -- alright exists in snapshot or extra-deps - Just _ -> m + (errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns + addUnknown pn = + case Map.lookup pn extraDeps1 of + Just _ -> Right Map.empty Nothing -> - case Map.lookup name latestVersion of - -- use the latest version in the index - Just v -> Map.insert name v m - -- does not exist, will be reported as an error - Nothing -> m - - addIdent m (PackageIdentifier name version) = - case Map.lookup name snapshot of - -- the version matches what's in the snapshot, so just use the snapshot version - Just version' | version == version' -> m - _ -> Map.insert name version m + case Map.lookup pn latestVersion of + Just v -> Right $ Map.singleton pn v + Nothing -> Left pn -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values. diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs new file mode 100644 index 0000000000..a84d51c77b --- /dev/null +++ b/src/Stack/Build/Target.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +-- | Parsing command line targets +module Stack.Build.Target + ( -- * Types + ComponentName + , UnresolvedComponent (..) + , RawTarget (..) + , LocalPackageView (..) + , SimpleTarget (..) + -- * Parsers + , parseRawTarget + , parseTargets + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.IO.Class +import Data.Either (partitionEithers) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Monoid (mconcat) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Path +import Path.IO +import Stack.Types + +-- | The name of a component, which applies to executables, test suites, and benchmarks +type ComponentName = Text + +newtype RawInput = RawInput { unRawInput :: Text } + +-- | Either a fully resolved component, or a component name that could be +-- either an executable, test, or benchmark +data UnresolvedComponent + = ResolvedComponent !NamedComponent + | UnresolvedComponent !ComponentName + deriving (Show, Eq, Ord) + +-- | Raw command line input, without checking against any databases or list of +-- locals. Does not deal with directories +data RawTarget (a :: RawTargetType) where + RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a + RTComponent :: !ComponentName -> RawTarget a + RTPackage :: !PackageName -> RawTarget a + RTPackageIdentifier :: !PackageIdentifier -> RawTarget HasIdents + +deriving instance Show (RawTarget a) +deriving instance Eq (RawTarget a) +deriving instance Ord (RawTarget a) + +data RawTargetType = HasIdents | NoIdents + +-- | If this function returns @Nothing@, the input should be treated as a +-- directory. +parseRawTarget :: Text -> Maybe (RawTarget HasIdents) +parseRawTarget t = + (RTPackageIdentifier <$> parsePackageIdentifierFromString s) + <|> (RTPackage <$> parsePackageNameFromString s) + <|> (RTComponent <$> T.stripPrefix ":" t) + <|> parsePackageComponent + where + s = T.unpack t + + parsePackageComponent = + case T.splitOn ":" t of + [pname, "lib"] + | Just pname' <- parsePackageNameFromString (T.unpack pname) -> + Just $ RTPackageComponent pname' $ ResolvedComponent CLib + [pname, cname] + | Just pname' <- parsePackageNameFromString (T.unpack pname) -> + Just $ RTPackageComponent pname' $ UnresolvedComponent cname + [pname, typ, cname] + | Just pname' <- parsePackageNameFromString (T.unpack pname) + , Just wrapper <- parseCompType typ -> + Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname + _ -> Nothing + + parseCompType t' = + case t' of + "exe" -> Just CExe + "test" -> Just CTest + "bench" -> Just CBench + _ -> Nothing + +-- | A view of a local package needed for resolving components +data LocalPackageView = LocalPackageView + { lpvVersion :: !Version + , lpvRoot :: !(Path Abs Dir) + , lpvCabalFP :: !(Path Abs File) + , lpvComponents :: !(Set NamedComponent) + , lpvExtraDep :: !Bool + } + +-- | Same as @parseRawTarget@, but also takes directories into account. +parseRawTargetDirs :: (MonadIO m, MonadThrow m) + => Path Abs Dir -- ^ current directory + -> Map PackageName LocalPackageView + -> Text + -> m (Either Text [(RawInput, RawTarget HasIdents)]) +parseRawTargetDirs root locals t = + case parseRawTarget t of + Just rt -> return $ Right [(ri, rt)] + Nothing -> do + mdir <- resolveDirMaybe root $ T.unpack t + case mdir of + Nothing -> return $ Left $ "Directory not found: " `T.append` t + Just dir -> + case mapMaybe (childOf dir) $ Map.toList locals of + [] -> return $ Left $ + "No local directories found as children of " `T.append` + t + names -> return $ Right $ map ((ri, ) . RTPackage) names + where + ri = RawInput t + + childOf dir (name, lpv) = + if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv) + then Just name + else Nothing + +data TargetType + = TTUnknown + | TTNonLocal + | TTLocalComp !NamedComponent + | TTLocalAllComps !(Set NamedComponent) + +data SimpleTarget + = STUnknown + | STNonLocal + | STLocal !(Set NamedComponent) + deriving (Show, Eq, Ord) + +resolveIdents :: Map PackageName Version -- ^ snapshot + -> Map PackageName Version -- ^ extra deps + -> Map PackageName LocalPackageView + -> (RawInput, RawTarget HasIdents) + -> Either Text ((RawInput, RawTarget NoIdents), Map PackageName Version) +resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty) +resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty) +resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty) +resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) = + case mfound of + Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat + [ "Specified target version " + , versionString version + , " for package " + , packageNameString name + , " does not match " + , foundPlace + , " version " + , versionString foundVersion + ] + _ -> Right + ( (ri, RTPackage name) + , case mfound of + -- Add to extra deps since we didn't have it already + Nothing -> Map.singleton name version + -- Already had it, don't add to extra deps + Just _ -> Map.empty + ) + where + mfound = mlocal <|> mextra <|> msnap + + mlocal = (("local", ) . lpvVersion) <$> Map.lookup name locals + mextra = ("extra-deps", ) <$> Map.lookup name extras + msnap = ("snapshot", ) <$> Map.lookup name snap + +resolveRawTarget :: Map PackageName Version -- ^ snapshot + -> Map PackageName Version -- ^ extra deps + -> Map PackageName LocalPackageView + -> (RawInput, RawTarget NoIdents) + -> Either Text (PackageName, (RawInput, TargetType)) +resolveRawTarget snap extras locals (ri, rt) = + go rt + where + go (RTPackageComponent name ucomp) = + case Map.lookup name locals of + Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name + Just lpv -> + case ucomp of + ResolvedComponent comp + | comp `Set.member` lpvComponents lpv -> + Right (name, (ri, TTLocalComp comp)) + | otherwise -> Left $ T.pack $ concat + [ "Component " + , show comp + , " does not exist in package " + , packageNameString name + ] + UnresolvedComponent comp -> + case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of + [] -> Left $ T.concat + [ "Component " + , comp + , " does not exist in package " + , T.pack $ packageNameString name + ] + [x] -> Right (name, (ri, TTLocalComp x)) + matches -> Left $ T.concat + [ "Ambiguous component name " + , comp + , " for package " + , T.pack $ packageNameString name + , ": " + , T.pack $ show matches + ] + go (RTComponent cname) = + let allPairs = concatMap + (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) + (Map.toList locals) + in case filter (isCompNamed cname . snd) allPairs of + [] -> Left $ "Could not find a component named " `T.append` cname + [(name, comp)] -> + Right (name, (ri, TTLocalComp comp)) + matches -> Left $ T.concat + [ "Ambiugous component name " + , cname + , ", matches: " + , T.pack $ show matches + ] + + go (RTPackage name) = + case Map.lookup name locals of + Just lpv -> Right (name, (ri, TTLocalAllComps $ lpvComponents lpv)) + Nothing -> + case Map.lookup name extras of + Just _ -> Right (name, (ri, TTNonLocal)) + Nothing -> + case Map.lookup name snap of + Just _ -> Right (name, (ri, TTNonLocal)) + Nothing -> Right (name, (ri, TTUnknown)) + +isCompNamed :: Text -> NamedComponent -> Bool +isCompNamed _ CLib = False +isCompNamed t1 (CExe t2) = t1 == t2 +isCompNamed t1 (CTest t2) = t1 == t2 +isCompNamed t1 (CBench t2) = t1 == t2 + +simplifyTargets :: Bool -- ^ include tests + -> Bool -- ^ include benchmarks + -> [(PackageName, (RawInput, TargetType))] + -> ([Text], Map PackageName SimpleTarget) +simplifyTargets includeTests includeBenches = + mconcat . map go . Map.toList . Map.fromListWith (++) . fmap (second return) + where + go :: (PackageName, [(RawInput, TargetType)]) + -> ([Text], Map PackageName SimpleTarget) + go (_, []) = error "Stack.Build.Target.simplifyTargets: the impossible happened" + go (name, [(_, tt)]) = ([], Map.singleton name $ + case tt of + TTUnknown -> STUnknown + TTNonLocal -> STNonLocal + TTLocalComp comp -> STLocal $ Set.singleton comp + TTLocalAllComps comps -> STLocal $ Set.filter keepComp comps + ) + go (name, pairs) = + case partitionEithers $ map (getLocalComp . snd) pairs of + ([], comps) -> ([], Map.singleton name $ STLocal $ Set.fromList comps) + _ -> + let err = T.pack $ concat + [ "Overlapping targets provided for package " + , packageNameString name + , ": " + , show $ map (unRawInput . fst) pairs + ] + in ([err], Map.empty) + + keepComp CLib = True + keepComp (CExe _) = True + keepComp (CTest _) = includeTests + keepComp (CBench _) = includeBenches + + getLocalComp (TTLocalComp comp) = Right comp + getLocalComp _ = Left () + +parseTargets :: (MonadThrow m, MonadIO m) + => Bool -- ^ using implicit global? + -> Bool -- ^ include tests + -> Bool -- ^ include benchmarks + -> Map PackageName Version -- ^ snapshot + -> Map PackageName Version -- ^ extra deps + -> Map PackageName LocalPackageView + -> Path Abs Dir -- ^ current directory + -> [Text] -- ^ command line targets + -> m (Map PackageName Version, Map PackageName SimpleTarget) +parseTargets implicitGlobal includeTests includeBenches snap extras locals currDir textTargets' = do + let textTargets = + if null textTargets' + then map (T.pack . packageNameString) $ Map.keys $ Map.filter (not . lpvExtraDep) locals + else textTargets' + erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets + + let (errs1, rawTargets) = partitionEithers erawTargets + (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $ + map (resolveIdents snap extras locals) $ concat rawTargets + (errs3, targetTypes) = partitionEithers $ + map (resolveRawTarget snap extras locals) rawTargets' + (errs4, targets) = simplifyTargets includeTests includeBenches targetTypes + errs = concat [errs1, errs2, errs3, errs4] + + if null errs + then if Map.null targets + then throwM $ TargetParseException + $ if implicitGlobal + then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] + else ["The specified targets matched no packages"] + else return (Map.unions newExtras, targets) + else throwM $ TargetParseException errs diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f508797535..56ff708131 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -296,6 +296,7 @@ loadBuildConfig mproject config stackRoot mresolver = do , bcExtraDeps = projectExtraDeps project , bcStackYaml = stackYamlFP , bcFlags = projectFlags project + , bcImplicitGlobal = isNothing mproject } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 6d077fb2bd..3c1f5a5206 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -11,7 +11,7 @@ module Stack.Dot (dot import Control.Applicative import Control.Arrow ((&&&)) -import Control.Monad (void) +import Control.Monad (liftM, void) import Control.Monad.Catch (MonadCatch,MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) @@ -63,14 +63,13 @@ dot :: (HasEnvConfig env => DotOpts -> m () dot dotOpts = do - (locals,_,_) <- loadLocals defaultBuildOpts Map.empty + localNames <- liftM Map.keysSet getLocalPackageViews resultGraph <- createDependencyGraph dotOpts let pkgsToPrune = if dotIncludeBase dotOpts then dotPrune dotOpts else Set.insert "base" (dotPrune dotOpts) - localNames = Set.fromList (map (packageName . lpPackageFinal) locals) prunedGraph = pruneGraph localNames pkgsToPrune resultGraph - printGraph dotOpts locals prunedGraph + printGraph dotOpts localNames prunedGraph -- | Create the dependency graph, the result is a map from a package -- name to a tuple of dependencies and a version if available. This @@ -194,7 +193,7 @@ createDepLoader :: Applicative m -> m (Set PackageName, Maybe Version) createDepLoader sourceMap installed loadPackageDeps pkgName = case Map.lookup pkgName sourceMap of - Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackageFinal lp)) + Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp)) Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags Nothing -> pure (Set.empty, do m' <- T.traverse libVersionFromInstalled installed Map.lookup pkgName m') @@ -202,18 +201,18 @@ createDepLoader sourceMap installed loadPackageDeps pkgName = -- | Resolve the direct (depth 0) external dependencies of the given local packages localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))] localDependencies dotOpts locals = - map (\lp -> (packageName (lpPackageFinal lp), (deps lp,Just (lpVersion lp)))) locals + map (\lp -> (packageName (lpPackage lp), (deps lp,Just (lpVersion lp)))) locals where deps lp = if dotIncludeExternal dotOpts - then Set.delete (lpName lp) (packageAllDeps (lpPackageFinal lp)) - else Set.intersection localNames (packageAllDeps (lpPackageFinal lp)) - lpName lp = packageName (lpPackageFinal lp) - localNames = Set.fromList $ map (packageName . lpPackageFinal) locals - lpVersion lp = packageVersion (lpPackageFinal lp) + then Set.delete (lpName lp) (packageAllDeps (lpPackage lp)) + else Set.intersection localNames (packageAllDeps (lpPackage lp)) + lpName lp = packageName (lpPackage lp) + localNames = Set.fromList $ map (packageName . lpPackage) locals + lpVersion lp = packageVersion (lpPackage lp) -- | Print a graphviz graph of the edges in the Map and highlight the given local packages printGraph :: (Applicative m, MonadIO m) => DotOpts - -> [LocalPackage] + -> Set PackageName -- ^ all locals -> Map PackageName (Set PackageName, Maybe Version) -> m () printGraph dotOpts locals graph = do @@ -222,13 +221,13 @@ printGraph dotOpts locals graph = do printLeaves graph void (Map.traverseWithKey printEdges (fst <$> graph)) liftIO $ Text.putStrLn "}" - where filteredLocals = filter (\local -> - show (packageName (lpPackageFinal local)) `Set.notMember` dotPrune dotOpts) locals + where filteredLocals = Set.filter (\local -> + packageNameString local `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m) => DotOpts - -> t LocalPackage + -> t PackageName -> m () printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes) where applyStyle :: Text -> Text @@ -236,7 +235,7 @@ printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" l then n <> " [style=dashed];" else n <> " [style=solid];" lpNodes :: [Text] - lpNodes = map (applyStyle . nodeName . packageName . lpPackageFinal) (F.toList locals) + lpNodes = map (applyStyle . nodeName) (F.toList locals) -- | Print nodes without dependencies printLeaves :: (Applicative m, MonadIO m) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index bd617fc651..0a612314b5 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -46,6 +46,7 @@ data Command | Test | Haddock | Bench + | Install deriving (Eq) -- | Parser for bench arguments. @@ -56,16 +57,25 @@ benchOptsParser = BenchmarkOpts help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`"))) +addCoverageFlags :: BuildOpts -> BuildOpts +addCoverageFlags bopts + | toCoverage $ boptsTestOpts bopts + = bopts { boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts } + | otherwise = bopts + -- | Parser for build arguments. buildOptsParser :: Command - -> Bool -- ^ default copy-bins value -> Parser BuildOpts -buildOptsParser cmd defCopyBins = +buildOptsParser cmd = + fmap addCoverageFlags $ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> - optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*> + optimize <*> haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*> flags <*> copyBins <*> preFetch <*> - ((||) <$> onlySnapshot <*> onlyDependencies) <*> - fileWatch' <*> keepGoing <*> forceDirty + buildSubset <*> + fileWatch' <*> keepGoing <*> forceDirty <*> + tests <*> testOptsParser <*> + benches <*> benchOptsParser <*> + many exec where optimize = maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm target = @@ -86,7 +96,7 @@ buildOptsParser cmd defCopyBins = haddock = boolFlags (cmd == Haddock) "haddock" - "building Haddocks" + "generating Haddocks the project(s) in this directory/configuration" idm haddockDeps = if cmd == Haddock @@ -95,9 +105,8 @@ buildOptsParser cmd defCopyBins = "building Haddocks for dependencies" idm else pure Nothing - finalAction = pure DoNothing - copyBins = boolFlags defCopyBins + copyBins = boolFlags (cmd == Install) "copy-bins" "copying binaries to the local-bin-path (see 'stack path')" idm @@ -125,12 +134,15 @@ buildOptsParser cmd defCopyBins = preFetch = flag False True (long "prefetch" <> help "Fetch packages necessary for the build immediately, useful with --dry-run") - onlySnapshot = flag False True - (long "only-snapshot" <> - help "Only build packages for the snapshot database, not the local database") - onlyDependencies = flag False True - (long "only-dependencies" <> - help "Currently: a synonym for only-snapshot, see https://github.com/commercialhaskell/stack/issues/387") + + buildSubset = + flag' BSOnlySnapshot + (long "only-snapshot" <> + help "Only build packages for the snapshot database, not the local database") + <|> flag' BSOnlyDependencies + (long "only-dependencies" <> + help "Only build packages that are dependencies of targets on the command line") + <|> pure BSAll fileWatch' = flag False True (long "file-watch" <> @@ -145,6 +157,22 @@ buildOptsParser cmd defCopyBins = (long "force-dirty" <> help "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)") + + tests = boolFlags (cmd == Test) + "test" + "testing the project(s) in this directory/configuration" + idm + + benches = boolFlags (cmd == Bench) + "bench" + "benchmarking the project(s) in this directory/configuration" + idm + + exec = cmdOption + ( long "exec" <> + metavar "CMD [ARGS]" <> + help "Command and arguments to run after a successful build" ) + -- | Parser for package:[-]flag readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) readFlag = do diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 55b61f9550..f9e18a105d 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -89,12 +89,12 @@ readLocalPackage pkgDir = do package <- readPackage config cabalfp return LocalPackage { lpPackage = package - , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. + , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file. , lpDir = pkgDir , lpCabalFile = cabalfp -- NOTE: these aren't the 'correct values, but aren't used in -- the usage of this function in this module. - , lpPackageFinal = package + , lpTestBench = Nothing , lpDirtyFiles = True , lpNewBuildCache = Map.empty , lpFiles = Set.empty diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index bbd2894184..b51248b920 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -25,8 +25,8 @@ module Stack.Types.Build ,Plan(..) ,TestOpts(..) ,BenchmarkOpts(..) - ,FinalAction(..) ,BuildOpts(..) + ,BuildSubset(..) ,defaultBuildOpts ,TaskType(..) ,TaskConfigOpts(..) @@ -103,6 +103,7 @@ data StackBuildException Version -- version specified on command line | NoSetupHsFound (Path Abs Dir) | InvalidFlagSpecification (Set UnusedFlags) + | TargetParseException [Text] deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -270,6 +271,10 @@ instance Show StackBuildException where ] where name = packageNameString (packageName pkg) pkgFlags = packageDefinedFlags pkg + show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err + show (TargetParseException errs) = unlines + $ "The following errors occurred while parsing the build targets:" + : map (("- " ++) . T.unpack) errs instance Exception StackBuildException @@ -335,6 +340,15 @@ instance Show ConstructPlanException where ---------------------------------------------- +-- | Which subset of packages to build +data BuildSubset + = BSAll + | BSOnlySnapshot + -- ^ Only install packages in the snapshot database, skipping + -- packages intended for the local database. + | BSOnlyDependencies + deriving Show + -- | Configuration for building. data BuildOpts = BuildOpts {boptsTargets :: ![Text] @@ -345,7 +359,6 @@ data BuildOpts = -- ^ Build haddocks? ,boptsHaddockDeps :: !(Maybe Bool) -- ^ Build haddocks for dependencies? - ,boptsFinalAction :: !FinalAction ,boptsDryrun :: !Bool ,boptsGhcOptions :: ![Text] ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) @@ -353,15 +366,25 @@ data BuildOpts = -- ^ Install executables to user path after building? ,boptsPreFetch :: !Bool -- ^ Fetch all packages immediately - ,boptsOnlySnapshot :: !Bool - -- ^ Only install packages in the snapshot database, skipping - -- packages intended for the local database. + ,boptsBuildSubset :: !BuildSubset ,boptsFileWatch :: !Bool -- ^ Watch files for changes and automatically rebuild ,boptsKeepGoing :: !(Maybe Bool) -- ^ Keep building/running after failure ,boptsForceDirty :: !Bool -- ^ Force treating all local packages as having dirty files + + ,boptsTests :: !Bool + -- ^ Turn on tests for local targets + ,boptsTestOpts :: !TestOpts + -- ^ Additional test arguments + + ,boptsBenchmarks :: !Bool + -- ^ Turn on benchmarks for local targets + ,boptsBenchmarkOpts :: !BenchmarkOpts + -- ^ Additional test arguments + ,boptsExec :: ![(String, [String])] + -- ^ Commands (with arguments) to run after a successful build } deriving (Show) @@ -373,16 +396,20 @@ defaultBuildOpts = BuildOpts , boptsEnableOptimizations = Nothing , boptsHaddock = False , boptsHaddockDeps = Nothing - , boptsFinalAction = DoNothing , boptsDryrun = False , boptsGhcOptions = [] , boptsFlags = Map.empty , boptsInstallExes = False , boptsPreFetch = False - , boptsOnlySnapshot = False + , boptsBuildSubset = BSAll , boptsFileWatch = False , boptsKeepGoing = Nothing , boptsForceDirty = False + , boptsTests = False + , boptsTestOpts = defaultTestOpts + , boptsBenchmarks = False + , boptsBenchmarkOpts = defaultBenchmarkOpts + , boptsExec = [] } -- | Options for the 'FinalAction' 'DoTests' @@ -393,17 +420,23 @@ data TestOpts = ,toDisableRun :: !Bool -- ^ Disable running of tests } deriving (Eq,Show) +defaultTestOpts :: TestOpts +defaultTestOpts = TestOpts + { toRerunTests = True + , toAdditionalArgs = [] + , toCoverage = False + , toDisableRun = False + } + -- | Options for the 'FinalAction' 'DoBenchmarks' data BenchmarkOpts = BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program } deriving (Eq,Show) --- | Run a Setup.hs action after building a package, before installing. -data FinalAction - = DoTests TestOpts - | DoBenchmarks BenchmarkOpts - | DoNothing - deriving (Eq,Show) +defaultBenchmarkOpts :: BenchmarkOpts +defaultBenchmarkOpts = BenchmarkOpts + { beoAdditionalArgs = Nothing + } -- | Package dependency oracle. newtype PkgDepsOracle = @@ -471,7 +504,7 @@ taskLocation task = -- | A complete plan of what needs to be built and how to do it data Plan = Plan { planTasks :: !(Map PackageName Task) - , planFinals :: !(Map PackageName Task) + , planFinals :: !(Map PackageName (Task, LocalPackageTB)) -- ^ Final actions to be taken (test, benchmark, etc) , planUnregisterLocal :: !(Map GhcPkgId Text) -- ^ Text is reason we're unregistering, for display only diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 0e3c19793d..73d2162b89 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -240,6 +240,9 @@ data BuildConfig = BuildConfig -- different from bcRoot "stack.yaml" , bcFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Per-package flag overrides + , bcImplicitGlobal :: !Bool + -- ^ Are we loading from the implicit global stack.yaml? This is useful + -- for providing better error messages. } -- | Directory containing the project's stack.yaml file diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 1b0931d529..030ad0e165 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | @@ -23,6 +24,7 @@ import Data.Maybe import Data.Monoid import Data.Set (Set) import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import Distribution.InstalledPackageInfo (PError) import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) @@ -159,20 +161,52 @@ class PackageInstallInfo a where piiVersion :: a -> Version piiLocation :: a -> InstallLocation +-- | Second-stage build information: tests and benchmarks +data LocalPackageTB = LocalPackageTB + { lptbPackage :: !Package + -- ^ Package resolved with dependencies for tests and benchmarks, depending + -- on which components are active + , lptbTests :: !(Set Text) + -- ^ Test components + , lptbBenches :: !(Set Text) + -- ^ Benchmark components + } + deriving Show + -- | Information on a locally available package of source code data LocalPackage = LocalPackage - { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any final actions - , lpPackageFinal :: !Package -- ^ Same as lpPackage, but with any test suites or benchmarks enabled as necessary - , lpWanted :: !Bool -- ^ Is this package a \"wanted\" target based on command line input + { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks + , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target + + , lpTestBench :: !(Maybe LocalPackageTB) + , lpDir :: !(Path Abs Dir) -- ^ Directory of the package. , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build? , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package - , lpComponents :: !(Set Text) -- ^ components to build, passed directly to Setup.hs build + , lpComponents :: !(Set NamedComponent) } deriving Show +-- | Is the given local a target +lpWanted :: LocalPackage -> Bool +lpWanted lp = isJust (lpExeComponents lp) || isJust (lpTestBench lp) + +-- | A single, fully resolved component of a package +data NamedComponent + = CLib + | CExe !Text + | CTest !Text + | CBench !Text + deriving (Show, Eq, Ord) + +renderComponent :: NamedComponent -> S.ByteString +renderComponent CLib = "lib" +renderComponent (CExe x) = "exe:" <> encodeUtf8 x +renderComponent (CTest x) = "test:" <> encodeUtf8 x +renderComponent (CBench x) = "bench:" <> encodeUtf8 x + -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local deriving (Show, Eq) diff --git a/src/main/Main.hs b/src/main/Main.hs index 90a31dfd13..28de296ce9 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -151,32 +151,28 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> fixCodePage $ globalOptsParser isTerminal) (do addCommand "build" "Build the project(s) in this directory/configuration" - (buildCmd DoNothing) - (buildOptsParser Build False) + (buildCmd Nothing) + (buildOptsParser Build) addCommand "install" - "Identical to 'build --copy-bins', not actually a managed installation tool!" - installCmd - (buildOptsParser Build True) + "Shortcut for 'build --copy-bins'" + (buildCmd $ Just ("install", "copy-bins")) + (buildOptsParser Install) addCommand "uninstall" "DEPRECATED: This command performs no actions, and is present for documentation only" uninstallCmd (many $ strArgument $ metavar "IGNORED") addCommand "test" - "Build and test the project(s) in this directory/configuration" - (\(bopts, topts) -> - let bopts' = if toCoverage topts - then bopts { boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts} - else bopts - in buildCmd (DoTests topts) bopts') - ((,) <$> buildOptsParser Test False <*> testOptsParser) + "Shortcut for 'build --test'" + (buildCmd $ Just ("test", "test")) + (buildOptsParser Test) addCommand "bench" - "Build and benchmark the project(s) in this directory/configuration" - (\(bopts, beopts) -> buildCmd (DoBenchmarks beopts) bopts) - ((,) <$> buildOptsParser Bench False <*> benchOptsParser) + "Shortcut for 'build --bench'" + (buildCmd $ Just ("bench", "bench")) + (buildOptsParser Bench) addCommand "haddock" - "Generate haddocks for the project(s) in this directory/configuration" - (buildCmd DoNothing) - (buildOptsParser Haddock False) + "Shortcut for 'build --haddock'" + (buildCmd $ Just ("haddock", "haddock")) + (buildOptsParser Haddock) addCommand "new" "Create a brand new project" newCmd @@ -665,31 +661,23 @@ cleanCmd :: () -> GlobalOpts -> IO () cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) -- | Helper for build and install commands -buildCmdHelper :: StackT EnvConfig IO () -- ^ do before build - -> FinalAction -> BuildOpts -> GlobalOpts -> IO () -buildCmdHelper beforeBuild finalAction opts go +buildCmd :: Maybe (Text, Text) -- ^ option synonym + -> BuildOpts -> GlobalOpts -> IO () +buildCmd moptionSynonym opts go | boptsFileWatch opts = fileWatch inner | otherwise = inner $ const $ return () where inner setLocalFiles = withBuildConfigAndLock go $ \lk -> do - beforeBuild - Stack.Build.build setLocalFiles (Just lk) opts { boptsFinalAction = finalAction } - --- | Build the project. -buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO () -buildCmd = buildCmdHelper (return ()) - --- | Install -installCmd :: BuildOpts -> GlobalOpts -> IO () -installCmd = - buildCmdHelper warning DoNothing - where - warning = do - $logInfo "NOTE: the install command will copy executables to a destination directory" - $logInfo "It is functionally equivalent to the --copy-bins option" - -copyCmd :: BuildOpts -> GlobalOpts -> IO () -copyCmd opts = buildCmdHelper (return ()) DoNothing opts { boptsInstallExes = True } + case moptionSynonym of + Nothing -> return () + Just (cmd, opt) -> $logInfo $ T.concat + [ "NOTE: the " + , cmd + , " command is functionally equivalent to 'build --" + , opt + , "'" + ] + Stack.Build.build setLocalFiles (Just lk) opts uninstallCmd :: [String] -> GlobalOpts -> IO () uninstallCmd _ go = withConfigAndLock go $ do diff --git a/src/test/Stack/Build/ExecuteSpec.hs b/src/test/Stack/Build/ExecuteSpec.hs index fe7bb4294b..f4d317c54e 100644 --- a/src/test/Stack/Build/ExecuteSpec.hs +++ b/src/test/Stack/Build/ExecuteSpec.hs @@ -8,17 +8,4 @@ main :: IO () main = hspec spec spec :: Spec -spec = describe "compareTestComponents" $ do - let test comps names expected = it (show (comps, names)) $ - compareTestsComponents - (T.words $ T.pack comps) - (T.words $ T.pack names) - `shouldBe` - (T.words $ T.pack expected) - - test "" "" "" - test "" "foo" "foo" - test "foo" "bar" "" - test "foo" "foo bar" "foo" - test "test:foo" "foo bar" "foo" - test "test:foo exe:bar" "foo bar" "foo" +spec = return () diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs new file mode 100644 index 0000000000..5cc420cf2f --- /dev/null +++ b/src/test/Stack/Build/TargetSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Stack.Build.TargetSpec (main, spec) where + +import qualified Data.Text as T +import Stack.Build.Target +import Stack.Types +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "parseRawTarget" $ do + let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e + test "foobar" $ Just $ RTPackage $(mkPackageName "foobar") + test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier + $(mkPackageName "foobar") $(mkVersion "1.2.3") + test "./foobar" Nothing + test "foobar/" Nothing + test "/foobar" Nothing + test ":some-exe" $ Just $ RTComponent "some-exe" + test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe" + test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") + $ ResolvedComponent $ CExe "some-exe" diff --git a/stack.cabal b/stack.cabal index 62d7b779e5..cb7a665966 100644 --- a/stack.cabal +++ b/stack.cabal @@ -79,6 +79,7 @@ library Stack.Build.Haddock Stack.Build.Installed Stack.Build.Source + Stack.Build.Target Stack.Upgrade Stack.Upload System.Process.Read @@ -219,6 +220,7 @@ test-suite stack-test other-modules: Spec , Stack.BuildPlanSpec , Stack.Build.ExecuteSpec + , Stack.Build.TargetSpec , Stack.ConfigSpec , Stack.DotSpec , Stack.PackageDumpSpec diff --git a/test/integration/tests/617-extra-dep-flag/Main.hs b/test/integration/tests/617-extra-dep-flag/Main.hs index e61b083aa4..50fcae4fa6 100644 --- a/test/integration/tests/617-extra-dep-flag/Main.hs +++ b/test/integration/tests/617-extra-dep-flag/Main.hs @@ -1,4 +1,4 @@ import StackTest main :: IO () -main = stack ["build"] +main = stack ["build", "acme-dont-1.1"]