stack 0.1.10.1 → 1.0.0
raw patch · 50 files changed
+1485/−910 lines, 50 filesdep +errorsdep +text-binarydep ~asyncdep ~attoparsecdep ~bifunctors
Dependencies added: errors, text-binary
Dependency ranges changed: async, attoparsec, bifunctors, email-validate, gitrev, path, stack, tar
Files
- ChangeLog.md +63/−0
- src/Data/Attoparsec/Args.hs +3/−63
- src/Data/Attoparsec/Interpreter.hs +136/−0
- src/Options/Applicative/Complicated.hs +1/−1
- src/Stack/Build.hs +1/−1
- src/Stack/Build/ConstructPlan.hs +1/−2
- src/Stack/Build/Execute.hs +65/−42
- src/Stack/Build/Installed.hs +4/−5
- src/Stack/Build/Source.hs +3/−4
- src/Stack/BuildPlan.hs +5/−5
- src/Stack/Config.hs +8/−7
- src/Stack/Config/Nix.hs +30/−12
- src/Stack/Constants.hs +1/−1
- src/Stack/Coverage.hs +17/−33
- src/Stack/Docker.hs +19/−14
- src/Stack/Docker/GlobalDB.hs +7/−7
- src/Stack/GhcPkg.hs +1/−1
- src/Stack/Ghci.hs +27/−3
- src/Stack/Ide.hs +1/−0
- src/Stack/Image.hs +7/−4
- src/Stack/Init.hs +1/−1
- src/Stack/New.hs +66/−30
- src/Stack/Nix.hs +53/−18
- src/Stack/Options.hs +78/−21
- src/Stack/Package.hs +22/−15
- src/Stack/PackageDump.hs +44/−49
- src/Stack/PackageIndex.hs +7/−10
- src/Stack/Setup.hs +9/−11
- src/Stack/Setup/Installed.hs +4/−3
- src/Stack/Solver.hs +3/−3
- src/Stack/Types/Build.hs +2/−2
- src/Stack/Types/BuildPlan.hs +7/−10
- src/Stack/Types/Config.hs +19/−6
- src/Stack/Types/FlagName.hs +19/−22
- src/Stack/Types/GhcPkgId.hs +10/−19
- src/Stack/Types/Nix.hs +41/−20
- src/Stack/Types/Package.hs +1/−0
- src/Stack/Types/PackageIdentifier.hs +8/−11
- src/Stack/Types/PackageName.hs +17/−25
- src/Stack/Types/Sig.hs +1/−2
- src/Stack/Types/TemplateName.hs +36/−14
- src/Stack/Types/Version.hs +7/−8
- src/System/Process/Read.hs +33/−24
- src/main/Main.hs +421/−358
- src/test/Stack/ArgsSpec.hs +109/−7
- src/test/Stack/DotSpec.hs +2/−2
- src/test/Stack/PackageDumpSpec.hs +34/−0
- stack.cabal +17/−13
- stack.yaml +7/−1
- test/integration/lib/StackTest.hs +7/−0
ChangeLog.md view
@@ -1,5 +1,68 @@ # Changelog +## 1.0.0++Release notes:++* We're calling this version 1.0.0 in preparation for Stackage+ LTS 4. Note, however, that this does not mean the code's API+ will be stable as this is primarily an end-user tool.++Enhancements:++* Added flag `--profile` flag: passed with `stack build`, it will+ enable profiling, and for `--bench` and `--test` it will generate a+ profiling report by passing `+RTS -p` to the executable(s). Great+ for using like `stack build --bench --profile` (remember that+ enabling profile will slow down your benchmarks by >4x). Run `stack+ build --bench` again to disable the profiling and get proper speeds+* Added flag `--trace` flag: just like `--profile`, it enables+ profiling, but instead of generating a report for `--bench` and+ `--test`, prints out a stack trace on exception. Great for using+ like `stack build --test --trace`+* Nix: all options can be overriden on command line+ [#1483](https://github.com/commercialhaskell/stack/issues/1483)+* Nix: build environments (shells) are now pure by default.+* Make verbosity silent by default in script interpreter mode+ [#1472](https://github.com/commercialhaskell/stack/issues/1472)+* Show a message when resetting git commit fails+ [#1453](https://github.com/commercialhaskell/stack/issues/1453)+* Improve Unicode handling in project/package names+ [#1337](https://github.com/commercialhaskell/stack/issues/1337)+* Fix ambiguity between a stack command and a filename to execute (prefer+ `stack` subcommands)+ [#1471](https://github.com/commercialhaskell/stack/issues/1471)+* Support multi line interpreter directive comments+ [#1394](https://github.com/commercialhaskell/stack/issues/1394)+* Handle space separated pids in ghc-pkg dump (for GHC HEAD)+ [#1509](https://github.com/commercialhaskell/stack/issues/1509)+* Add ghci --no-package-hiding option+ [#1517](https://github.com/commercialhaskell/stack/issues/1517)+* `stack new` can download templates from URL+ [#1466](https://github.com/commercialhaskell/stack/issues/1466)++Bug fixes:++* Nix: stack exec options are passed properly to the stack sub process+ [#1538](https://github.com/commercialhaskell/stack/issues/1538)+* Nix: specifying a shell-file works in any current working directory+ [#1547](https://github.com/commercialhaskell/stack/issues/1547)+* Nix: use `--resolver` argument+* Docker: fix missing image message and '--docker-auto-pull'+* No HTML escaping for "stack new" template params+ [#1475](https://github.com/commercialhaskell/stack/issues/1475)+* Set permissions for generated .ghci script+ [#1480](https://github.com/commercialhaskell/stack/issues/1480)+* Restrict commands allowed in interpreter mode+ [#1504](https://github.com/commercialhaskell/stack/issues/1504)+* stack ghci doesn't see preprocessed files for executables+ [#1347](https://github.com/commercialhaskell/stack/issues/1347)+* All test suites run even when only one is requested+ [#1550](https://github.com/commercialhaskell/stack/pull/1550)+* Edge cases in broken templates give odd errors+ [#1535](https://github.com/commercialhaskell/stack/issues/1535)+* Fix test coverage bug on windows+ ## 0.1.10.1 Bug fixes:
src/Data/Attoparsec/Args.hs view
@@ -1,27 +1,16 @@ {-# LANGUAGE OverloadedStrings #-}--- | Parsing argument-like things.+-- | Parsing of stack command line arguments module Data.Attoparsec.Args ( EscapingMode(..) , argsParser , parseArgs- , withInterpreterArgs ) where import Control.Applicative import Data.Attoparsec.Text ((<?>)) import qualified Data.Attoparsec.Text as P-import Data.Attoparsec.Types (Parser)-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8')-import System.Directory (doesFileExist)-import System.Environment (getArgs, withArgs)-import System.IO (IOMode (ReadMode), withBinaryFile) -- | Mode for parsing escape characters. data EscapingMode@@ -35,7 +24,7 @@ -- | A basic argument parser. It supports space-separated text, and -- string quotation with identity escaping: \x -> x.-argsParser :: EscapingMode -> Parser Text [String]+argsParser :: EscapingMode -> P.Parser [String] argsParser mode = many (P.skipSpace *> (quoted <|> unquoted)) <* P.skipSpace <* (P.endOfInput <?> "unterminated string") where@@ -45,54 +34,5 @@ Escaping -> escaped <|> nonquote NoEscaping -> nonquote) escaped = P.char '\\' *> P.anyChar- nonquote = P.satisfy (not . (=='"'))+ nonquote = P.satisfy (/= '"') naked = P.satisfy (not . flip elem ("\" " :: String))---- | Use 'withArgs' on result of 'getInterpreterArgs'.-withInterpreterArgs :: String -> ([String] -> Bool -> IO a) -> IO a-withInterpreterArgs progName inner = do- (args, isInterpreter) <- getInterpreterArgs progName- withArgs args $ inner args isInterpreter---- | Check if command-line looks like it's being used as a script interpreter,--- and if so look for a @-- progName ...@ comment that contains additional--- arguments.-getInterpreterArgs :: String -> IO ([String], Bool)-getInterpreterArgs progName = do- args0 <- getArgs- case args0 of- (x:_) -> do- isFile <- doesFileExist x- if isFile- then do- margs <-- withBinaryFile x ReadMode $ \h ->- CB.sourceHandle h- $= CB.lines- $= CL.map killCR- $$ sinkInterpreterArgs progName- return $ case margs of- Nothing -> (args0, True)- Just args -> (args ++ "--" : args0, True)- else return (args0, False)- _ -> return (args0, False)- where- killCR bs- | S.null bs || S.last bs /= 13 = bs- | otherwise = S.init bs--sinkInterpreterArgs :: Monad m => String -> Sink ByteString m (Maybe [String])-sinkInterpreterArgs progName =- await >>= maybe (return Nothing) checkShebang- where- checkShebang bs- | "#!" `S.isPrefixOf` bs = fmap (maybe Nothing parseArgs') await- | otherwise = return (parseArgs' bs)-- parseArgs' bs =- case decodeUtf8' bs of- Left _ -> Nothing- Right t ->- case P.parseOnly (argsParser Escaping) t of- Right ("--":progName':rest) | progName' == progName -> Just rest- _ -> Nothing
+ src/Data/Attoparsec/Interpreter.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}+{- | This module implements parsing of additional arguments embedded in a+ comment when stack is invoked as a script interpreter++ ===Specifying arguments in script interpreter mode+ @/stack/@ can execute a Haskell source file using @/runghc/@ and if required+ it can also install and setup the compiler and any package dependencies+ automatically.++ For using a Haskell source file as an executable script on a Unix like OS,+ the first line of the file must specify @stack@ as the interpreter using a+ shebang directive e.g.++ > #!/usr/bin/env stack++ Additional arguments can be specified in a haskell comment following the+ @#!@ line. The contents inside the comment must be a single valid stack+ command line, starting with @stack@ as the command and followed by the+ options to use for executing this file.++ The comment must be on the line immediately following the @#!@ line. The+ comment must start in the first column of the line. When using a block style+ comment the command can be split on multiple lines.++ Here is an example of a single line comment:++ > #!/usr/bin/env stack+ > -- stack --resolver lts-3.14 --install-ghc runghc --package random++ Here is an example of a multi line block comment:++@+ #!\/usr\/bin\/env stack+ {\- stack+ --resolver lts-3.14+ --install-ghc+ runghc+ --package random+ -\}+@++ When the @#!@ line is not present, the file can still be executed+ using @stack \<file name\>@ command if the file starts with a valid stack+ interpreter comment. This can be used to execute the file on Windows for+ example.++ Nested block comments are not supported.+-}++module Data.Attoparsec.Interpreter+ ( interpreterArgsParser -- for unit tests+ , getInterpreterArgs+ ) where++import Control.Applicative+import Data.Attoparsec.Args+import Data.Attoparsec.Text ((<?>))+import qualified Data.Attoparsec.Text as P+import Data.Char (isSpace)+import Data.Conduit+import Data.Conduit.Attoparsec+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Text(decodeUtf8)+import Data.List (intercalate)+import Data.Text (pack)+import Stack.Constants+import System.IO (IOMode (ReadMode), withBinaryFile, stderr, hPutStrLn)++-- | Parser to extract the stack command line embedded inside a comment+-- after validating the placement and formatting rules for a valid+-- interpreter specification.+interpreterArgsParser :: String -> P.Parser String+interpreterArgsParser progName = P.option "" sheBangLine *> interpreterComment+ where+ sheBangLine = P.string "#!"+ *> P.manyTill P.anyChar P.endOfLine++ commentStart str = (P.string str <?> (progName ++ " options comment"))+ *> P.skipSpace+ *> (P.string (pack progName) <?> show progName)++ -- Treat newlines as spaces inside the block comment+ anyCharNormalizeSpace = let normalizeSpace c = if isSpace c then ' ' else c+ in P.satisfyWith normalizeSpace $ const True++ comment start end = commentStart start+ *> ((end >> return "")+ <|> (P.space *> (P.manyTill anyCharNormalizeSpace end <?> "-}")))++ lineComment = comment "--" (P.endOfLine <|> P.endOfInput)+ blockComment = comment "{-" (P.string "-}")+ interpreterComment = lineComment <|> blockComment++-- | Extract stack arguments from a correctly placed and correctly formatted+-- comment when it is being used as an interpreter+getInterpreterArgs :: String -> IO [String]+getInterpreterArgs file = do+ eArgStr <- withBinaryFile file ReadMode parseFile+ case eArgStr of+ Left err -> handleFailure $ decodeError err+ Right str -> parseArgStr str+ where+ parseFile h =+ CB.sourceHandle h+ =$= decodeUtf8+ $$ sinkParserEither (interpreterArgsParser stackProgName)++ -- FIXME We should print anything only when explicit verbose mode is+ -- specified by the user on command line. But currently the+ -- implementation does not accept or parse any command line flags in+ -- interpreter mode. We can only invoke the interpreter as+ -- "stack <file name>" strictly without any options.+ stackWarn s = hPutStrLn stderr $ stackProgName ++ ": WARNING! " ++ s++ handleFailure err = do+ mapM_ stackWarn (lines err)+ stackWarn "Missing or unusable stack options specification"+ stackWarn "Using runghc without any additional stack options"+ return ["runghc"]++ parseArgStr str =+ case P.parseOnly (argsParser Escaping) (pack str) of+ Left err -> handleFailure ("Error parsing command specified in the \+ \stack options comment: " ++ err)+ Right [] -> handleFailure ("Empty argument list in stack options \+ \comment")+ Right args -> return args++ decodeError e =+ case e of+ ParseError ctxs _ (Position line col) ->+ if length ctxs == 0+ then "Parse error"+ else ("Expecting " ++ (intercalate " or " ctxs))+ ++ " at line " ++ (show line) ++ ", column " ++ (show col)+ DivergentParser -> "Divergent parser"
src/Options/Applicative/Complicated.hs view
@@ -132,7 +132,7 @@ hsubparser' :: Mod CommandFields a -> Parser a hsubparser' m = mkParser d g rdr where- Mod _ d g = m `mappend` metavar "COMMAND"+ Mod _ d g = m `mappend` metavar "COMMAND|FILE" (cmds, subs) = mkCommand m rdr = CmdReader cmds (fmap add_helper . subs) add_helper pinfo = pinfo
src/Stack/Build.hs view
@@ -201,7 +201,7 @@ localExes = collect [ (exe,packageName pkg)- | pkg <- map (lpPackage) locals+ | pkg <- map lpPackage locals , exe <- Set.toList (packageExes pkg) ] collect :: Ord k => [(k,v)] -> Map k (NonEmpty v)
src/Stack/Build/ConstructPlan.hs view
@@ -19,7 +19,6 @@ import Control.Monad.Logger (MonadLogger, logWarn) import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource-import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.Function import Data.List@@ -180,7 +179,7 @@ , combinedMap = combineMap sourceMap installedMap , toolToPackages = \ (Dependency name _) -> maybe Map.empty (Map.fromSet (const anyVersion)) $- Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap+ Map.lookup (T.pack . packageNameString . fromCabalPackageName $ name) toolMap , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0
src/Stack/Build/Execute.hs view
@@ -24,19 +24,20 @@ import Control.Concurrent.STM import Control.Exception.Enclosed (catchIO, tryIO) import Control.Exception.Lifted-import Control.Monad (liftM, when, unless, void, join, guard, filterM, (<=<))+import Control.Monad (liftM, when, unless, void, join, filterM, (<=<)) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource-import Data.ByteString (ByteString)+import Data.Attoparsec.Text import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8 import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Text as CT+import Data.Either (isRight) import Data.Foldable (forM_, any) import Data.Function import Data.IORef.RunOnce (runOnce)@@ -55,7 +56,6 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock (getCurrentTime) import Data.Traversable (forM)-import Data.Word8 (_colon) import qualified Distribution.PackageDescription as C import Distribution.System (OS (Windows), Platform (Platform))@@ -222,7 +222,7 @@ getSetupExe setupHs tmpdir = do wc <- getWhichCompiler econfig <- asks getEnvConfig- platformDir <- platformVariantRelDir+ platformDir <- platformGhcRelDir let config = getConfig econfig baseNameS = concat [ "setup-Simple-Cabal-"@@ -487,7 +487,7 @@ let total = length actions loop prev | prev == total =- runInBase $ $logStickyDone ("Completed all " <> T.pack (show total) <> " actions.")+ runInBase $ $logStickyDone ("Completed " <> T.pack (show total) <> " action(s).") | otherwise = do when terminal $ runInBase $ $logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))@@ -626,13 +626,19 @@ if boptsReconfigure eeBuildOpts then return True else do+ -- We can ignore the components portion of the config+ -- cache, because it's just used to inform 'construct+ -- plan that we need to plan to build additional+ -- components. These components don't affect the actual+ -- package configuration.+ let ignoreComponents cc = cc { configCacheComponents = Set.empty } -- Determine the old and new configuration in the local directory, to -- determine if we need to reconfigure. mOldConfigCache <- tryGetConfigCache pkgDir mOldCabalMod <- tryGetCabalMod pkgDir - return $ fmap configCacheOpts mOldConfigCache /= Just (configCacheOpts newConfigCache)+ return $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache) || mOldCabalMod /= Just newCabalMod let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache when needConfig $ withMVar eeConfigureLock $ \_ -> do@@ -828,6 +834,7 @@ liftIO $ hClose h runResourceT $ CB.sourceFile (toFilePath logFile)+ =$= CT.decodeUtf8 $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir =$ CL.consume throwM $ CabalExitedUnsuccessfully@@ -1172,7 +1179,14 @@ hpcDir <- hpcDirFromDir pkgDir when needHpc (createTree hpcDir) - errs <- liftM Map.unions $ forM (Map.toList (packageTests package)) $ \(testName, suiteInterface) -> do+ let suitesToRun+ = [ testSuitePair+ | testSuitePair <- Map.toList $ packageTests package+ , let testName = fst testSuitePair+ , testName `elem` testsToRun+ ]++ errs <- liftM Map.unions $ forM suitesToRun $ \(testName, suiteInterface) -> do let stestName = T.unpack testName (testName', isTestTypeLib) <- case suiteInterface of@@ -1180,7 +1194,10 @@ C.TestSuiteExeV10{} -> return (stestName, False) interface -> throwM (TestSuiteTypeUnsupported interface) - exeName <- testExeName testName'+ let exeName = testName' +++ case configPlatform config of+ Platform _ Windows -> ".exe"+ _ -> "" tixPath <- liftM (pkgDir </>) $ parseRelFile $ exeName ++ ".tix" exePath <- liftM (buildDir </>) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName exists <- fileExists exePath@@ -1204,18 +1221,24 @@ [] -> "" _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args) announce $ "test (suite: " <> testName <> argsDisplay <> ")"- let cp = (proc (toFilePath exePath) args)++ -- Clear "Progress: ..." message before+ -- redirecting output.+ when (isNothing mlogFile) $ do+ $logStickyDone ""+ liftIO $ hFlush stdout+ liftIO $ hFlush stderr++ let output =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ cp = (proc (toFilePath exePath) args) { cwd = Just $ toFilePath pkgDir , Process.env = envHelper menv , std_in = CreatePipe- , std_out =- case mlogFile of- Nothing -> Inherit- Just (_, h) -> UseHandle h- , std_err =- case mlogFile of- Nothing -> Inherit- Just (_, h) -> UseHandle h+ , std_out = output+ , std_err = output } -- Use createProcess_ to avoid the log file being closed afterwards@@ -1226,11 +1249,14 @@ liftIO $ hPutStr inH $ show (logPath, testName) liftIO $ hClose inH ec <- liftIO $ waitForProcess ph+ -- Add a trailing newline, incase the test+ -- output didn't finish with a newline.+ when (isNothing mlogFile) ($logInfo "") -- Move the .tix file out of the package -- directory into the hpc work dir, for -- tidiness. when needHpc $- updateTixFile (packageName package) tixPath+ updateTixFile (packageName package) tixPath testName' return $ case ec of ExitSuccess -> Map.empty _ -> Map.singleton testName $ Just ec@@ -1297,7 +1323,8 @@ -- | Grab all output from the given @Handle@ and log it, stripping -- Template Haskell "Loading package" lines and making paths absolute. -- thread.-printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)+printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m,+ MonadThrow m) => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory@@ -1306,7 +1333,8 @@ -> m () printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $ CB.sourceHandle outH- $$ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir+ $$ CT.decodeUtf8+ =$ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir =$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level) -- | Strip Template Haskell "Loading package" lines and making paths absolute.@@ -1314,52 +1342,47 @@ => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory- -> ConduitM ByteString ByteString m ()+ -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $- CB.lines+ CT.lines =$ CL.map stripCarriageReturn =$ CL.filter (not . isTHLoading) =$ CL.mapM toAbsolutePath where -- | Is this line a Template Haskell "Loading package" line -- ByteString- isTHLoading :: S8.ByteString -> Bool+ isTHLoading :: Text -> Bool isTHLoading _ | not excludeTHLoading = False isTHLoading bs =- "Loading package " `S8.isPrefixOf` bs &&- ("done." `S8.isSuffixOf` bs || "done.\r" `S8.isSuffixOf` bs)+ "Loading package " `T.isPrefixOf` bs &&+ ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) -- | Convert GHC error lines with file paths to have absolute file paths toAbsolutePath bs | not makeAbsolute = return bs toAbsolutePath bs = do- let (x, y) = S.break (== _colon) bs+ let (x, y) = T.break (== ':') bs mabs <- if isValidSuffix y then do- efp <- liftIO $ tryIO $ resolveFile pkgDir (S8.unpack x)+ efp <- liftIO $ tryIO $ resolveFile pkgDir (T.unpack x) case efp of Left _ -> return Nothing- Right fp -> return $ Just $ S8.pack (toFilePath fp)+ Right fp -> return $ Just $ T.pack (toFilePath fp) else return Nothing case mabs of Nothing -> return bs- Just fp -> return $ fp `S.append` y+ Just fp -> return $ fp `T.append` y -- | Match the line:column format at the end of lines- isValidSuffix bs0 = maybe False (const True) $ do- guard $ not $ S.null bs0- guard $ S.head bs0 == _colon- (_, bs1) <- S8.readInt $ S.drop 1 bs0-- guard $ not $ S.null bs1- guard $ S.head bs1 == _colon- (_, bs2) <- S8.readInt $ S.drop 1 bs1-- guard $ (bs2 == ":" || bs2 == ": Warning:")+ isValidSuffix = isRight . parseOnly (lineCol <* endOfInput)+ lineCol = char ':' >> (decimal :: Parser Int)+ >> char ':' >> (decimal :: Parser Int)+ >> (string ":" <|> string ": Warning:")+ >> return () -- | Strip @\r@ characters from the byte vector. Used because Windows.- stripCarriageReturn :: ByteString -> ByteString- stripCarriageReturn = S8.filter (not . (=='\r'))+ stripCarriageReturn :: Text -> Text+ stripCarriageReturn = T.filter (/= '\r') -- | Find the Setup.hs or Setup.lhs in the given directory. If none exists, -- throw an exception.
src/Stack/Build/Installed.hs view
@@ -21,6 +21,7 @@ import Data.Conduit import qualified Data.Conduit.List as CL import Data.Function+import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.List import Data.Map.Strict (Map)@@ -87,9 +88,7 @@ loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2 let installedLibs = M.fromList $ map lhPair installedLibs3 - case mcache of- Nothing -> return ()- Just pcache -> saveInstalledCache (configInstalledCache bconfig) pcache+ F.forM_ mcache (saveInstalledCache (configInstalledCache bconfig)) -- Add in the executables that are installed, making sure to only trust a -- listed installation under the right circumstances (see below)@@ -191,8 +190,8 @@ [ "Ignoring package " , packageNameText (fst (lhPair lh)) ] ++- (maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb) ++- [ " due to "+ maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb +++ [ " due to" , case reason of Allowed -> " the impossible?!?!" NeedsProfiling -> " it needing profiling."
src/Stack/Build/Source.hs view
@@ -145,7 +145,7 @@ in (packageName p, PSLocal lp) , extraDeps3 , flip fmap (mbpPackages mbp) $ \mpi ->- (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi))+ PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) return (targets, mbp, locals, nonLocalTargets, sourceMap)@@ -205,8 +205,7 @@ -> Map PackageName a -- ^ locals -> [PackageName] -- ^ packages referenced by a flag -> m (Map PackageName Version)-convertSnapshotToExtra snapshot extra0 locals flags0 =- go Map.empty flags0+convertSnapshotToExtra snapshot extra0 locals = go Map.empty where go !extra [] = return extra go extra (flag:flags)@@ -417,7 +416,7 @@ $ Set.fromList unusedFlags -- | All flags for a local package-localFlags :: (Map (Maybe PackageName) (Map FlagName Bool))+localFlags :: Map (Maybe PackageName) (Map FlagName Bool) -> BuildConfig -> PackageName -> Map FlagName Bool
src/Stack/BuildPlan.hs view
@@ -53,6 +53,7 @@ import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set+import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time (Day)@@ -84,7 +85,7 @@ data BuildPlanException = UnknownPackages (Path Abs File) -- stack.yaml file- (Map PackageName (Maybe Version, (Set PackageName))) -- truly unknown+ (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown (Map PackageName (Set PackageIdentifier)) -- shadowed | SnapshotNotFound SnapName deriving (Typeable)@@ -283,7 +284,7 @@ } name = packageIdentifierName ident pd = resolvePackageDescription packageConfig gpd- exes = Set.fromList $ map (ExeName . S8.pack . exeName) $ executables pd+ exes = Set.fromList $ map (ExeName . T.pack . exeName) $ executables pd notMe = Set.filter (/= name) . Map.keysSet return (name, MiniPackageInfo { mpiVersion = packageIdentifierVersion ident@@ -368,7 +369,7 @@ type ToolMap = Map ByteString (Set PackageName) -- | Map from tool name to package providing it-getToolMap :: MiniBuildPlan -> Map ByteString (Set PackageName)+getToolMap :: MiniBuildPlan -> Map Text (Set PackageName) getToolMap mbp = Map.unionsWith Set.union @@ -406,8 +407,7 @@ parseJSON = withObject "Snapshots" $ \o -> Snapshots <$> (o .: "nightly" >>= parseNightly) <*> (fmap IntMap.unions- $ mapM parseLTS- $ map snd+ $ mapM (parseLTS . snd) $ filter (isLTS . fst) $ HM.toList o) where
src/Stack/Config.hs view
@@ -151,13 +151,12 @@ configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts- configNix <- nixOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidNixOpts+ configNix <- nixOptsFromMonoid (fmap fst mproject) mresolver configMonoidNixOpts os rawEnv <- liftIO getEnvironment- origEnv <- mkEnvOverride configPlatform- $ augmentPathMap (map toFilePath configMonoidExtraPath)- $ Map.fromList- $ map (T.pack *** T.pack) rawEnv+ pathsEnv <- augmentPathMap (map toFilePath configMonoidExtraPath)+ (Map.fromList (map (T.pack *** T.pack) rawEnv))+ origEnv <- mkEnvOverride configPlatform pathsEnv let configEnvOverride _ = return origEnv platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform,configPlatformVariant)@@ -204,6 +203,7 @@ configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions configAllowNewer = fromMaybe False configMonoidAllowNewer+ configDefaultTemplate = configMonoidDefaultTemplate return Config {..} @@ -277,7 +277,7 @@ -- ^ Config monoid from parsed command-line arguments -> Maybe (Path Abs File) -- ^ Override stack.yaml- -> Maybe (AbstractResolver)+ -> Maybe AbstractResolver -- ^ Override resolver -> m (LoadConfig m) loadConfig configArgs mstackYaml mresolver = do@@ -477,7 +477,8 @@ Nothing readInNull dirTmp commandName menv (resetCommand ++ [T.unpack commit])- Nothing+ (Just $ "Please ensure that commit " <> commit <>+ " exists within " <> url) case remotePackageType of RPTHttpTarball -> do
src/Stack/Config/Nix.hs view
@@ -6,31 +6,49 @@ ,StackNixException(..) ) where -import Data.Text (pack)+import Control.Monad (when)+import qualified Data.Text as T import Data.Maybe import Data.Typeable-import Path+import Distribution.System (OS (..)) import Stack.Types import Control.Exception.Lifted import Control.Monad.Catch (throwM,MonadCatch) -- | Interprets NixOptsMonoid options.-nixOptsFromMonoid :: (Monad m, MonadCatch m) => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts-nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do+nixOptsFromMonoid+ :: (Monad m, MonadCatch m)+ => Maybe Project+ -> Maybe AbstractResolver+ -> NixOptsMonoid+ -> OS+ -> m NixOpts+nixOptsFromMonoid mproject maresolver NixOptsMonoid{..} os = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable+ defaultPure = case os of+ OSX -> False+ _ -> True+ nixPureShell = fromMaybe defaultPure nixMonoidPureShell+ mresolver = case maresolver of+ Just (ARResolver resolver) -> Just resolver+ Just _ -> Nothing+ Nothing -> fmap projectResolver mproject+ pkgs = fromMaybe [] nixMonoidPackages nixPackages = case mproject of- Nothing -> nixMonoidPackages- Just p -> nixMonoidPackages ++ [case projectResolver p of- ResolverSnapshot (LTS x y) ->- pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")- _ -> pack "ghc"]+ Nothing -> pkgs+ Just _ -> pkgs ++ [case mresolver of+ Just (ResolverSnapshot (LTS x y)) ->+ T.pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")+ _ -> T.pack "ghc"] nixInitFile = nixMonoidInitFile- nixShellOptions = nixMonoidShellOptions- if not (null nixMonoidPackages) && isJust nixInitFile then+ nixShellOptions = fromMaybe [] nixMonoidShellOptions+ ++ prefixAll (T.pack "-I") (fromMaybe [] nixMonoidPath)+ when (not (null pkgs) && isJust nixInitFile) $ throwM NixCannotUseShellFileAndPackagesException- else return () return NixOpts{..}+ where prefixAll p (x:xs) = p : x : prefixAll p xs+ prefixAll _ _ = [] -- Exceptions thown specifically by Stack.Nix data StackNixException
src/Stack/Constants.hs view
@@ -212,7 +212,7 @@ => m (Path Rel Dir) distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)- platform <- platformVariantRelDir+ platform <- platformGhcRelDir wc <- getWhichCompiler -- Cabal version, suffixed with "_ghcjs" if we're using GHCJS. envDir <-
src/Stack/Coverage.hs view
@@ -8,7 +8,6 @@ module Stack.Coverage ( deleteHpcReports , updateTixFile- , testExeName , generateHpcReport , HpcReportOpts(..) , generateHpcReportForTargets@@ -28,7 +27,6 @@ import Data.Foldable (forM_, asum, toList) import Data.Function import Data.List-import Data.List.Extra (stripSuffix) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Maybe.Extra (mapMaybeM)@@ -39,7 +37,6 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import Data.Traversable (forM)-import Distribution.System (OS (Windows), Platform (Platform)) import Network.HTTP.Download (HasHttpManager) import Path import Path.Extra (toFilePathNoTrailingSep)@@ -66,33 +63,21 @@ -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)- => PackageName -> Path Abs File -> m ()-updateTixFile pkgName tixSrc = do- case stripSuffix ".tix" (toFilePath (filename tixSrc)) of- Nothing -> error "Invariant violated: updateTixFile expected a tix filepath."- Just testName -> do- exists <- fileExists tixSrc- when exists $ do- tixDest <- tixFilePath pkgName testName- removeFileIfExists tixDest- createTree (parent tixDest)- -- Remove exe modules because they are problematic. This could be revisited if there's a GHC- -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853- mtix <- readTixOrLog tixSrc- case mtix of- Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc)- Just tix -> do- liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)- removeFileIfExists tixSrc--testExeName :: (MonadReader env m,HasConfig env) => String -> m String-testExeName testName = do- config <- asks getConfig- let exeExtension =- case configPlatform config of- Platform _ Windows -> ".exe"- _ -> ""- return $ testName ++ exeExtension+ => PackageName -> Path Abs File -> String -> m ()+updateTixFile pkgName tixSrc testName = do+ exists <- fileExists tixSrc+ when exists $ do+ tixDest <- tixFilePath pkgName testName+ removeFileIfExists tixDest+ createTree (parent tixDest)+ -- Remove exe modules because they are problematic. This could be revisited if there's a GHC+ -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853+ mtix <- readTixOrLog tixSrc+ case mtix of+ Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc)+ Just tix -> do+ liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)+ removeFileIfExists tixSrc -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)@@ -108,8 +93,7 @@ => PackageName -> String -> m (Path Abs File) tixFilePath pkgName testName = do pkgPath <- hpcPkgPath pkgName- exeName <- testExeName testName- tixRel <- parseRelFile (testName ++ "/" ++ exeName ++ ".tix")+ tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix") return (pkgPath </> tixRel) -- | Generates the HTML coverage report and shows a textual coverage summary for a package.@@ -202,7 +186,7 @@ generateHpcErrorReport reportDir (msg True) else do -- Print output, stripping @\r@ characters because Windows.- forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))+ forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (/= '\r')) $logInfo ("The " <> report <> " is available at " <> T.pack (toFilePath (reportDir </> $(mkRelFile "hpc_index.html"))))
src/Stack/Docker.hs view
@@ -9,6 +9,7 @@ ,CleanupAction(..) ,dockerCleanupCmdName ,dockerCmdName+ ,dockerHelpOptName ,dockerPullCmdName ,entrypoint ,preventInContainer@@ -37,7 +38,7 @@ import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf,foldl')-import Data.List.Extra (trim,nubOrd)+import Data.List.Extra (trim) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe@@ -67,7 +68,6 @@ import System.Environment (getEnv,getProgName,getArgs,getExecutablePath,lookupEnv) import System.Exit (exitSuccess, exitWith) import qualified System.FilePath as FP-import qualified System.FilePath.Posix as Posix import System.IO (stderr,stdin,stdout,hIsTerminalDevice) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO)@@ -288,16 +288,16 @@ -- This is fixed in Docker 1.9.1, but will leave the workaround -- in place for now, for users who haven't upgraded yet. (isTerm || (isNothing bamboo && isNothing jenkins))- newPathEnv = intercalate [Posix.searchPathSeparator] $- nubOrd $- [hostBinDir- ,toFilePathNoTrailingSep $ sandboxHomeDir </> $(mkRelDir ".local/bin")] ++- maybe [] Posix.splitSearchPath (lookupImageEnv "PATH" imageEnvVars)+ newPathEnv <- augmentPath+ [ hostBinDir+ , toFilePathNoTrailingSep $ sandboxHomeDir+ </> $(mkRelDir ".local/bin")]+ (T.pack <$> lookupImageEnv "PATH" imageEnvVars) (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker pwd <- getWorkingDir liftIO (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)- mapM_ createTree ([sandboxHomeDir, stackRoot]))+ mapM_ createTree [sandboxHomeDir, stackRoot]) containerID <- (trim . decodeUtf8) <$> readDockerProcess envOverride (concat@@ -307,7 +307,7 @@ ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot ,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir- ,"-e","PATH=" ++ newPathEnv+ ,"-e","PATH=" ++ T.unpack newPathEnv ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir@@ -332,7 +332,7 @@ before #ifndef WINDOWS runInBase <- liftBaseWith $ \run -> return (void . run)- oldHandlers <- forM ([sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2]) $ \sig -> do+ oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do let sigHandler = runInBase $ do readProcessNull Nothing envOverride "docker" ["kill","--signal=" ++ show sig,containerID]@@ -530,10 +530,10 @@ Nothing -> return () sortCreated = sortWith (\(_,_,x) -> Down x) .- (mapMaybe (\(h,r) ->+ mapMaybe (\(h,r) -> case Map.lookup h inspectMap of Nothing -> Nothing- Just ii -> Just (h,r,iiCreated ii)))+ Just ii -> Just (h,r,iiCreated ii)) buildSection sectionHead items itemBuilder = do let (anyWrote,b) = runWriter (forM items itemBuilder) when (or anyWrote) $@@ -571,7 +571,7 @@ projectPath) buildInspect hash = case Map.lookup hash inspectMap of- Just (Inspect{iiCreated,iiVirtualSize}) ->+ Just Inspect{iiCreated,iiVirtualSize} -> buildInfo ("Created " ++ showDaysAgo iiCreated ++ maybe ""@@ -629,7 +629,9 @@ case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of Left msg -> throwM (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))- Left e -> throwM (e :: ReadProcessException)+ Left (ReadProcessException _ _ _ err)+ | "Error: No such image" `LBS.isPrefixOf` err -> return Map.empty+ Left e -> throwM e -- | Pull latest version of configured Docker image from registry. pull :: M env m => m ()@@ -843,6 +845,9 @@ -- | Command-line argument for "docker" dockerCmdName :: String dockerCmdName = "docker"++dockerHelpOptName :: String+dockerHelpOptName = dockerCmdName ++ "-help" -- | Command-line argument for @docker pull@. dockerPullCmdName :: String
src/Stack/Docker/GlobalDB.hs view
@@ -16,10 +16,11 @@ where import Control.Exception (IOException,catch,throwIO)-import Control.Monad (forM_)+import Control.Monad (forM_, when) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Resource (ResourceT) import Data.List (sortBy, isInfixOf, stripPrefix)+import Data.List.Extra (stripSuffix) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Text as T@@ -75,11 +76,11 @@ pruneDockerImagesLastUsed :: Config -> [String] -> IO () pruneDockerImagesLastUsed config existingHashes = withGlobalDB config go- where go = do l <- selectList [] []- forM_ l (\(Entity k (DockerImageProject{dockerImageProjectImageHash = h})) ->- if h `elem` existingHashes- then return ()- else delete k)+ where+ go = do+ l <- selectList [] []+ forM_ l (\(Entity k DockerImageProject{dockerImageProjectImageHash = h}) ->+ when (h `notElem` existingHashes) $ delete k) -- | Get the record of whether an executable is compatible with a Docker image getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool)@@ -105,7 +106,6 @@ action) `catch` \ex -> do let str = show ex- stripSuffix x = fmap reverse . stripPrefix x . reverse str' = fromMaybe str $ stripPrefix "user error (" $ fromMaybe str $ stripSuffix ")" str if "ErrorReadOnly" `isInfixOf` str
src/Stack/GhcPkg.hs view
@@ -134,7 +134,7 @@ findGhcPkgVersion menv wc pkgDbs name = do mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version" case mv of- Just !v -> return (parseVersion (T.encodeUtf8 v))+ Just !v -> return (parseVersion v) _ -> return Nothing unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)
src/Stack/Ghci.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} -- | Run a GHCi configured with the user's package(s). @@ -52,6 +53,10 @@ import Stack.Types.Internal import System.Directory (getTemporaryDirectory) +#ifndef WINDOWS+import qualified System.Posix.Files as Posix+#endif+ -- | Command-line options for GHC. data GhciOpts = GhciOpts { ghciNoBuild :: !Bool@@ -61,6 +66,7 @@ , ghciAdditionalPackages :: ![String] , ghciMainIs :: !(Maybe Text) , ghciSkipIntermediate :: !Bool+ , ghciHidePackages :: !Bool , ghciBuildOpts :: !BuildOpts } deriving Show @@ -93,8 +99,11 @@ mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs wc <- getWhichCompiler let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts- hidePkgOpt = if null pkgs then [] else ["-hide-all-packages"]- genOpts = nubOrd (concatMap (concatMap (bioOneWordOpts . snd) . ghciPkgOpts) pkgs)+ hidePkgOpt = if null pkgs || not ghciHidePackages then [] else ["-hide-all-packages"]+ oneWordOpts bio+ | ghciHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio+ | otherwise = bioOneWordOpts bio+ genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs) (omittedOpts, ghcOpts) = partition badForGhci $ concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ getUserOptions Nothing ++@@ -139,6 +148,7 @@ loadModules = ":load " <> unwords (map show thingsToLoad) bringIntoScope = ":module + " <> unwords modulesToLoad liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))+ setScriptPerms fp execGhci (macrosOpts ++ ["-ghci-script=" <> fp]) -- | Figure out the main-is file to load based on the targets. Sometimes there@@ -438,8 +448,22 @@ preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String] preprocessCabalMacros pkgs out = liftIO $ do- let fps = nubOrd (concatMap (catMaybes . map (bioCabalMacros . snd) . ghciPkgOpts) pkgs)+ let fps = nubOrd (concatMap (mapMaybe (bioCabalMacros . snd) . ghciPkgOpts) pkgs) files <- mapM (S8.readFile . toFilePath) fps if null files then return [] else do S8.writeFile (toFilePath out) $ S8.intercalate "\n#undef CURRENT_PACKAGE_KEY\n" files return ["-optP-include", "-optP" <> toFilePath out]++setScriptPerms :: MonadIO m => FilePath -> m ()+#ifdef WINDOWS+setScriptPerms _ = do+ return ()+#else+setScriptPerms fp = do+ liftIO $ Posix.setFileMode fp $ foldl1 Posix.unionFileModes+ [ Posix.ownerReadMode+ , Posix.ownerWriteMode+ , Posix.groupReadMode+ , Posix.otherReadMode+ ]+#endif
src/Stack/Ide.hs view
@@ -100,6 +100,7 @@ let ghcOptions bio = bioOneWordOpts bio ++ bioOpts bio +++ bioPackageFlags bio ++ maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio) return ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) :
src/Stack/Image.hs view
@@ -95,13 +95,17 @@ imageName :: Path Abs Dir -> String imageName = map toLower . toFilePathNoTrailingSep . dirname +mkDockerConfig :: (HasConfig e, MonadReader e m) => m (Maybe ImageDockerOpts)+mkDockerConfig = do+ config <- asks getConfig+ return (imgDocker (configImage config))+ -- | Create a general purpose docker image from the temporary -- directory of executables & static content. createDockerImage :: Assemble e m => Path Abs Dir -> m () createDockerImage dir = do menv <- getMinimalEnvOverride- config <- asks getConfig- let dockerConfig = imgDocker (configImage config)+ dockerConfig <- mkDockerConfig case imgDockerBase =<< dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do@@ -125,8 +129,7 @@ extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m () extendDockerImageWithEntrypoint dir = do menv <- getMinimalEnvOverride- config <- asks getConfig- let dockerConfig = imgDocker (configImage config)+ dockerConfig <- mkDockerConfig let dockerImageName = fromMaybe (imageName (parent (parent dir))) (imgDockerImageName =<< dockerConfig)
src/Stack/Init.hs view
@@ -130,7 +130,7 @@ \# system-ghc: true\n\n\ \# Require a specific version of stack, using version ranges\n\ \# require-stack-version: -any # Default\n\- \# require-stack-version: >= 0.1.10.0\n\n\+ \# require-stack-version: >= 1.0.0\n\n\ \# Override the architecture used by stack, especially useful on Windows\n\ \# arch: i386\n\ \# arch: x86_64\n\n\
src/Stack/New.hs view
@@ -16,6 +16,7 @@ , listTemplates) where +import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class@@ -27,9 +28,11 @@ import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Conduit+import Data.Foldable (asum) import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe) import Data.Maybe.Extra (mapMaybeM) import Data.Monoid import Data.Set (Set)@@ -45,6 +48,7 @@ import Network.HTTP.Types.Status import Path import Path.IO+import Prelude import Stack.Constants import Stack.Types import Stack.Types.TemplateName@@ -62,7 +66,7 @@ -- ^ Name of the project to create. , newOptsCreateBare :: Bool -- ^ Whether to create the project without a directory.- , newOptsTemplate :: TemplateName+ , newOptsTemplate :: Maybe TemplateName -- ^ Name of the template to use. , newOptsNonceParams :: Map Text Text -- ^ Nonce parameters specified just for this invocation.@@ -70,7 +74,7 @@ -- | Create a new project with the given options. new- :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r)+ :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r, Functor m, Applicative m) => NewOpts -> m (Path Abs Dir) new opts = do pwd <- getWorkingDir@@ -78,11 +82,14 @@ else do relDir <- parseRelDir (packageNameString project) liftM (pwd </>) (return relDir) exists <- dirExists absDir+ configTemplate <- configDefaultTemplate <$> asks getConfig+ let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate+ , configTemplate+ ] if exists && not bare then throwM (AlreadyExists absDir) else do- logUsing absDir- templateText <- loadTemplate template+ templateText <- loadTemplate template (logUsing absDir template) files <- applyTemplate project@@ -94,12 +101,16 @@ runTemplateInits absDir return absDir where- template = newOptsTemplate opts+ cliOptionTemplate = newOptsTemplate opts project = newOptsProjectName opts bare = newOptsCreateBare opts- logUsing absDir =+ logUsing absDir template templateFrom =+ let loading = case templateFrom of+ LocalTemp -> "Loading local"+ RemoteTemp -> "Downloading"+ in $logInfo- ("Downloading template \"" <> templateName template <>+ (loading <> " template \"" <> templateName template <> "\" to create project \"" <> packageNameText project <> "\" in " <>@@ -107,44 +118,56 @@ else T.pack (toFilePath (dirname absDir)) <> " ...") +data TemplateFrom = LocalTemp | RemoteTemp+ -- | Download and read in a template's text content. loadTemplate :: forall m r.- (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m)- => TemplateName -> m Text-loadTemplate name =+ (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, Functor m, Applicative m)+ => TemplateName -> (TemplateFrom -> m ()) -> m Text+loadTemplate name logIt = do+ templateDir <- templatesDir <$> asks getConfig case templatePath name of- Left absFile -> loadLocalFile absFile- Right relFile ->+ AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile+ UrlPath s -> do+ let req = fromMaybe (error "impossible happened: already valid \+ \URL couldn't be parsed")+ (parseUrl s)+ rel = fromMaybe backupUrlRelPath (parseRelFile s)+ downloadTemplate req (templateDir </> rel)+ RelPath relFile -> catch- (loadLocalFile relFile)- (\(_ :: NewException) ->- downloadTemplate relFile)+ (loadLocalFile relFile <* logIt LocalTemp)+ (\(e :: NewException) ->+ case relRequest relFile of+ Just req -> downloadTemplate req+ (templateDir </> relFile)+ Nothing -> throwM e+ ) where loadLocalFile :: Path b File -> m Text loadLocalFile path = do+ $logDebug ("Opening local template: \"" <> T.pack (toFilePath path)+ <> "\"") exists <- fileExists path if exists then liftIO (T.readFile (toFilePath path)) else throwM (FailedToLoadTemplate name (toFilePath path))- downloadTemplate :: Path Rel File -> m Text- downloadTemplate rel = do- config <- asks getConfig- req <- parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel)- let path :: Path Abs File- path = templatesDir config </> rel+ relRequest :: MonadThrow n => Path Rel File -> n Request+ relRequest rel = parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel)+ downloadTemplate :: Request -> Path Abs File -> m Text+ downloadTemplate req path = do+ logIt RemoteTemp _ <- catch (redownload req path) (throwM . FailedToDownloadTemplate name)- exists <- fileExists path- if exists- then liftIO (T.readFile (toFilePath path))- else throwM (FailedToLoadTemplate name (toFilePath path))+ loadLocalFile path+ backupUrlRelPath = $(mkRelFile "downloaded.template.file.hsfiles") -- | Apply and unpack a template into a directory. applyTemplate- :: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m)+ :: (MonadIO m, MonadThrow m, MonadCatch m, MonadReader r m, HasConfig r, MonadLogger m) => PackageName -> TemplateName -> Map Text Text@@ -160,15 +183,23 @@ (applied,missingKeys) <- runWriterT (hastacheStr- defaultConfig+ defaultConfig { muEscapeFunc = id } templateText (mkStrContextM (contextFunction context))) unless (S.null missingKeys) ($logInfo (T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))))) files :: Map FilePath LB.ByteString <-- execWriterT $- yield (T.encodeUtf8 (LT.toStrict applied)) $$- unpackTemplate receiveMem id+ catch (execWriterT $+ yield (T.encodeUtf8 (LT.toStrict applied)) $$+ unpackTemplate receiveMem id+ )+ (\(e :: ProjectTemplateException) ->+ throwM (InvalidTemplate template (show e)))+ when (M.null files) $+ throwM (InvalidTemplate template "Template does not contain any files")+ unless (any (".cabal" `isSuffixOf`) . M.keys $ files) $+ throwM (InvalidTemplate template "Template does not contain a .cabal\+ \ file") liftM M.fromList (mapM@@ -296,6 +327,7 @@ | BadTemplatesJSON !String !LB.ByteString | AlreadyExists !(Path Abs Dir) | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)+ | InvalidTemplate !TemplateName !String deriving (Typeable) instance Exception NewException@@ -350,3 +382,7 @@ (\key -> "-p \"" <> key <> ":value\"") (S.toList missingKeys))]+ show (InvalidTemplate name why) =+ "The template \"" <> T.unpack (templateName name) <>+ "\" is invalid and could not be used. " <>+ "The error was: \"" <> why <> "\""
src/Stack/Nix.hs view
@@ -1,14 +1,19 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -- | Run commands in a nix-shell module Stack.Nix (reexecWithOptionalShell ,nixCmdName+ ,nixHelpOptName ) where import Control.Applicative+import Control.Arrow ((***))+import Control.Exception (Exception,throw) import Control.Monad import Control.Monad.Catch (try,MonadCatch) import Control.Monad.IO.Class (MonadIO,liftIO)@@ -17,15 +22,19 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Data.Char (toUpper) import Data.List (intercalate)+import Data.Traversable import Data.Maybe import Data.Monoid import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import qualified Data.Text as T import Data.Version (showVersion)+import Data.Typeable (Typeable) import Network.HTTP.Client.Conduit (HasHttpManager)+import Path+import Path.IO import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings-import Stack.Constants (stackProgName)+import Stack.Constants (stackProgName,platformVariantEnvVar) import Stack.Docker (reExecArgName) import Stack.Exec (exec) import System.Process.Read (getEnvOverride)@@ -39,14 +48,15 @@ -- Otherwise, runs the inner action. reexecWithOptionalShell :: M env m- => IO ()+ => Maybe (Path Abs Dir)+ -> IO () -> m ()-reexecWithOptionalShell inner =+reexecWithOptionalShell mprojectRoot inner = do config <- asks getConfig inShell <- getInShell isReExec <- asks getReExec if nixEnable (configNix config) && not inShell && not isReExec- then runShellAndExit getCmdArgs+ then runShellAndExit mprojectRoot getCmdArgs else liftIO inner where getCmdArgs = do@@ -57,22 +67,28 @@ exePath <- liftIO getExecutablePath return (exePath, args) -runShellAndExit :: M env m- => m (String, [String])- -> m ()-runShellAndExit getCmdArgs = do+runShellAndExit+ :: M env m+ => Maybe (Path Abs Dir)+ -> m (String, [String])+ -> m ()+runShellAndExit mprojectRoot getCmdArgs = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config)- (cmnd,args) <- getCmdArgs- let mshellFile = nixInitFile (configNix config)- pkgsInConfig = nixPackages (configNix config)+ (cmnd,args) <- fmap (escape *** map escape) getCmdArgs+ mshellFile <-+ traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $+ nixInitFile (configNix config)+ let pkgsInConfig = nixPackages (configNix config)+ pureShell = nixPureShell (configNix config) nixopts = case mshellFile of- Just filePath -> [filePath]+ Just fp -> [toFilePath fp] Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat [["with (import <nixpkgs> {});" ,"runCommand \"myEnv\" {" ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgsInConfig,["];"- ,T.pack inShellEnvVar,"=1 ;"+ ,T.pack platformVariantEnvVar <> "=''nix'';"+ ,T.pack inShellEnvVar <> "=1;" ,"STACK_IN_NIX_EXTRA_ARGS=''"] , (map (\p -> T.concat ["--extra-lib-dirs=${",p,"}/lib"@@ -80,15 +96,15 @@ pkgsInConfig), ["'' ;" ,"} \"\""]]] -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.- fullArgs = concat [ -- ["--pure"],+ fullArgs = concat [if pureShell then ["--pure"] else [], map T.unpack (nixShellOptions (configNix config)) ,nixopts- ,["--command", intercalate " " (map escape (cmnd:args))- ++ " $STACK_IN_NIX_EXTRA_ARGS"]+ ,["--command", intercalate " " (cmnd:"$STACK_IN_NIX_EXTRA_ARGS":args)] ]+ $logDebug $ "Using a nix-shell environment " <> (case mshellFile of- Just filePath -> "from file: " <> (T.pack filePath)+ Just path -> "from file: " <> (T.pack (toFilePath path)) Nothing -> "with nix packages: " <> (T.intercalate ", " pkgsInConfig)) e <- try (exec envOverride "nix-shell" fullArgs) case e of@@ -102,6 +118,10 @@ else (c:)) "" str ++ "'" +-- | Fail with friendly error if project root not set.+fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir+fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)+ -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar)@@ -115,6 +135,21 @@ -- | Command-line argument for "nix" nixCmdName :: String nixCmdName = "nix"++nixHelpOptName :: String+nixHelpOptName = nixCmdName ++ "-help"++-- | Exceptions thrown by "Stack.Nix".+data StackNixException+ = CannotDetermineProjectRootException+ -- ^ Can't determine the project root (location of the shell file if any).+ deriving (Typeable)++instance Exception StackNixException++instance Show StackNixException where+ show CannotDetermineProjectRootException =+ "Cannot determine project root directory." type M env m = (MonadIO m
src/Stack/Options.hs view
@@ -80,13 +80,51 @@ buildOptsParser :: Command -> Parser BuildOpts buildOptsParser cmd =+ transform <$> trace <*> profile <*> options+ where transform tracing profiling = enable+ where enable opts+ | tracing || profiling =+ opts {boptsLibProfile = True+ ,boptsExeProfile = True+ ,boptsGhcOptions = ["-auto-all","-caf-all"]+ ,boptsBenchmarkOpts =+ bopts {beoAdditionalArgs =+ beoAdditionalArgs bopts <>+ Just (unwords additionalArgs)}+ ,boptsTestOpts =+ topts {toAdditionalArgs =+ (toAdditionalArgs topts) <>+ additionalArgs}}+ | otherwise = opts+ where bopts = boptsBenchmarkOpts opts+ topts = boptsTestOpts opts+ additionalArgs = [" +RTS ", trac, prof]+ trac = if tracing+ then " -xc "+ else ""+ prof = if profiling+ then " -p "+ else ""+ profile =+ flag False True+ ( long "profile"+ <> help "Enable profiling in libraries, executables, etc. \+ \for all expressions and generate a profiling report\+ \ in exec or benchmarks")+ trace =+ flag False True+ ( long "trace"+ <> help "Enable profiling in libraries, executables, etc. \+ \for all expressions and generate a backtrace on \+ \exception")+ options = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*> flags <*> copyBins <*> preFetch <*> buildSubset <*> fileWatch' <*> keepGoing <*> forceDirty <*> tests <*> testOptsParser <*> benches <*> benchOptsParser <*> many exec <*> onlyConfigure <*> reconfigure <*> cabalVerbose- where target =+ target = many (textArgument (metavar "TARGET" <> help "If none specified, use all packages"))@@ -320,22 +358,40 @@ where hide = hideMods hide0 nixOptsParser :: Bool -> Parser NixOptsMonoid-nixOptsParser hide0 =- NixOptsMonoid+nixOptsParser hide0 = overrideActivation <$>+ (NixOptsMonoid <$> pure False <*> maybeBoolFlags nixCmdName- "using a Nix-shell"+ "use of a Nix-shell" hide- <*> pure []- <*> pure Nothing- <*> ((map T.pack . fromMaybe [])+ <*> maybeBoolFlags "nix-pure"+ "use of a pure Nix-shell"+ hide+ <*> (fmap (map T.pack)+ <$> optional (argsOption (long "nix-packages" <>+ metavar "NAMES" <>+ help "List of packages that should be available in the nix-shell (space separated)" <>+ hide)))+ <*> optional (option str (long "nix-shell-file" <>+ metavar "FILEPATH" <>+ help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>+ hide))+ <*> (fmap (map T.pack) <$> optional (argsOption (long "nix-shell-options" <>- metavar "OPTION" <>+ metavar "OPTIONS" <> help "Additional options passed to nix-shell" <> hide)))+ <*> (fmap (map T.pack)+ <$> optional (argsOption (long "nix-path" <>+ metavar "PATH_OPTIONS" <>+ help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>+ hide)))+ ) where hide = hideMods hide0-+ overrideActivation m =+ if m /= mempty then m { nixMonoidEnable = Just True }+ else m -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid@@ -397,7 +453,7 @@ hide <> metavar "PATH" <> help "Location of image usage tracking database")- <*> optional (option str+ <*> maybeStrOption (long(dockerOptName dockerStackExeArgName) <> hide <> metavar (intercalate "|"@@ -407,7 +463,7 @@ , "PATH" ]) <> help (concat [ "Location of " , stackProgName- , " executable used in container" ])))+ , " executable used in container" ])) <*> maybeBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide@@ -513,6 +569,7 @@ \module to load, such as for an executable for \ \test suite or benchmark.")) <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")+ <*> boolFlags True "package-hiding" "package hiding" idm <*> buildOptsParser Build -- | Parser for exec command@@ -565,12 +622,12 @@ help "Use an unmodified environment (only useful with Docker)") -- | Parser for global command-line options.-globalOptsParser :: Bool -> Parser GlobalOptsMonoid-globalOptsParser hide0 =+globalOptsParser :: Bool -> Maybe LogLevel -> Parser GlobalOptsMonoid+globalOptsParser hide0 defLogLevel = GlobalOptsMonoid <$> optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>- logLevelOptsParser hide0 <*>+ logLevelOptsParser hide0 defLogLevel <*> configOptsParser hide0 <*> optional (abstractResolverOptsParser hide0) <*> optional (compilerOptsParser hide0) <*>@@ -629,8 +686,8 @@ help "Use the given resolver, even if not all dependencies are met") -- | Parser for a logging level.-logLevelOptsParser :: Bool -> Parser (Maybe LogLevel)-logLevelOptsParser hide =+logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)+logLevelOptsParser hide defLogLevel = fmap (Just . parse) (strOption (long "verbosity" <> metavar "VERBOSITY" <>@@ -640,7 +697,7 @@ (short 'v' <> long "verbose" <> help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <> hideMods hide) <|>- pure Nothing+ pure defLogLevel where verboseLevel = LevelDebug showLevel l = case l of@@ -746,11 +803,11 @@ switch (long "bare" <> help "Do not create a subdirectory for the project") <*>- templateNameArgument+ optional (templateNameArgument (metavar "TEMPLATE_NAME" <>- help "Name of a template or a local template in a subdirectory,\- \ for example: foo or foo.hsfiles" <>- value defaultTemplateName) <*>+ help "Name of a template or a local template in a file or a URL.\+ \ For example: foo or foo.hsfiles or ~/foo or\+ \ https://example.com/foo.hsfiles")) <*> fmap M.fromList (many
src/Stack/Package.hs view
@@ -316,7 +316,8 @@ -- -- See https://github.com/commercialhaskell/stack/issues/1255 , bioOneWordOpts = nubOrd $ concat- [extOpts b, srcOpts, includeOpts, deps, extra b, extraDirs, fworks b, cObjectFiles]+ [extOpts b, srcOpts, includeOpts, extra b, extraDirs, fworks b, cObjectFiles]+ , bioPackageFlags = deps , bioCabalMacros = mcabalMacros } where@@ -348,7 +349,9 @@ (("-i" <>) . toFilePathNoTrailingSep) ([cabalDir | null (hsSourceDirs b)] <> mapMaybe toIncludeDir (hsSourceDirs b) <>- [autogenDir distDir,buildDir distDir]) +++ [autogenDir distDir,buildDir distDir] <>+ [makeGenDir (buildDir distDir)+ | Just makeGenDir <- [fileGenDirFromComponentName componentName]]) ++ ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir distDir)] toIncludeDir "." = Just cabalDir toIncludeDir x = fmap (cabalDir </>) (parseRelDir x)@@ -410,19 +413,23 @@ relCFilePath <- stripDir cabalDir cFilePath relOFilePath <- parseRelFile (replaceExtension (toFilePath relCFilePath) "o")- addComponentPrefix <- fromComponentName+ addComponentPrefix <- fileGenDirFromComponentName namedComponent return (addComponentPrefix (buildDir distDir) </> relOFilePath)- where- fromComponentName =- case namedComponent of- CLib -> return id- CExe name -> makeTmp name- CTest name -> makeTmp name- CBench name -> makeTmp name- makeTmp name = do- prefix <- parseRelDir (T.unpack name <> "/" <> T.unpack name <> "-tmp")- return (</> prefix) +-- | The directory where generated files are put like .o or .hs (from .x files).+fileGenDirFromComponentName+ :: MonadThrow m+ => NamedComponent -> m (Path b Dir -> Path b Dir)+fileGenDirFromComponentName namedComponent =+ case namedComponent of+ CLib -> return id+ CExe name -> makeTmp name+ CTest name -> makeTmp name+ CBench name -> makeTmp name+ where makeTmp name = do+ prefix <- parseRelDir (T.unpack name <> "/" <> T.unpack name <> "-tmp")+ return (</> prefix)+ -- | Make the autogen dir. autogenDir :: Path Abs Dir -> Path Abs Dir autogenDir distDir = buildDir distDir </> $(mkRelDir "autogen")@@ -445,10 +452,10 @@ allBuildInfo' -- | Get all build tool dependencies of the package (buildable targets only).-packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange+packageToolDependencies :: PackageDescription -> Map Text VersionRange packageToolDependencies = M.fromList .- concatMap (fmap (packageNameByteString . depName &&& depRange) .+ concatMap (fmap (packageNameText . depName &&& depRange) . buildTools) . allBuildInfo'
src/Stack/PackageDump.hs view
@@ -35,12 +35,9 @@ import Data.Attoparsec.Args import Data.Attoparsec.Text as P import Data.Binary.VersionTagged-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8 import Data.Conduit-import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Text as CT import Data.Either (partitionEithers) import Data.IORef import Data.Map (Map)@@ -48,7 +45,8 @@ import Data.Maybe (catMaybes, listToMaybe) import Data.Maybe.Extra (mapMaybeM) import qualified Data.Set as Set-import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Path@@ -83,7 +81,7 @@ => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global- -> Sink ByteString IO a+ -> Sink Text IO a -> m a ghcPkgDump = ghcPkgCmdArgs ["dump"] @@ -94,7 +92,7 @@ -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global- -> Sink ByteString IO a+ -> Sink Text IO a -> m a ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName] @@ -105,13 +103,13 @@ -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global- -> Sink ByteString IO a+ -> Sink Text IO a -> m a ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do case reverse mpkgDbs of (pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead? _ -> return ()- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink+ sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink' where args = concat [ case mpkgDbs of@@ -121,6 +119,7 @@ , cmd , ["--expand-pkgroot"] ]+ sink' = CT.decodeUtf8 =$= sink -- | Create a new, empty @InstalledCache@ newInstalledCache :: MonadIO m => m InstalledCache@@ -233,12 +232,12 @@ return dp { dpProfiling = p } isProfiling :: FilePath -- ^ entry in directory- -> ByteString -- ^ name of library+ -> Text -- ^ name of library -> Bool isProfiling content lib =- prefix `S.isPrefixOf` S8.pack content+ prefix `T.isPrefixOf` T.pack content where- prefix = S.concat ["lib", lib, "_p"]+ prefix = T.concat ["lib", lib, "_p"] -- | Add haddock information to the stream of @DumpPackage@s addHaddock :: MonadIO m@@ -268,7 +267,7 @@ { dpGhcPkgId :: !GhcPkgId , dpPackageIdent :: !PackageIdentifier , dpLibDirs :: ![FilePath]- , dpLibraries :: ![ByteString]+ , dpLibraries :: ![Text] , dpHasExposedModules :: !Bool , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![FilePath]@@ -280,8 +279,8 @@ deriving (Show, Eq, Ord) data PackageDumpException- = MissingSingleField ByteString (Map ByteString [Line])- | Couldn'tParseField ByteString [Line]+ = MissingSingleField Text (Map Text [Line])+ | Couldn'tParseField Text [Line] deriving Typeable instance Exception PackageDumpException instance Show PackageDumpException where@@ -298,7 +297,7 @@ -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m- => Conduit ByteString m (DumpPackage () ())+ => Conduit Text m (DumpPackage () ()) conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume let m = Map.fromList pairs@@ -310,15 +309,15 @@ -- https://github.com/fpco/stack/issues/182 parseM k = Map.findWithDefault [] k m - parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId)+ parseDepend :: MonadThrow m => Text -> m (Maybe GhcPkgId) parseDepend "builtin_rts" = return Nothing parseDepend bs = liftM Just $ parseGhcPkgId bs' where (bs', _builtinRts) =- case stripSuffixBS " builtin_rts" bs of+ case stripSuffixText " builtin_rts" bs of Nothing ->- case stripPrefixBS "builtin_rts " bs of+ case stripPrefixText "builtin_rts " bs of Nothing -> (bs, False) Just x -> (x, True) Just x -> (x, True)@@ -334,10 +333,10 @@ libraries = parseM "hs-libraries" exposedModules = parseM "exposed-modules" exposed = parseM "exposed"- depends <- mapMaybeM parseDepend $ parseM "depends"+ depends <- mapMaybeM parseDepend $ concatMap T.words $ parseM "depends" let parseQuoted key =- case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of+ case mapM (P.parseOnly (argsParser NoEscaping)) val of Left{} -> throwM (Couldn'tParseField key val) Right dirs -> return (concat dirs) where@@ -350,7 +349,7 @@ { dpGhcPkgId = ghcPkgId , dpPackageIdent = PackageIdentifier name version , dpLibDirs = libDirPaths- , dpLibraries = S8.words $ S8.unwords libraries+ , dpLibraries = T.words $ T.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces@@ -360,34 +359,33 @@ , dpIsExposed = exposed == ["True"] } -stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString-stripPrefixBS x y- | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y+stripPrefixText :: Text -> Text -> Maybe Text+stripPrefixText x y+ | x `T.isPrefixOf` y = Just $ T.drop (T.length x) y | otherwise = Nothing -stripSuffixBS :: ByteString -> ByteString -> Maybe ByteString-stripSuffixBS x y- | x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y+stripSuffixText :: Text -> Text -> Maybe Text+stripSuffixText x y+ | x `T.isSuffixOf` y = Just $ T.take (T.length y - T.length x) y | otherwise = Nothing -- | A single line of input, not including line endings-type Line = ByteString+type Line = Text -- | Apply the given Sink to each section of output, broken by a single line containing --- eachSection :: Monad m => Sink Line m a- -> Conduit ByteString m a+ -> Conduit Text m a eachSection inner =- CL.map (S.filter (/= _cr)) =$= CB.lines =$= start+ CL.map (T.filter (/= '\r')) =$= CT.lines =$= start where- _cr = 13 - peekBS = await >>= maybe (return Nothing) (\bs ->- if S.null bs- then peekBS+ peekText = await >>= maybe (return Nothing) (\bs ->+ if T.null bs+ then peekText else leftover bs >> return (Just bs)) - start = peekBS >>= maybe (return ()) (const go)+ start = peekText >>= maybe (return ()) (const go) go = do x <- toConsumer $ takeWhileC (/= "---") =$= inner@@ -397,25 +395,22 @@ -- | Grab each key/value pair eachPair :: Monad m- => (ByteString -> Sink Line m a)+ => (Text -> Sink Line m a) -> Conduit Line m a eachPair inner = start where start = await >>= maybe (return ()) start' - _colon = 58- _space = 32- start' bs1 = toConsumer (valSrc =$= inner key) >>= yield >> start where- (key, bs2) = S.break (== _colon) bs1- (spaces, bs3) = S.span (== _space) $ S.drop 1 bs2- indent = S.length key + 1 + S.length spaces+ (key, bs2) = T.break (== ':') bs1+ (spaces, bs3) = T.span (== ' ') $ T.drop 1 bs2+ indent = T.length key + 1 + T.length spaces valSrc- | S.null bs3 = noIndent+ | T.null bs3 = noIndent | otherwise = yield bs3 >> loopIndent indent noIndent = do@@ -423,12 +418,12 @@ case mx of Nothing -> return () Just bs -> do- let (spaces, val) = S.span (== _space) bs- if S.length spaces == 0+ let (spaces, val) = T.span (== ' ') bs+ if T.length spaces == 0 then leftover val else do yield val- loopIndent (S.length spaces)+ loopIndent (T.length spaces) loopIndent i = loop@@ -436,11 +431,11 @@ loop = await >>= maybe (return ()) go go bs- | S.length spaces == i && S.all (== _space) spaces =+ | T.length spaces == i && T.all (== ' ') spaces = yield val >> loop | otherwise = leftover bs where- (spaces, val) = S.splitAt i bs+ (spaces, val) = T.splitAt i bs -- | General purpose utility takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a
src/Stack/PackageIndex.hs view
@@ -34,10 +34,6 @@ import Data.Aeson.Extended import Data.Binary.VersionTagged-import qualified Data.Word8 as Word8-import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as SU-import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Conduit (($$), (=$)) import Data.Conduit.Binary (sinkHandle,@@ -50,6 +46,7 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Unsafe (unsafeTail) import Data.Traversable (forM) @@ -139,19 +136,19 @@ m breakSlash x- | S.null z = Nothing- | otherwise = Just (y, SU.unsafeTail z)+ | T.null z = Nothing+ | otherwise = Just (y, unsafeTail z) where- (y, z) = S.break (== Word8._slash) x+ (y, z) = T.break (== '/') x parseNameVersion t1 = do (p', t3) <- breakSlash- $ S.map (\c -> if c == Word8._backslash then Word8._slash else c)- $ S8.pack t1+ $ T.map (\c -> if c == '\\' then '/' else c)+ $ T.pack t1 p <- parsePackageName p' (v', t5) <- breakSlash t3 v <- parseVersion v'- let (t6, suffix) = S.break (== Word8._period) t5+ let (t6, suffix) = T.break (== '.') t5 if t6 == p' then return (PackageIdentifier p v, suffix) else Nothing
src/Stack/Setup.hs view
@@ -211,9 +211,8 @@ -- Modify the initial environment to include the GHC path, if a local GHC -- is being used menv0 <- getMinimalEnvOverride- let env = removeHaskellEnvVars- $ augmentPathMap (maybe [] edBins mghcBin)- $ unEnvOverride menv0+ env <- removeHaskellEnvVars+ <$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0) menv <- mkEnvOverride platform env compilerVer <- getCompilerVersion menv wc@@ -232,8 +231,8 @@ mkDirs <- runReaderT extraBinDirs envConfig0 let mpath = Map.lookup "PATH" env mkDirs' = map toFilePath . mkDirs- depsPath = augmentPath (mkDirs' False) mpath- localsPath = augmentPath (mkDirs' True) mpath+ depsPath <- augmentPath (mkDirs' False) mpath+ localsPath <- augmentPath (mkDirs' True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 createDatabase menv wc deps@@ -417,7 +416,7 @@ Nothing -> return menv0 Just ed -> do config <- asks getConfig- let m = augmentPathMap (edBins ed) (unEnvOverride menv0)+ m <- augmentPathMap (edBins ed) (unEnvOverride menv0) mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) when (soptsUpgradeCabal sopts) $ do@@ -998,7 +997,7 @@ ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] case ebs of Left _ -> return Nothing- Right bs -> Just <$> parseVersion (T.encodeUtf8 (T.dropWhileEnd isSpace (T.decodeUtf8 bs)))+ Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs)) -- | Check if given processes appear to be present, throwing an exception if -- missing.@@ -1066,10 +1065,9 @@ platform <- asks getPlatform menv0 <- getMinimalEnvOverride- let oldEnv = unEnvOverride menv0- newEnv = augmentPathMap- [toFilePath $ destDir </> $(mkRelDir "usr") </> $(mkRelDir "bin")]- oldEnv+ newEnv <- augmentPathMap [toFilePath $ destDir </> $(mkRelDir "usr")+ </> $(mkRelDir "bin")]+ (unEnvOverride menv0) menv <- mkEnvOverride platform newEnv -- I couldn't find this officially documented anywhere, but you need to run
src/Stack/Setup/Installed.hs view
@@ -28,6 +28,7 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal import Path@@ -89,14 +90,14 @@ Ghc -> do bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] let (_, ghcVersion) = versionFromEnd bs- GhcVersion <$> parseVersion ghcVersion+ GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) Ghcjs -> do -- Output looks like -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) bs <- readProcessStdout Nothing menv "ghcjs" ["--version"]- let (rest, ghcVersion) = versionFromEnd bs- (_, ghcjsVersion) = versionFromEnd rest+ let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd bs+ (_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion where versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid
src/Stack/Solver.hs view
@@ -69,9 +69,9 @@ $logInfo $ "No GHC on path, selecting: " <> T.pack (versionString version) ed <- extraDirs $ Tool $ PackageIdentifier ghcName version- mkEnvOverride platform- $ augmentPathMap (edBins ed)- $ unEnvOverride menv0+ pathsEnv <- augmentPathMap (edBins ed)+ (unEnvOverride menv0)+ mkEnvOverride platform pathsEnv mcabal <- findExecutable menv "cabal" case mcabal of Nothing -> throwM SolverMissingCabalInstall
src/Stack/Types/Build.hs view
@@ -110,7 +110,7 @@ (Path Abs File) -- cabal Executable [String] -- cabal arguments (Maybe (Path Abs File)) -- logfiles location- [S.ByteString] -- log contents+ [Text] -- log contents | ExecutionFailure [SomeException] | LocalPackageDoesn'tMatchTarget PackageName@@ -256,7 +256,7 @@ logLocations ++ (if null bss then ""- else "\n\n" ++ doubleIndent (map (T.unpack . decodeUtf8With lenientDecode) bss))+ else "\n\n" ++ doubleIndent (map T.unpack bss)) where doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) dropQuotes = filter ('\"' /=)
src/Stack/Types/BuildPlan.hs view
@@ -32,8 +32,6 @@ object, withObject, withText, (.!=), (.:), (.:?), (.=)) import Data.Binary.VersionTagged-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8 import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map)@@ -44,7 +42,6 @@ import Data.String (IsString, fromString) import Data.Text (Text, pack, unpack) import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8) import Data.Text.Read (decimal) import Data.Time (Day) import qualified Data.Traversable as T@@ -248,13 +245,13 @@ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) -- | Name of an executable.-newtype ExeName = ExeName { unExeName :: ByteString }+newtype ExeName = ExeName { unExeName :: Text } deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData) instance HasStructuralInfo ExeName instance ToJSON ExeName where- toJSON = toJSON . S8.unpack . unExeName+ toJSON = toJSON . unExeName instance FromJSON ExeName where- parseJSON = withText "ExeName" $ return . ExeName . encodeUtf8+ parseJSON = withText "ExeName" $ return . ExeName -- | A simplified package description that tracks: --@@ -363,9 +360,9 @@ Nightly <$> readMay (T.unpack t1) instance ToJSON a => ToJSON (Map ExeName a) where- toJSON = toJSON . Map.mapKeysWith const (S8.unpack . unExeName)+ toJSON = toJSON . Map.mapKeysWith const unExeName instance FromJSON a => FromJSON (Map ExeName a) where- parseJSON = fmap (Map.mapKeysWith const (ExeName . encodeUtf8)) . parseJSON+ parseJSON = fmap (Map.mapKeysWith const ExeName) . parseJSON -- | A simplified version of the 'BuildPlan' + cabal file. data MiniBuildPlan = MiniBuildPlan@@ -383,11 +380,11 @@ { mpiVersion :: !Version , mpiFlags :: !(Map FlagName Bool) , mpiPackageDeps :: !(Set PackageName)- , mpiToolDeps :: !(Set ByteString)+ , mpiToolDeps :: !(Set Text) -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the -- executable name, the package name, or something else. We have to guess -- based on what's available, which is why we store this is an unwrapped- -- 'ByteString'.+ -- 'Text'. , mpiExes :: !(Set ExeName) -- ^ Executables provided by this package , mpiHasLibrary :: !Bool
src/Stack/Types/Config.hs view
@@ -102,7 +102,7 @@ ,packageDatabaseExtra ,packageDatabaseLocal ,platformOnlyRelDir- ,platformVariantRelDir+ ,platformGhcRelDir ,useShaPathOnWindows ,getWorkDir -- * Command-specific types@@ -167,6 +167,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName+import Stack.Types.TemplateName import Stack.Types.Version import System.PosixCompat.Types (UserID, GroupID) import System.Process.Read (EnvOverride)@@ -273,6 +274,9 @@ ,configAllowNewer :: !Bool -- ^ Ignore version ranges in .cabal files. Funny naming chosen to -- match cabal.+ ,configDefaultTemplate :: !(Maybe TemplateName)+ -- ^ The default template to use when none is specified.+ -- (If Nothing, the default default is used.) } -- | Which packages to ghc-options on the command line apply to?@@ -793,6 +797,9 @@ -- ^ See 'configApplyGhcOptions' ,configMonoidAllowNewer :: !(Maybe Bool) -- ^ See 'configMonoidAllowNewer'+ ,configMonoidDefaultTemplate :: !(Maybe TemplateName)+ -- ^ The default template to use when none is specified.+ -- (If Nothing, the default default is used.) } deriving Show @@ -831,6 +838,7 @@ , configMonoidRebuildGhcOptions = Nothing , configMonoidApplyGhcOptions = Nothing , configMonoidAllowNewer = Nothing+ , configMonoidDefaultTemplate = Nothing } mappend l r = ConfigMonoid { configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r@@ -867,6 +875,7 @@ , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r+ , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r } instance FromJSON (ConfigMonoid, [JSONWarning]) where@@ -930,6 +939,7 @@ configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName+ configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName return ConfigMonoid {..} where@@ -1055,6 +1065,9 @@ configMonoidAllowNewerName :: Text configMonoidAllowNewerName = "allow-newer" +configMonoidDefaultTemplateName :: Text+configMonoidDefaultTemplateName = "default-template"+ data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text@@ -1187,7 +1200,7 @@ snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do config <- asks getConfig- platform <- platformVariantRelDir+ platform <- platformGhcRelDir return $ configStackRoot config </> $(mkRelDir "snapshots") </> platform -- | Installation root for dependencies@@ -1212,16 +1225,16 @@ => m (Path Rel Dir) platformSnapAndCompilerRel = do bc <- asks getBuildConfig- platform <- platformVariantRelDir+ platform <- platformGhcRelDir name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir useShaPathOnWindows (platform </> name </> ghc) -- | Relative directory for the platform identifier-platformVariantRelDir+platformGhcRelDir :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) => m (Path Rel Dir)-platformVariantRelDir = do+platformGhcRelDir = do platform <- asks getPlatform platformVariant <- asks getPlatformVariant ghcVariant <- asks getGHCVariant@@ -1278,7 +1291,7 @@ -> m (Path Abs File) configMiniBuildPlanCache name = do root <- asks getStackRoot- platform <- platformVariantRelDir+ platform <- platformGhcRelDir file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" -- Yes, cached plans differ based on platform return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)
src/Stack/Types/FlagName.hs view
@@ -24,20 +24,17 @@ import Control.Applicative import Control.Monad.Catch import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Text import Data.Attoparsec.Combinators import Data.Binary.VersionTagged-import qualified Data.ByteString as S-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Char (isLetter)+import Data.Char (isLetter, isDigit, toLower) import Data.Data import Data.Hashable import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text)-import qualified Data.Text.Encoding as T-import qualified Data.Word8 as Word8+import qualified Data.Text as T+import Data.Text.Binary () import qualified Distribution.PackageDescription as Cabal import GHC.Generics import Language.Haskell.TH@@ -45,7 +42,7 @@ -- | A parse fail. data FlagNameParseFail- = FlagNameParseFail ByteString+ = FlagNameParseFail Text deriving (Typeable) instance Exception FlagNameParseFail instance Show FlagNameParseFail where@@ -53,22 +50,22 @@ -- | A flag name. newtype FlagName =- FlagName ByteString+ FlagName Text deriving (Typeable,Data,Generic,Hashable,Binary,NFData) instance HasStructuralInfo FlagName instance Eq FlagName where x == y = compare x y == EQ instance Ord FlagName where compare (FlagName x) (FlagName y) =- compare (S.map Word8.toLower x) (S.map Word8.toLower y)+ compare (T.map toLower x) (T.map toLower y) instance Lift FlagName where lift (FlagName n) = appE (conE 'FlagName)- (stringE (S8.unpack n))+ (stringE (T.unpack n)) instance Show FlagName where- show (FlagName n) = S8.unpack n+ show (FlagName n) = T.unpack n instance FromJSON FlagName where parseJSON j =@@ -78,10 +75,10 @@ fail ("Couldn't parse flag name: " ++ s) Just ver -> return ver --- | Attoparsec parser for a flag name from bytestring.+-- | Attoparsec parser for a flag name flagNameParser :: Parser FlagName flagNameParser =- fmap (FlagName . S8.pack)+ fmap (FlagName . T.pack) (appending (many1 (satisfy isLetter)) (concating (many (alternating (pured (satisfy isAlphaNum))@@ -97,36 +94,36 @@ Nothing -> error ("Invalid flag name: " ++ show s) Just pn -> [|pn|] --- | Convenient way to parse a flag name from a bytestring.-parseFlagName :: MonadThrow m => ByteString -> m FlagName+-- | Convenient way to parse a flag name from a 'Text'.+parseFlagName :: MonadThrow m => Text -> m FlagName parseFlagName x = go x where go = either (const (throwM (FlagNameParseFail x))) return . parseOnly (flagNameParser <* endOfInput) --- | Migration function.+-- | Convenience function for parsing from a 'String' parseFlagNameFromString :: MonadThrow m => String -> m FlagName parseFlagNameFromString =- parseFlagName . S8.pack+ parseFlagName . T.pack -- | Produce a string representation of a flag name. flagNameString :: FlagName -> String-flagNameString (FlagName n) = S8.unpack n+flagNameString (FlagName n) = T.unpack n -- | Produce a string representation of a flag name. flagNameText :: FlagName -> Text-flagNameText (FlagName n) = T.decodeUtf8 n+flagNameText (FlagName n) = n -- | Convert from a Cabal flag name. fromCabalFlagName :: Cabal.FlagName -> FlagName fromCabalFlagName (Cabal.FlagName name) =- let !x = S8.pack name+ let !x = T.pack name in FlagName x -- | Convert to a Cabal flag name. toCabalFlagName :: FlagName -> Cabal.FlagName toCabalFlagName (FlagName name) =- let !x = S8.unpack name+ let !x = T.unpack name in Cabal.FlagName x instance ToJSON a => ToJSON (Map FlagName a) where
src/Stack/Types/GhcPkgId.hs view
@@ -13,27 +13,26 @@ import Control.Applicative import Control.Monad.Catch import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8 as A8+import Data.Attoparsec.Text import Data.Binary (getWord8, putWord8) import Data.Binary.VersionTagged-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S8 import Data.Data import Data.Hashable-import Data.Text.Encoding (encodeUtf8)+import Data.Text (Text)+import qualified Data.Text as T import GHC.Generics import Prelude -- Fix AMP warning -- | A parse fail. data GhcPkgIdParseFail- = GhcPkgIdParseFail ByteString+ = GhcPkgIdParseFail Text deriving Typeable instance Show GhcPkgIdParseFail where show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs instance Exception GhcPkgIdParseFail -- | A ghc-pkg package identifier.-newtype GhcPkgId = GhcPkgId ByteString+newtype GhcPkgId = GhcPkgId Text deriving (Eq,Ord,Data,Typeable,Generic) instance Hashable GhcPkgId@@ -59,7 +58,7 @@ instance FromJSON GhcPkgId where parseJSON = withText "GhcPkgId" $ \t ->- case parseGhcPkgId $ encodeUtf8 t of+ case parseGhcPkgId t of Left e -> fail $ show (e, t) Right x -> return x @@ -67,8 +66,8 @@ toJSON g = toJSON (ghcPkgIdString g) --- | Convenient way to parse a package name from a bytestring.-parseGhcPkgId :: MonadThrow m => ByteString -> m GhcPkgId+-- | Convenient way to parse a package name from a 'Text'.+parseGhcPkgId :: MonadThrow m => Text -> m GhcPkgId parseGhcPkgId x = go x where go = either (const (throwM (GhcPkgIdParseFail x))) return .@@ -77,16 +76,8 @@ -- | A parser for a package-version-hash pair. ghcPkgIdParser :: Parser GhcPkgId ghcPkgIdParser =- fmap GhcPkgId (A8.takeWhile isValid)- where- isValid c =- ('A' <= c && c <= 'Z') ||- ('a' <= c && c <= 'z') ||- ('0' <= c && c <= '9') ||- c == '.' ||- c == '-' ||- c == '_'+ GhcPkgId . T.pack <$> many1 (choice [digit, letter, satisfy (`elem` "_.-")]) -- | Get a string representation of GHC package id. ghcPkgIdString :: GhcPkgId -> String-ghcPkgIdString (GhcPkgId x) = S8.unpack x+ghcPkgIdString (GhcPkgId x) = T.unpack x
src/Stack/Types/Nix.hs view
@@ -8,15 +8,18 @@ import Control.Applicative import Data.Aeson.Extended-import Data.Monoid import Data.Text (Text)+import Data.Monoid +import Prelude+ -- | Nix configuration. data NixOpts = NixOpts {nixEnable :: !Bool+ ,nixPureShell :: !Bool ,nixPackages :: ![Text] -- ^ The system packages to be installed in the environment before it runs- ,nixInitFile :: !(Maybe String)+ ,nixInitFile :: !(Maybe FilePath) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) ,nixShellOptions :: ![Text] -- ^ Options to be given to the nix-shell command line@@ -30,46 +33,60 @@ -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? ,nixMonoidEnable :: !(Maybe Bool) -- ^ Is using nix-shell enabled?- ,nixMonoidPackages :: ![Text]+ ,nixMonoidPureShell :: !(Maybe Bool)+ -- ^ Should the nix-shell be pure+ ,nixMonoidPackages :: !(Maybe [Text]) -- ^ System packages to use (given to nix-shell)- ,nixMonoidInitFile :: !(Maybe String)+ ,nixMonoidInitFile :: !(Maybe FilePath) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)- ,nixMonoidShellOptions :: ![Text]+ ,nixMonoidShellOptions :: !(Maybe [Text]) -- ^ Options to be given to the nix-shell command line+ ,nixMonoidPath :: !(Maybe [Text])+ -- ^ Override parts of NIX_PATH (notably 'nixpkgs') }- deriving (Show)+ deriving (Eq, Show) -- | Decode uninterpreted nix options from JSON/YAML. instance FromJSON (NixOptsMonoid, [JSONWarning]) where- parseJSON = withObjectWarnings "DockerOptsMonoid"+ parseJSON = withObjectWarnings "NixOptsMonoid" (\o -> do nixMonoidDefaultEnable <- pure True- nixMonoidEnable <- o ..:? nixEnableArgName- nixMonoidPackages <- o ..:? nixPackagesArgName ..!= []- nixMonoidInitFile <- o ..:? nixInitFileArgName- nixMonoidShellOptions <- o ..:? nixShellOptsArgName ..!= []+ nixMonoidEnable <- o ..:? nixEnableArgName+ nixMonoidPureShell <- o ..:? nixPureShellArgName+ nixMonoidPackages <- o ..:? nixPackagesArgName+ nixMonoidInitFile <- o ..:? nixInitFileArgName+ nixMonoidShellOptions <- o ..:? nixShellOptsArgName+ nixMonoidPath <- o ..:? nixPathArgName return NixOptsMonoid{..}) --- | Left-biased combine nix options+-- | Left-biased combine Nix options instance Monoid NixOptsMonoid where mempty = NixOptsMonoid {nixMonoidDefaultEnable = False- ,nixMonoidEnable = Nothing- ,nixMonoidPackages = []- ,nixMonoidInitFile = Nothing- ,nixMonoidShellOptions = []+ ,nixMonoidEnable = Nothing+ ,nixMonoidPureShell = Nothing+ ,nixMonoidPackages = Nothing+ ,nixMonoidInitFile = Nothing+ ,nixMonoidShellOptions = Nothing+ ,nixMonoidPath = Nothing } mappend l r = NixOptsMonoid {nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r- ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r- ,nixMonoidPackages = nixMonoidPackages l <> nixMonoidPackages r- ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r- ,nixMonoidShellOptions = nixMonoidShellOptions l <> nixMonoidShellOptions r+ ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r+ ,nixMonoidPureShell = nixMonoidPureShell l <|> nixMonoidPureShell r+ ,nixMonoidPackages = nixMonoidPackages l <|> nixMonoidPackages r+ ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r+ ,nixMonoidShellOptions = nixMonoidShellOptions l <|> nixMonoidShellOptions r+ ,nixMonoidPath = nixMonoidPath l <|> nixMonoidPath r } -- | Nix enable argument name. nixEnableArgName :: Text nixEnableArgName = "enable" +-- | Nix run in pure shell argument name.+nixPureShellArgName :: Text+nixPureShellArgName = "pure"+ -- | Nix packages (build inputs) argument name. nixPackagesArgName :: Text nixPackagesArgName = "packages"@@ -81,3 +98,7 @@ -- | Extra options for the nix-shell command argument name. nixShellOptsArgName :: Text nixShellOptsArgName = "nix-shell-options"++-- | NIX_PATH override argument name+nixPathArgName :: Text+nixPathArgName = "path"
src/Stack/Types/Package.hs view
@@ -117,6 +117,7 @@ data BuildInfoOpts = BuildInfoOpts { bioOpts :: [String] , bioOneWordOpts :: [String]+ , bioPackageFlags :: [String] -- ^ These options can safely have 'nubOrd' applied to them, as -- there are no multi-word options (see -- https://github.com/commercialhaskell/stack/issues/1255)
src/Stack/Types/PackageIdentifier.hs view
@@ -21,15 +21,12 @@ import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Text import Data.Binary.VersionTagged (Binary, HasStructuralInfo)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8 import Data.Data import Data.Hashable import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8) import GHC.Generics import Prelude hiding (FilePath) import Stack.Types.PackageName@@ -37,7 +34,7 @@ -- | A parse fail. data PackageIdentifierParseFail- = PackageIdentifierParseFail ByteString+ = PackageIdentifierParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs@@ -66,7 +63,7 @@ toJSON = toJSON . packageIdentifierString instance FromJSON PackageIdentifier where parseJSON = withText "PackageIdentifier" $ \t ->- case parsePackageIdentifier $ encodeUtf8 t of+ case parsePackageIdentifier t of Left e -> fail $ show (e, t) Right x -> return x @@ -82,21 +79,21 @@ packageIdentifierParser :: Parser PackageIdentifier packageIdentifierParser = do name <- packageNameParser- char8 '-'+ char '-' version <- versionParser return (PackageIdentifier name version) --- | Convenient way to parse a package identifier from a bytestring.-parsePackageIdentifier :: MonadThrow m => ByteString -> m PackageIdentifier+-- | Convenient way to parse a package identifier from a 'Text'.+parsePackageIdentifier :: MonadThrow m => Text -> m PackageIdentifier parsePackageIdentifier x = go x where go = either (const (throwM (PackageIdentifierParseFail x))) return . parseOnly (packageIdentifierParser <* endOfInput) --- | Migration function.+-- | Convenience function for parsing from a 'String'. parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier parsePackageIdentifierFromString =- parsePackageIdentifier . S8.pack+ parsePackageIdentifier . T.pack -- | Get a string representation of the package identifier; name-ver. packageIdentifierString :: PackageIdentifier -> String
src/Stack/Types/PackageName.hs view
@@ -14,7 +14,6 @@ ,packageNameParser ,parsePackageName ,parsePackageNameFromString- ,packageNameByteString ,packageNameString ,packageNameText ,fromCabalPackageName@@ -29,19 +28,17 @@ import Control.Monad import Control.Monad.Catch import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Text import Data.Attoparsec.Combinators import Data.Binary.VersionTagged (Binary, HasStructuralInfo)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Char (isLetter) import Data.Data import Data.Hashable import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text)-import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import Data.Text.Binary () import qualified Distribution.Package as Cabal import GHC.Generics import Language.Haskell.TH@@ -51,7 +48,7 @@ -- | A parse fail. data PackageNameParseFail- = PackageNameParseFail ByteString+ = PackageNameParseFail Text | CabalFileNameParseFail FilePath | CabalFileNameInvalidPackageName FilePath deriving (Typeable)@@ -63,16 +60,16 @@ -- | A package name. newtype PackageName =- PackageName ByteString+ PackageName Text deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData) instance Lift PackageName where lift (PackageName n) = appE (conE 'PackageName)- (stringE (S8.unpack n))+ (stringE (T.unpack n)) instance Show PackageName where- show (PackageName n) = S8.unpack n+ show (PackageName n) = T.unpack n instance HasStructuralInfo PackageName @@ -86,16 +83,15 @@ fail ("Couldn't parse package name: " ++ s) Just ver -> return ver --- | Attoparsec parser for a package name from bytestring.+-- | Attoparsec parser for a package name packageNameParser :: Parser PackageName packageNameParser =- fmap (PackageName . S8.pack . intercalate "-")+ fmap (PackageName . T.pack . intercalate "-") (sepBy1 word (char '-')) where word = concat <$> sequence [many digit, pured letter, many (alternating letter digit)]- letter = satisfy isLetter -- | Make a package name. mkPackageName :: String -> Q Exp@@ -104,40 +100,36 @@ Nothing -> error ("Invalid package name: " ++ show s) Just pn -> [|pn|] --- | Convenient way to parse a package name from a bytestring.-parsePackageName :: MonadThrow m => ByteString -> m PackageName+-- | Parse a package name from a 'Text'.+parsePackageName :: MonadThrow m => Text -> m PackageName parsePackageName x = go x where go = either (const (throwM (PackageNameParseFail x))) return . parseOnly (packageNameParser <* endOfInput) --- | Migration function.+-- | Parse a package name from a 'String'. parsePackageNameFromString :: MonadThrow m => String -> m PackageName parsePackageNameFromString =- parsePackageName . S8.pack---- | Produce a bytestring representation of a package name.-packageNameByteString :: PackageName -> ByteString-packageNameByteString (PackageName n) = n+ parsePackageName . T.pack -- | Produce a string representation of a package name. packageNameString :: PackageName -> String-packageNameString (PackageName n) = S8.unpack n+packageNameString (PackageName n) = T.unpack n -- | Produce a string representation of a package name. packageNameText :: PackageName -> Text-packageNameText (PackageName n) = T.decodeUtf8 n+packageNameText (PackageName n) = n -- | Convert from a Cabal package name. fromCabalPackageName :: Cabal.PackageName -> PackageName fromCabalPackageName (Cabal.PackageName name) =- let !x = S8.pack name+ let !x = T.pack name in PackageName x -- | Convert to a Cabal package name. toCabalPackageName :: PackageName -> Cabal.PackageName toCabalPackageName (PackageName name) =- let !x = S8.unpack name+ let !x = T.unpack name in Cabal.PackageName x -- | Parse a package name from a file path.
src/Stack/Types/Sig.hs view
@@ -26,7 +26,6 @@ import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) import Stack.Types.PackageName @@ -68,7 +67,7 @@ instance FromJSON (Aeson PackageName) where parseJSON j = do s <- parseJSON j- case (parsePackageName . T.encodeUtf8) s of+ case parsePackageName s of Just name -> return (Aeson name) Nothing -> fail ("Invalid package name: " <> T.unpack s)
src/Stack/Types/TemplateName.hs view
@@ -7,18 +7,37 @@ module Stack.Types.TemplateName where +import Control.Error.Safe (justErr)+import Control.Applicative+import Data.Aeson.Extended (FromJSON, withText, parseJSON)+import Data.Foldable (asum) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH+import Network.HTTP.Client (parseUrl) import qualified Options.Applicative as O import Path import Path.Internal+import Prelude -- | A template name.-data TemplateName = TemplateName !Text !(Either (Path Abs File) (Path Rel File))+data TemplateName = TemplateName !Text !TemplatePath deriving (Ord,Eq,Show) +data TemplatePath = AbsPath (Path Abs File)+ -- ^ an absolute path on the filesystem+ | RelPath (Path Rel File)+ -- ^ a relative path on the filesystem, or relative to+ -- the template repository+ | UrlPath String+ -- ^ a full URL+ deriving (Eq, Ord, Show)++instance FromJSON TemplateName where+ parseJSON = withText "TemplateName" $+ either fail return . parseTemplateNameFromString . T.unpack+ -- | An argument which accepts a template name of the format -- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@. templateNameArgument :: O.Mod O.ArgumentFields TemplateName@@ -46,17 +65,19 @@ parseTemplateNameFromString :: String -> Either String TemplateName parseTemplateNameFromString fname = case T.stripSuffix ".hsfiles" (T.pack fname) of- Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles")- Just prefix -> parseValidFile prefix fname+ Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname+ Just prefix -> parseValidFile prefix fname fname where- parseValidFile prefix str =- case parseRelFile str of- Nothing ->- case parseAbsFile str of- Nothing -> Left expected- Just fp -> return (TemplateName prefix (Left fp))- Just fp -> return (TemplateName prefix (Right fp))- expected = "Expected a template filename like: foo or foo.hsfiles"+ parseValidFile prefix hsf orig = justErr expected+ $ asum (validParses prefix hsf orig)+ validParses prefix hsf orig =+ -- NOTE: order is important+ [ TemplateName (T.pack orig) . UrlPath <$> (parseUrl orig *> Just orig)+ , TemplateName prefix . AbsPath <$> parseAbsFile hsf+ , TemplateName prefix . RelPath <$> parseRelFile hsf+ ]+ expected = "Expected a template like: foo or foo.hsfiles or\+ \ https://example.com/foo.hsfiles" -- | Make a template name. mkTemplateName :: String -> Q Exp@@ -67,13 +88,14 @@ [|TemplateName (T.pack prefix) $(pn)|] where pn = case p of- Left (Path fp) -> [|Left (Path fp)|]- Right (Path fp) -> [|Right (Path fp)|]+ AbsPath (Path fp) -> [|AbsPath (Path fp)|]+ RelPath (Path fp) -> [|RelPath (Path fp)|]+ UrlPath fp -> [|UrlPath fp|] -- | Get a text representation of the template name. templateName :: TemplateName -> Text templateName (TemplateName prefix _) = prefix -- | Get the path of the template.-templatePath :: TemplateName -> Either (Path Abs File) (Path Rel File)+templatePath :: TemplateName -> TemplatePath templatePath (TemplateName _ fp) = fp
src/Stack/Types/Version.hs view
@@ -33,10 +33,8 @@ import Control.DeepSeq import Control.Monad.Catch import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Text import Data.Binary.VersionTagged (Binary, HasStructuralInfo)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8 import Data.Data import Data.Hashable import Data.List@@ -47,6 +45,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Binary () import Data.Vector.Binary () import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V@@ -61,7 +60,7 @@ -- | A parse fail. data VersionParseFail =- VersionParseFail ByteString+ VersionParseFail Text deriving (Typeable) instance Exception VersionParseFail instance Show VersionParseFail where@@ -106,7 +105,7 @@ k' <- either (fail . show) return $ parseVersionFromString k return (k', v) --- | Attoparsec parser for a package version from bytestring.+-- | Attoparsec parser for a package version. versionParser :: Parser Version versionParser = do ls <- ((:) <$> num <*> many num')@@ -116,8 +115,8 @@ num' = point *> num point = satisfy (== '.') --- | Convenient way to parse a package version from a bytestring.-parseVersion :: MonadThrow m => ByteString -> m Version+-- | Convenient way to parse a package version from a 'Text'.+parseVersion :: MonadThrow m => Text -> m Version parseVersion x = go x where go = either (const (throwM (VersionParseFail x))) return .@@ -126,7 +125,7 @@ -- | Migration function. parseVersionFromString :: MonadThrow m => String -> m Version parseVersionFromString =- parseVersion . S8.pack+ parseVersion . T.pack -- | Get a string representation of a package version. versionString :: Version -> String
src/System/Process/Read.hs view
@@ -38,7 +38,7 @@ import Control.Arrow ((***), first) import Control.Concurrent.Async (Concurrently (..)) import Control.Exception hiding (try, catch)-import Control.Monad (join, liftM)+import Control.Monad (join, liftM, unless) import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logError)@@ -53,7 +53,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (isJust)+import Data.Maybe (isJust, maybeToList) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T@@ -141,7 +141,7 @@ sinkProcessStdout wd menv name args CL.sinkNull -- | Run the given command in the given directory. If it exits with anything--- but success, prints an error and then calls 'exitWith' to exit the program.+-- but success, print an error and then call 'exitWith' to exit the program. readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Path Abs Dir -- ^ Directory to run in -> FilePath -- ^ Command to run@@ -152,18 +152,12 @@ readInNull wd cmd menv args errMsg = do result <- try (readProcessNull (Just wd) menv cmd args) case result of- Left (ProcessExitedUnsuccessfully _ ec) -> do- $logError $- T.pack $- concat- [ "Exit code "- , show ec- , " while running "- , show (cmd : args)- , " in "- , toFilePath wd]- forM_ errMsg $logError- liftIO (exitWith ec)+ Left ex -> do+ $logError (T.pack (show ex))+ case ex of+ ReadProcessException{} -> forM_ errMsg $logError+ _ -> return ()+ liftIO exitFailure Right () -> return () -- | Try to produce a strict 'S.ByteString' from the stdout of a@@ -342,7 +336,7 @@ else testFPs fps testFPs fps0 epath <- loop $ eoPath eo- !() <- atomicModifyIORef (eoExeCache eo) $ \m' ->+ () <- atomicModifyIORef (eoExeCache eo) $ \m' -> (Map.insert name epath m', ()) return epath return $ either throwM return epath@@ -355,17 +349,32 @@ mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) +data PathException = PathsInvalidInPath [FilePath]+ deriving Typeable++instance Exception PathException+instance Show PathException where+ show (PathsInvalidInPath paths) = unlines $+ [ "Would need to add some paths to the PATH environment variable \+ \to continue, but they would be invalid because they contain a "+ ++ show FP.searchPathSeparator ++ "."+ , "Please fix the following paths and try again:"+ ] ++ paths+ -- | Augment the PATH environment variable with the given extra paths.-augmentPath :: [FilePath] -> Maybe Text -> Text+augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text augmentPath dirs mpath =- T.intercalate (T.singleton FP.searchPathSeparator)- $ map (T.pack . FP.dropTrailingPathSeparator) dirs- ++ maybe [] return mpath+ do let illegal = filter (FP.searchPathSeparator `elem`) dirs+ unless (null illegal) (throwM $ PathsInvalidInPath illegal)+ return $ T.intercalate (T.singleton FP.searchPathSeparator)+ $ map (T.pack . FP.dropTrailingPathSeparator) dirs+ ++ maybeToList mpath -- | Apply 'augmentPath' on the PATH value in the given Map.-augmentPathMap :: [FilePath] -> Map Text Text -> Map Text Text-augmentPathMap paths origEnv =- Map.insert "PATH" path origEnv+augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text+ -> m (Map Text Text)+augmentPathMap dirs origEnv =+ do path <- augmentPath dirs mpath+ return $ Map.insert "PATH" path origEnv where mpath = Map.lookup "PATH" origEnv- path = augmentPath paths mpath
src/main/Main.hs view
@@ -18,7 +18,10 @@ import Control.Monad.Logger import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Attoparsec.Args (withInterpreterArgs, parseArgs, EscapingMode (Escaping))+import Control.Monad.Trans.Either (EitherT)+import Control.Monad.Trans.Writer (Writer)+import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))+import Data.Attoparsec.Interpreter (getInterpreterArgs) import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List@@ -43,12 +46,13 @@ import Network.HTTP.Client import Options.Applicative import Options.Applicative.Args+import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import Options.Applicative.Builder.Extra import Options.Applicative.Complicated #ifdef USE_GIT_INFO import Options.Applicative.Simple (simpleVersion) #endif-import Options.Applicative.Types (readerAsk)+import Options.Applicative.Types (readerAsk, ParserHelp(..)) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO@@ -86,10 +90,10 @@ import qualified Stack.Upload as Upload import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) import qualified System.Directory as Directory (findExecutable)-import System.Environment (getEnvironment, getProgName)+import System.Environment (getEnvironment, getProgName, getArgs, withArgs) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)-import System.FilePath (searchPathSeparator)+import System.FilePath (pathSeparator, searchPathSeparator) import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding) import System.Process.Read @@ -105,364 +109,422 @@ hSetEncoding h enc' _ -> return () --- | Commandline dispatcher.-main :: IO ()-main = withInterpreterArgs stackProgName $ \args isInterpreter -> do- -- Line buffer the output by default, particularly for non-terminal runs.- -- See https://github.com/commercialhaskell/stack/pull/360- hSetBuffering stdout LineBuffering- hSetBuffering stdin LineBuffering- hSetBuffering stderr LineBuffering- hSetTranslit stdout- hSetTranslit stderr- progName <- getProgName- isTerminal <- hIsTerminalDevice stdout- execExtraHelp args- dockerHelpOptName- (dockerOptsParser False)- ("Only showing --" ++ Docker.dockerCmdName ++ "* options.")- execExtraHelp args- nixHelpOptName- (nixOptsParser False)- ("Only showing --" ++ Nix.nixCmdName ++ "* options.")+versionString' :: String #ifdef USE_GIT_INFO- let commitCount = $gitCommitCount- versionString' = concat $ concat- [ [$(simpleVersion Meta.version)]- -- Leave out number of commits for --depth=1 clone- -- See https://github.com/commercialhaskell/stack/issues/792- , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&- commitCount /= ("UNKNOWN" :: String)]- , [" ", display buildArch]- ]+versionString' = concat $ concat+ [ [$(simpleVersion Meta.version)]+ -- Leave out number of commits for --depth=1 clone+ -- See https://github.com/commercialhaskell/stack/issues/792+ , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&+ commitCount /= ("UNKNOWN" :: String)]+ , [" ", display buildArch]+ ]+ where commitCount = $gitCommitCount #else- let versionString' = showVersion Meta.version ++ ' ' : display buildArch+versionString' = showVersion Meta.version ++ ' ' : display buildArch #endif - let globalOpts hide =- extraHelpOption hide progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*>- extraHelpOption hide progName (Nix.nixCmdName ++ "*") nixHelpOptName <*> - globalOptsParser hide- addCommand' cmd title footerStr constr =- addCommand cmd title footerStr constr (globalOpts True)- addSubCommands' cmd title footerStr =- addSubCommands cmd title footerStr (globalOpts True)- eGlobalRun <- try $- complicatedOptions- Meta.version- (Just versionString')- "stack - The Haskell Tool Stack"- ""- (globalOpts False)- -- when there's a parse failure- (Just $ \f as ->- -- fall-through to external executables in `git` style if they exist- -- (i.e. `stack something` looks for `stack-something` before- -- failing with "Invalid argument `something'")- case stripPrefix "Invalid argument" (fst (renderFailure f "")) of- Just _ -> do- mExternalExec <- Directory.findExecutable ("stack-" ++ head as)- case mExternalExec of- Just ex -> do- menv <- getEnvOverride buildPlatform- runNoLoggingT (exec menv ex (tail as))- Nothing -> handleParseResult (Failure f)- Nothing -> handleParseResult (Failure f)- )- (do addCommand' "build"- "Build the package(s) in this directory/configuration"- cmdFooter- buildCmd- (buildOptsParser Build)- addCommand' "install"- "Shortcut for 'build --copy-bins'"- cmdFooter- buildCmd- (buildOptsParser Install)- addCommand' "uninstall"- "DEPRECATED: This command performs no actions, and is present for documentation only"- cmdFooter- uninstallCmd- (many $ strArgument $ metavar "IGNORED")- addCommand' "test"- "Shortcut for 'build --test'"- cmdFooter- buildCmd- (buildOptsParser Test)- addCommand' "bench"- "Shortcut for 'build --bench'"- cmdFooter- buildCmd- (buildOptsParser Bench)- addCommand' "haddock"- "Shortcut for 'build --haddock'"- cmdFooter- buildCmd- (buildOptsParser Haddock)- addCommand' "new"- "Create a new project from a template. Run `stack templates' to see available templates."- cmdFooter- newCmd- newOptsParser- addCommand' "templates"- "List the templates available for `stack new'."- cmdFooter- templatesCmd- (pure ())- addCommand' "init"- "Initialize a stack project based on one or more cabal packages"- cmdFooter- initCmd- initOptsParser- addCommand' "solver"- "Use a dependency solver to try and determine missing extra-deps"- cmdFooter- solverCmd- solverOptsParser- addCommand' "setup"- "Get the appropriate GHC for your project"- cmdFooter- setupCmd- setupParser- addCommand' "path"- "Print out handy path information"- cmdFooter- pathCmd- (mapMaybeA- (\(desc,name,_) ->- flag Nothing- (Just name)- (long (T.unpack name) <>- help desc))- paths)- addCommand' "unpack"- "Unpack one or more packages locally"- cmdFooter- unpackCmd- (some $ strArgument $ metavar "PACKAGE")- addCommand' "update"- "Update the package index"- cmdFooter- updateCmd- (pure ())- addCommand' "upgrade"- "Upgrade to the latest stack (experimental)"- cmdFooter- upgradeCmd- ((,) <$> switch- ( long "git"- <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )- <*> strOption- ( long "git-repo"- <> help "Clone from specified git repository"- <> value "https://github.com/commercialhaskell/stack"- <> showDefault ))- addCommand' "upload"- "Upload a package to Hackage"- cmdFooter- uploadCmd- ((,,,)- <$> many (strArgument $ metavar "TARBALL/DIR")- <*> optional pvpBoundsOption- <*> ignoreCheckSwitch- <*> flag False True- (long "sign" <>- help "GPG sign & submit signature"))- addCommand' "sdist"- "Create source distribution tarballs"- cmdFooter- sdistCmd- ((,,)- <$> many (strArgument $ metavar "DIR")- <*> optional pvpBoundsOption- <*> ignoreCheckSwitch)- addCommand' "dot"- "Visualize your project's dependency graph using Graphviz dot"- cmdFooter- dotCmd- dotOptsParser- addCommand' "exec"- "Execute a command"- cmdFooter- execCmd- (execOptsParser Nothing)- addCommand' "ghc"- "Run ghc"- cmdFooter- execCmd- (execOptsParser $ Just ExecGhc)- addCommand' "ghci"- "Run ghci in the context of package(s) (experimental)"- cmdFooter- ghciCmd- ghciOptsParser- addCommand' "repl"- "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"- cmdFooter- ghciCmd- ghciOptsParser- addCommand' "runghc"- "Run runghc"- cmdFooter- execCmd- (execOptsParser $ Just ExecRunGhc)- addCommand' "runhaskell"- "Run runghc (alias for 'runghc')"- cmdFooter- execCmd- (execOptsParser $ Just ExecRunGhc)- addCommand' "eval"- "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"- cmdFooter- evalCmd- (evalOptsParser "CODE")- addCommand' "clean"- "Clean the local packages"- cmdFooter- cleanCmd- cleanOptsParser- addCommand' "list-dependencies"- "List the dependencies"- cmdFooter- listDependenciesCmd- (textOption (long "separator" <>- metavar "SEP" <>- help ("Separator between package name " <>- "and package version.") <>- value " " <>- showDefault))- addCommand' "query"- "Query general build information (experimental)"- cmdFooter- queryCmd- (many $ strArgument $ metavar "SELECTOR...")- addSubCommands'- "ide"- "IDE-specific commands"- cmdFooter- (do addCommand'- "start"- "Start the ide-backend service"- cmdFooter- ideCmd- ((,) <$> many (textArgument- (metavar "TARGET" <>- help ("If none specified, use all " <>- "packages defined in current directory")))- <*> argsOption (long "ghc-options" <>- metavar "OPTION" <>- help "Additional options passed to GHCi" <>- value []))- addCommand'- "packages"- "List all available local loadable packages"- cmdFooter- packagesCmd- (pure ())- addCommand'- "load-targets"- "List all load targets for a package target"- cmdFooter- targetsCmd- (textArgument- (metavar "TARGET")))- addSubCommands'- Docker.dockerCmdName- "Subcommands specific to Docker use"- cmdFooter- (do addCommand' Docker.dockerPullCmdName- "Pull latest version of Docker image from registry"- cmdFooter- dockerPullCmd- (pure ())- addCommand' "reset"- "Reset the Docker sandbox"- cmdFooter- dockerResetCmd- (switch (long "keep-home" <>- help "Do not delete sandbox's home directory"))- addCommand' Docker.dockerCleanupCmdName- "Clean up Docker images and containers"- cmdFooter- dockerCleanupCmd- dockerCleanupOptsParser)- addSubCommands'- ConfigCmd.cfgCmdName- "Subcommands specific to modifying stack.yaml files"- cmdFooter- (addCommand' ConfigCmd.cfgCmdSetName- "Sets a field in the project's stack.yaml to value"- cmdFooter- cfgSetCmd- configCmdSetParser)- addSubCommands'- Image.imgCmdName- "Subcommands specific to imaging (EXPERIMENTAL)"- cmdFooter- (addCommand' Image.imgDockerCmdName- "Build a Docker image for the project"- cmdFooter- imgDockerCmd- (boolFlags True- "build"- "building the project before creating the container"- idm))- addSubCommands'- "hpc"- "Subcommands specific to Haskell Program Coverage"- cmdFooter- (addCommand' "report"- "Generate HPC report a combined HPC report"- cmdFooter- hpcReportCmd- hpcReportOptsParser)- addSubCommands'- Sig.sigCmdName- "Subcommands specific to package signatures (EXPERIMENTAL)"- cmdFooter- (addSubCommands'- Sig.sigSignCmdName- "Sign a a single package or all your packages"- cmdFooter- (addCommand'- Sig.sigSignSdistCmdName- "Sign a single sdist package file"- cmdFooter- sigSignSdistCmd- Sig.sigSignSdistOpts)))- case eGlobalRun of- Left (exitCode :: ExitCode) -> do- when isInterpreter $- hPutStrLn stderr $ concat- [ "\nIf you are trying to use "- , stackProgName- , " as a script interpreter, a\n'-- "- , stackProgName- , " [options] runghc [options]' comment is required."- , "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/GUIDE.md#ghcrunghc" ]- throwIO exitCode- Right (globalMonoid,run) -> do- let global = globalOptsFromMonoid isTerminal globalMonoid- when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'- case globalReExecVersion global of- Just expectVersion- | expectVersion /= showVersion Meta.version ->- throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)- _ -> return ()- run global `catch` \e ->- -- This special handler stops "stack: " from being printed before the- -- exception- case fromException e of- Just ec -> exitWith ec- Nothing -> do- printExceptionStderr e- exitFailure+main :: IO ()+main = do+ -- Line buffer the output by default, particularly for non-terminal runs.+ -- See https://github.com/commercialhaskell/stack/pull/360+ hSetBuffering stdout LineBuffering+ hSetBuffering stdin LineBuffering+ hSetBuffering stderr LineBuffering+ hSetTranslit stdout+ hSetTranslit stderr+ args <- getArgs+ progName <- getProgName+ isTerminal <- hIsTerminalDevice stdout+ execExtraHelp args+ Docker.dockerHelpOptName+ (dockerOptsParser False)+ ("Only showing --" ++ Docker.dockerCmdName ++ "* options.")+ execExtraHelp args+ Nix.nixHelpOptName+ (nixOptsParser False)+ ("Only showing --" ++ Nix.nixCmdName ++ "* options.")++ eGlobalRun <- try $ commandLineHandler progName False+ case eGlobalRun of+ Left (exitCode :: ExitCode) -> do+ throwIO exitCode+ Right (globalMonoid,run) -> do+ let global = globalOptsFromMonoid isTerminal globalMonoid+ when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'+ case globalReExecVersion global of+ Just expectVersion+ | expectVersion /= showVersion Meta.version ->+ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)+ _ -> return ()+ run global `catch` \e ->+ -- This special handler stops "stack: " from being printed before the+ -- exception+ case fromException e of+ Just ec -> exitWith ec+ Nothing -> do+ printExceptionStderr e+ exitFailure++-- Vertically combine only the error component of the first argument with the+-- error component of the second.+vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp+vcatErrorHelp (ParserHelp e1 _ _ _ _) (ParserHelp e2 h2 u2 b2 f2) =+ ParserHelp (vcatChunks [e2, e1]) h2 u2 b2 f2++commandLineHandler+ :: String+ -> Bool+ -> IO (GlobalOptsMonoid, GlobalOpts -> IO ())+commandLineHandler progName isInterpreter = complicatedOptions+ Meta.version+ (Just versionString')+ "stack - The Haskell Tool Stack"+ ""+ (globalOpts False)+ (Just failureCallback)+ (addCommands (globalOpts True) isInterpreter) where- ignoreCheckSwitch = switch (long "ignore-check" <> help "Do not check package for common mistakes")- dockerHelpOptName = Docker.dockerCmdName ++ "-help"- nixHelpOptName = Nix.nixCmdName ++ "-help"- cmdFooter = "Run 'stack --help' for global options that apply to all subcommands."+ failureCallback f args =+ case stripPrefix "Invalid argument" (fst (renderFailure f "")) of+ Just _ -> if isInterpreter+ then parseResultHandler args f+ else secondaryCommandHandler args f+ >>= interpreterHandler args+ Nothing -> parseResultHandler args f + parseResultHandler args f =+ if isInterpreter+ then do+ let hlp = errorHelp $ stringChunk+ (unwords ["Error executing interpreter command:"+ , progName+ , unwords args])+ handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f))+ else handleParseResult (Failure f)++ globalOpts hide =+ extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>+ extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>+ globalOptsParser hide (if isInterpreter+ then Just $ LevelOther "silent"+ else Nothing)++globalFooter :: String+globalFooter = "Run 'stack --help' for global options that apply to all subcommands."++addCommands+ :: Monoid c+ => Parser c+ -> Bool+ -> EitherT (GlobalOpts -> IO ())+ (Writer (Mod CommandFields (GlobalOpts -> IO (), c)))+ ()+addCommands globalOpts isInterpreter = do+ when (not isInterpreter) (do+ addCommand' "build"+ "Build the package(s) in this directory/configuration"+ buildCmd+ (buildOptsParser Build)+ addCommand' "install"+ "Shortcut for 'build --copy-bins'"+ buildCmd+ (buildOptsParser Install)+ addCommand' "uninstall"+ "DEPRECATED: This command performs no actions, and is present for documentation only"+ uninstallCmd+ (many $ strArgument $ metavar "IGNORED")+ addCommand' "test"+ "Shortcut for 'build --test'"+ buildCmd+ (buildOptsParser Test)+ addCommand' "bench"+ "Shortcut for 'build --bench'"+ buildCmd+ (buildOptsParser Bench)+ addCommand' "haddock"+ "Shortcut for 'build --haddock'"+ buildCmd+ (buildOptsParser Haddock)+ addCommand' "new"+ "Create a new project from a template. Run `stack templates' to see available templates."+ newCmd+ newOptsParser+ addCommand' "templates"+ "List the templates available for `stack new'."+ templatesCmd+ (pure ())+ addCommand' "init"+ "Initialize a stack project based on one or more cabal packages"+ initCmd+ initOptsParser+ addCommand' "solver"+ "Use a dependency solver to try and determine missing extra-deps"+ solverCmd+ solverOptsParser+ addCommand' "setup"+ "Get the appropriate GHC for your project"+ setupCmd+ setupParser+ addCommand' "path"+ "Print out handy path information"+ pathCmd+ (mapMaybeA+ (\(desc,name,_) ->+ flag Nothing+ (Just name)+ (long (T.unpack name) <>+ help desc))+ paths)+ addCommand' "unpack"+ "Unpack one or more packages locally"+ unpackCmd+ (some $ strArgument $ metavar "PACKAGE")+ addCommand' "update"+ "Update the package index"+ updateCmd+ (pure ())+ addCommand' "upgrade"+ "Upgrade to the latest stack (experimental)"+ upgradeCmd+ ((,) <$> switch+ ( long "git"+ <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )+ <*> strOption+ ( long "git-repo"+ <> help "Clone from specified git repository"+ <> value "https://github.com/commercialhaskell/stack"+ <> showDefault ))+ addCommand' "upload"+ "Upload a package to Hackage"+ uploadCmd+ ((,,,)+ <$> many (strArgument $ metavar "TARBALL/DIR")+ <*> optional pvpBoundsOption+ <*> ignoreCheckSwitch+ <*> flag False True+ (long "sign" <>+ help "GPG sign & submit signature"))+ addCommand' "sdist"+ "Create source distribution tarballs"+ sdistCmd+ ((,,)+ <$> many (strArgument $ metavar "DIR")+ <*> optional pvpBoundsOption+ <*> ignoreCheckSwitch)+ addCommand' "dot"+ "Visualize your project's dependency graph using Graphviz dot"+ dotCmd+ dotOptsParser+ addCommand' "exec"+ "Execute a command"+ execCmd+ (execOptsParser Nothing)+ addCommand' "ghc"+ "Run ghc"+ execCmd+ (execOptsParser $ Just ExecGhc)+ addCommand' "ghci"+ "Run ghci in the context of package(s) (experimental)"+ ghciCmd+ ghciOptsParser+ addCommand' "repl"+ "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"+ ghciCmd+ ghciOptsParser+ )++ -- These two are the only commands allowed in interpreter mode as well+ addCommand' "runghc"+ "Run runghc"+ execCmd+ (execOptsParser $ Just ExecRunGhc)+ addCommand' "runhaskell"+ "Run runghc (alias for 'runghc')"+ execCmd+ (execOptsParser $ Just ExecRunGhc)++ when (not isInterpreter) (do+ addCommand' "eval"+ "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"+ evalCmd+ (evalOptsParser "CODE")+ addCommand' "clean"+ "Clean the local packages"+ cleanCmd+ cleanOptsParser+ addCommand' "list-dependencies"+ "List the dependencies"+ listDependenciesCmd+ (textOption (long "separator" <>+ metavar "SEP" <>+ help ("Separator between package name " <>+ "and package version.") <>+ value " " <>+ showDefault))+ addCommand' "query"+ "Query general build information (experimental)"+ queryCmd+ (many $ strArgument $ metavar "SELECTOR...")+ addSubCommands'+ "ide"+ "IDE-specific commands"+ (do addCommand'+ "start"+ "Start the ide-backend service"+ ideCmd+ ((,) <$> many (textArgument+ (metavar "TARGET" <>+ help ("If none specified, use all " <>+ "packages defined in current directory")))+ <*> argsOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi" <>+ value []))+ addCommand'+ "packages"+ "List all available local loadable packages"+ packagesCmd+ (pure ())+ addCommand'+ "load-targets"+ "List all load targets for a package target"+ targetsCmd+ (textArgument+ (metavar "TARGET")))+ addSubCommands'+ Docker.dockerCmdName+ "Subcommands specific to Docker use"+ (do addCommand' Docker.dockerPullCmdName+ "Pull latest version of Docker image from registry"+ dockerPullCmd+ (pure ())+ addCommand' "reset"+ "Reset the Docker sandbox"+ dockerResetCmd+ (switch (long "keep-home" <>+ help "Do not delete sandbox's home directory"))+ addCommand' Docker.dockerCleanupCmdName+ "Clean up Docker images and containers"+ dockerCleanupCmd+ dockerCleanupOptsParser)+ addSubCommands'+ ConfigCmd.cfgCmdName+ "Subcommands specific to modifying stack.yaml files"+ (addCommand' ConfigCmd.cfgCmdSetName+ "Sets a field in the project's stack.yaml to value"+ cfgSetCmd+ configCmdSetParser)+ addSubCommands'+ Image.imgCmdName+ "Subcommands specific to imaging (EXPERIMENTAL)"+ (addCommand' Image.imgDockerCmdName+ "Build a Docker image for the project"+ imgDockerCmd+ (boolFlags True+ "build"+ "building the project before creating the container"+ idm))+ addSubCommands'+ "hpc"+ "Subcommands specific to Haskell Program Coverage"+ (addCommand' "report"+ "Generate HPC report a combined HPC report"+ hpcReportCmd+ hpcReportOptsParser)+ addSubCommands'+ Sig.sigCmdName+ "Subcommands specific to package signatures (EXPERIMENTAL)"+ (addSubCommands'+ Sig.sigSignCmdName+ "Sign a a single package or all your packages"+ (addCommand'+ Sig.sigSignSdistCmdName+ "Sign a single sdist package file"+ sigSignSdistCmd+ Sig.sigSignSdistOpts))+ )+ where+ ignoreCheckSwitch =+ switch (long "ignore-check"+ <> help "Do not check package for common mistakes")++ -- addCommand hiding global options+ addCommand' cmd title constr =+ addCommand cmd title globalFooter constr globalOpts++ addSubCommands' cmd title =+ addSubCommands cmd title globalFooter globalOpts++secondaryCommandHandler+ :: [String]+ -> ParserFailure ParserHelp+ -> IO (ParserFailure ParserHelp)++-- fall-through to external executables in `git` style if they exist+-- (i.e. `stack something` looks for `stack-something` before+-- failing with "Invalid argument `something'")+secondaryCommandHandler args f =+ -- don't even try when the argument looks like a path+ if elem pathSeparator cmd+ then return f+ else do+ mExternalExec <- Directory.findExecutable cmd+ case mExternalExec of+ Just ex -> do+ menv <- getEnvOverride buildPlatform+ -- TODO show the command in verbose mode+ -- hPutStrLn stderr $ unwords $+ -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"]+ _ <- runNoLoggingT (exec menv ex (tail args))+ return f+ Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f+ where+ -- FIXME this is broken when any options are specified before the command+ -- e.g. stack --verbosity silent cmd+ cmd = stackProgName ++ "-" ++ (head args)+ noSuchCmd name = errorHelp $ stringChunk+ ("Auxiliary command not found in path `" ++ name ++ "'")++interpreterHandler+ :: Monoid t+ => [String]+ -> ParserFailure ParserHelp+ -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t))+interpreterHandler args f = do+ isFile <- doesFileExist file+ if isFile+ then runInterpreterCommand file+ else parseResultHandler (errorCombine (noSuchFile file))+ where+ file = head args++ -- if the filename contains a path separator then we know that it is not a+ -- command it is a file to be interpreted. In that case we only show the+ -- interpreter error message and exclude the command related error messages.+ errorCombine =+ if elem pathSeparator file+ then overrideErrorHelp+ else vcatErrorHelp++ overrideErrorHelp (ParserHelp e1 _ _ _ _) (ParserHelp _ h2 u2 b2 f2) =+ ParserHelp e1 h2 u2 b2 f2++ parseResultHandler fn = handleParseResult (overFailure fn (Failure f))+ noSuchFile name = errorHelp $ stringChunk+ ("File does not exist or is not a regular file `" ++ name ++ "'")++ runInterpreterCommand path = do+ progName <- getProgName+ iargs <- getInterpreterArgs path+ let parseCmdLine = commandLineHandler progName True+ let cmdArgs = iargs ++ "--" : args+ -- TODO show the command in verbose mode+ -- hPutStrLn stderr $ unwords $+ -- ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]+ (a,b) <- withArgs cmdArgs parseCmdLine+ return (a,(b,mempty))+ -- | Print out useful path information in a human-readable format (and -- support others later). pathCmd :: [Text] -> GlobalOpts -> IO ()@@ -643,7 +705,7 @@ (lcProjectRoot lc) Nothing (runStackTGlobal manager (lcConfig lc) go $- Nix.reexecWithOptionalShell $+ Nix.reexecWithOptionalShell (lcProjectRoot lc) $ runStackLoggingTGlobal manager go $ do (wantedCompiler, compilerCheck, mstack) <- case scoCompilerVersion of@@ -809,7 +871,7 @@ (lcProjectRoot lc) mbefore (runStackTGlobal manager (lcConfig lc) go $- Nix.reexecWithOptionalShell (inner'' lk0))+ Nix.reexecWithOptionalShell (lcProjectRoot lc) (inner'' lk0)) mafter (Just $ liftIO $ do lk' <- readIORef curLk@@ -951,6 +1013,7 @@ config <- asks getConfig menv <- liftIO $ configEnvOverride config plainEnvSettings Nix.reexecWithOptionalShell+ (lcProjectRoot lc) (runStackTGlobal manager (lcConfig lc) go $ exec menv cmd args)) Nothing
src/test/Stack/ArgsSpec.hs view
@@ -2,21 +2,29 @@ module Stack.ArgsSpec where +import Control.Applicative+import Control.Exception.Base (assert) import Control.Monad+import Data.Attoparsec.Interpreter (interpreterArgsParser)+import qualified Data.Attoparsec.Text as P+import Data.Text (pack) import Options.Applicative.Args+import Stack.Constants (stackProgName) import Test.Hspec -- | Test spec. spec :: Spec-spec =- forM_- tests- (\(input,output) ->- it input (parseArgsFromString input == output))+spec = do+ argsSpec+ interpreterArgsSpec +argsSpec :: Spec+argsSpec = forM_ argsInputOutput+ (\(input,output) -> it input (parseArgsFromString input == output))+ -- | Fairly comprehensive checks.-tests :: [(String, Either String [String])]-tests =+argsInputOutput :: [(String, Either String [String])]+argsInputOutput = [ ("x", Right ["x"]) , ("x y z", Right ["x", "y", "z"]) , ("aaa bbb ccc", Right ["aaa", "bbb", "ccc"])@@ -29,3 +37,97 @@ , ("\"aa\\\"a\" bbb ccc \"ddd\"", Right ["aa\"a", "bbb", "ccc", "ddd"]) , ("\"aa\\\"a\" bb\\b ccc \"ddd\"", Right ["aa\"a", "bb\\b", "ccc", "ddd"]) , ("\"\" \"\" c", Right ["","","c"])]++interpreterArgsSpec :: Spec+interpreterArgsSpec =+ describe "Script interpreter parser" $ do+ describe "Success cases" $ do+ describe "Line comments" $ do+ checkLines ""+ checkLines " --x"+ checkLines " --x --y"+ describe "Block comments" $ do+ checkBlocks ""+ checkBlocks "\n"+ checkBlocks " --x"+ checkBlocks "\n--x"+ checkBlocks " --x --y"+ checkBlocks "\n--x\n--y"+ checkBlocks "\n\t--x\n\t--y"+ describe "Failure cases" $ do+ checkFailures+ where+ parse s = P.parseOnly (interpreterArgsParser stackProgName) (pack s)++ acceptSuccess args s = case parse s of+ Right x | words x == words args -> True+ _ -> False++ acceptFailure _ s = case parse s of+ Left _ -> True+ Right _ -> False++ showInput i = "BEGIN =>" ++ i ++ "<= END"+ testAndCheck checker out inp = it (showInput inp) $ checker out inp++ checkLines args = forM_+ (interpreterGenValid lineComment args)+ (testAndCheck acceptSuccess args)++ checkBlocks args = forM_+ (interpreterGenValid blockComment args)+ (testAndCheck acceptSuccess args)++ checkFailures = forM_+ interpreterGenInvalid+ (testAndCheck acceptFailure "unused")++ -- Generate a set of acceptable inputs for given format and args+ interpreterGenValid fmt args = shebang <++> newLine <++> (fmt args)++ -- Generate a set of Invalid inputs+ interpreterGenInvalid =+ ["-stack\n"] -- random input+ -- just the shebang+ <|> shebang <++> ["\n"]+ -- invalid shebang+ <|> blockSpace <++> [head (interpreterGenValid lineComment args)]+ -- something between shebang and stack comment+ <|> shebang+ <++> newLine+ <++> blockSpace+ <++> ([head (lineComment args)] <|> [head (blockComment args)])+ -- unterminated block comment+ -- just chop the closing chars from a valid block comment+ <|> shebang+ <++> ["\n"]+ <++> let+ c = head (blockComment args)+ l = length c - 2+ in [assert (drop l c == "-}") (take l c)]+ -- nested block comment+ <|> shebang+ <++> ["\n"]+ <++> [head (blockComment "--x {- nested -} --y")]+ where args = " --x --y"+ (<++>) = liftA2 (++)++ -- Generative grammar for the interpreter comments+ shebang = ["#!/usr/bin/env stack"]+ newLine = ["\n"] <|> ["\r\n"]++ -- A comment may be the last line or followed by something else+ postComment = [""] <|> newLine++ -- A command starts with zero or more whitespace followed by "stack"+ makeComment maker space args =+ let makePrefix s = (s <|> [""]) <++> [stackProgName]+ in (maker <$> ((makePrefix space) <++> [args])) <++> postComment++ lineSpace = [" "] <|> ["\t"]+ lineComment = makeComment makeLine lineSpace+ where makeLine s = "--" ++ s++ blockSpace = lineSpace <|> newLine+ blockComment = makeComment makeBlock blockSpace+ where makeBlock s = "{-" ++ s ++ "-}"
src/test/Stack/DotSpec.hs view
@@ -5,7 +5,6 @@ module Stack.DotSpec where import Control.Monad (filterM)-import Data.ByteString.Char8 (ByteString) import Data.Foldable as F import Data.Functor.Identity import Data.List ((\\))@@ -13,6 +12,7 @@ import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set+import Data.Text (Text) import Stack.Types import Test.Hspec import Test.Hspec.QuickCheck (prop)@@ -74,7 +74,7 @@ sublistOf = filterM (\_ -> choose (False, True)) -- Unsafe internal helper to create a package name-pkgName :: ByteString -> PackageName+pkgName :: Text -> PackageName pkgName = fromMaybe failure . parsePackageName where failure = error "Internal error during package name creation in DotSpec.pkgName"
src/test/Stack/PackageDumpSpec.hs view
@@ -6,6 +6,7 @@ import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB+import Data.Conduit.Text (decodeUtf8) import Control.Monad.Trans.Resource (runResourceT) import Stack.PackageDump import Stack.Types@@ -63,6 +64,7 @@ it "ghc 7.8" $ do haskell2010:_ <- runResourceT $ CB.sourceFile "test/package-dump/ghc-7.8.txt"+ =$= decodeUtf8 $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"@@ -89,6 +91,7 @@ it "ghc 7.10" $ do haskell2010:_ <- runResourceT $ CB.sourceFile "test/package-dump/ghc-7.10.txt"+ =$= decodeUtf8 $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"@@ -125,6 +128,7 @@ it "ghc 7.8.4 (osx)" $ do hmatrix:_ <- runResourceT $ CB.sourceFile "test/package-dump/ghc-7.8.4-osx.txt"+ =$= decodeUtf8 $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe"@@ -156,6 +160,36 @@ , dpHaddock = () , dpIsExposed = True }+ it "ghc HEAD" $ do+ ghcBoot:_ <- runResourceT+ $ CB.sourceFile "test/package-dump/ghc-head.txt"+ =$= decodeUtf8+ $$ conduitDumpPackage+ =$ CL.consume+ ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0"+ pkgId <- parsePackageIdentifier "ghc-boot-0.0.0.0"+ depends <- mapM parseGhcPkgId+ [ "base-4.9.0.0"+ , "binary-0.7.5.0"+ , "bytestring-0.10.7.0"+ , "directory-1.2.5.0"+ , "filepath-1.4.1.0"+ ]+ ghcBoot `shouldBe` DumpPackage+ { dpGhcPkgId = ghcPkgId+ , dpPackageIdent = pkgId+ , dpLibDirs =+ ["/opt/ghc/head/lib/ghc-7.11.20151213/ghc-boot-0.0.0.0"]+ , dpHaddockInterfaces = ["/opt/ghc/head/share/doc/ghc/html/libraries/ghc-boot-0.0.0.0/ghc-boot.haddock"]+ , dpHaddockHtml = Just "/opt/ghc/head/share/doc/ghc/html/libraries/ghc-boot-0.0.0.0"+ , dpDepends = depends+ , dpLibraries = ["HSghc-boot-0.0.0.0"]+ , dpHasExposedModules = True+ , dpProfiling = ()+ , dpHaddock = ()+ , dpIsExposed = True+ }+ it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do menv' <- getEnvOverride buildPlatform
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.1.10.1+version: 1.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -119,19 +119,20 @@ System.Process.Run Network.HTTP.Download.Verified Data.Attoparsec.Args+ Data.Attoparsec.Interpreter Data.Maybe.Extra Path.IO Path.Extra build-depends: Cabal >=1.18.1.5 && <1.23,- aeson >=0.8.0.2 && <0.10,+ aeson >=0.8.0.2 && <0.11, ansi-terminal >=0.6.2.3 && <0.7, async >=2.0.2 && <2.1, attoparsec >=0.12.1.5 && <0.14, base >=4.7 && <5, base16-bytestring >=0.1.1.6 && <0.2, base64-bytestring >=1.0.0.1 && <1.1,- bifunctors >=4.2.1 && <5.1,+ bifunctors >=4.2.1 && <5.2, binary ==0.7.*, binary-tagged >=0.1.1 && <0.2, blaze-builder >=0.4.0.1 && <0.5,@@ -147,6 +148,7 @@ edit-distance ==0.2.*, either >=4.4.1 && <4.5, enclosed-exceptions >=1.0.1.1 && <1.1,+ errors >=2.0.1 && <2.1, exceptions >=0.8.0.2 && <0.9, extra >=1.4.2 && <1.5, fast-logger >=2.3.1 && <2.5,@@ -158,14 +160,14 @@ http-client >=0.4.17 && <0.5, http-client-tls >=0.2.2 && <0.3, http-conduit >=2.1.7 && <2.2,- http-types >=0.8.6 && <0.9,+ http-types >=0.8.6 && <0.10, lifted-base >=0.2.3.6 && <0.3, monad-control >=1.0.0.4 && <1.1, monad-logger >=0.3.13.1 && <0.4, monad-loops >=0.4.2.1 && <0.5, mtl >=2.1.3.1 && <2.3, old-locale >=1.0.0.6 && <1.1,- optparse-applicative >=0.11.0.2 && <0.12,+ optparse-applicative >=0.11.0.2 && <0.13, path >=0.5.1 && <0.6, persistent >=2.1.2 && <2.3, persistent-sqlite >=2.1.4 && <2.3,@@ -175,7 +177,7 @@ resourcet >=1.1.4.1 && <1.2, retry >=0.6 && <0.8, safe ==0.3.*,- semigroups >=0.5 && <0.18,+ semigroups >=0.5 && <0.19, split >=0.2.2 && <0.3, stm >=2.4.4 && <2.5, streaming-commons >=0.1.10.0 && <0.2,@@ -183,6 +185,7 @@ template-haskell >=2.9.0.0 && <2.11, temporary >=1.2.0.3 && <1.3, text >=1.2.0.4 && <1.3,+ text-binary >=0.2.1 && <0.3, time >=1.4.2 && <1.6, transformers >=0.3.0.0 && <0.5, transformers-base >=0.4.4 && <0.5,@@ -192,7 +195,7 @@ vector-binary-instances >=0.2.1.0 && <0.3, void ==0.7.*, yaml >=0.8.10.1 && <0.9,- zlib >=0.5.4.2 && <0.6,+ zlib >=0.5.4.2 && <0.7, deepseq ==1.4.*, file-embed >=0.0.9 && <0.1, word8 >=0.1.2 && <0.2,@@ -243,11 +246,11 @@ monad-logger >=0.3.13.1 && <0.4, mtl >=2.1.3.1 && <2.3, old-locale >=1.0.0.6 && <1.1,- optparse-applicative >=0.11.0.2 && <0.12,- path >=0.5.2 && <0.6,+ optparse-applicative >=0.11.0.2 && <0.13,+ path >=0.5.3 && <0.6, process >=1.2.3.0 && <1.3, resourcet >=1.1.4.1 && <1.2,- stack >=0.1.10.1 && <0.2,+ stack >=1.0.0 && <1.1, text >=1.2.0.4 && <1.3, either >=4.4.1 && <4.5, directory >=1.2.2.0 && <1.3,@@ -269,13 +272,14 @@ build-depends: base >=4.7 && <5, hspec >=2.1.10 && <2.3,+ attoparsec >=0.12.1.6 && <0.14, containers >=0.5.5.1 && <0.6, directory >=1.2.2.0 && <1.3, exceptions >=0.8.0.2 && <0.9, filepath >=1.4.0.0 && <1.5,- path >=0.5.2 && <0.6,+ path >=0.5.3 && <0.6, temporary >=1.2.0.3 && <1.3,- stack >=0.1.10.1 && <0.2,+ stack >=1.0.0 && <1.1, monad-logger >=0.3.15 && <0.4, http-conduit >=2.1.8 && <2.2, cryptohash >=0.11.6 && <0.12,@@ -285,7 +289,7 @@ resourcet >=1.1.6 && <1.2, Cabal >=1.22.4.0 && <1.23, text >=1.2.1.3 && <1.3,- optparse-applicative >=0.11.0.2 && <0.12,+ optparse-applicative >=0.11.0.2 && <0.13, bytestring >=0.10.6.0 && <0.11, QuickCheck >=2.8.1 && <2.9, retry >=0.6 && <0.8
stack.yaml view
@@ -1,6 +1,12 @@-resolver: lts-3.14+resolver: lts-3.16 image: container: base: "fpco/ubuntu-with-libgmp:14.04" entrypoints: - stack++nix:+ # --nix on the command-line to enable.+ enable: false+ packages:+ - zlib
test/integration/lib/StackTest.hs view
@@ -8,6 +8,7 @@ import System.IO import System.Process import System.Exit+import System.Info (os) run' :: FilePath -> [String] -> IO ExitCode run' cmd args = do@@ -114,3 +115,9 @@ where special '"' = True special ' ' = True special _ = False++-- | Extension of executables+exeExt = if isWindows then ".exe" else ""++-- | Is the OS Windows?+isWindows = os == "mingw32"