pier 0.1.0.0 → 0.2.0.0
raw patch · 18 files changed
+549/−1393 lines, 18 filesdep +pier-coredep −base64-bytestringdep −bytestringdep −cryptohash-sha256dep ~Cabaldep ~aesondep ~base
Dependencies added: pier-core
Dependencies removed: base64-bytestring, bytestring, cryptohash-sha256, http-client, http-client-tls, http-types, pier, process, temporary, unix
Dependency ranges changed: Cabal, aeson, base, containers, directory, hashable, optparse-applicative, shake, text, transformers, unordered-containers, yaml
Files
- app/Main.hs +0/−287
- pier.cabal +19/−52
- src/Main.hs +358/−0
- src/Pier/Build/CFlags.hs +2/−2
- src/Pier/Build/Components.hs +118/−45
- src/Pier/Build/Config.hs +5/−6
- src/Pier/Build/ConfiguredPackage.hs +13/−19
- src/Pier/Build/Custom.hs +0/−1
- src/Pier/Build/Executable.hs +10/−10
- src/Pier/Build/Module.hs +5/−6
- src/Pier/Build/Package.hs +19/−12
- src/Pier/Build/Stackage.hs +0/−4
- src/Pier/Core/Artifact.hs +0/−685
- src/Pier/Core/Directory.hs +0/−12
- src/Pier/Core/Download.hs +0/−90
- src/Pier/Core/Persistent.hs +0/−90
- src/Pier/Core/Run.hs +0/−70
- src/Pier/Orphans.hs +0/−2
− app/Main.hs
@@ -1,287 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Main (main) where--import Control.Exception (bracket)-import Control.Monad (join, void)-import Data.IORef-import Data.List.Split (splitOn)-import Data.Maybe (fromMaybe)-import Data.Monoid (Last(..))-import Data.Semigroup (Semigroup, (<>))-import Development.Shake hiding (command)-import Development.Shake.FilePath ((</>), takeDirectory, splitFileName)-import Distribution.Package-import Distribution.Text (display, simpleParse)-import Options.Applicative hiding (action)-import System.Directory as Directory-import System.Environment--import qualified Data.HashMap.Strict as HM--import Pier.Build.Components-import Pier.Build.Config-import Pier.Build.Stackage-import Pier.Core.Artifact hiding (runCommand)-import Pier.Core.Download-import Pier.Core.Persistent-import Pier.Core.Run--data CommandOpt- = Clean- | CleanAll- | Build [(PackageName, Target)]- | Run Sandboxed (PackageName, Target) [String]- | Which (PackageName, Target)--data Sandboxed = Sandbox | NoSandbox--parseSandboxed :: Parser Sandboxed-parseSandboxed =- flag NoSandbox Sandbox- $ long "sandbox"- <> help "Run hermetically in a temporary folder"--data CommonOptions = CommonOptions- { pierYaml :: Last FilePath- , shakeFlags :: [String]- , lastHandleTemps :: Last HandleTemps- , lastDownloadLocation :: Last DownloadLocation- }--instance Semigroup CommonOptions where- CommonOptions y f ht dl <> CommonOptions y' f' ht' dl'- = CommonOptions (y <> y') (f <> f') (ht <> ht') (dl <> dl')--handleTemps :: CommonOptions -> HandleTemps-handleTemps = fromMaybe RemoveTemps . getLast . lastHandleTemps--downloadLocation :: CommonOptions -> DownloadLocation-downloadLocation = fromMaybe DownloadToHome . getLast . lastDownloadLocation---- | Parse command-independent options.------ These are allowed both at the top level--- (for example, "-V" in "pier -V build TARGETS") and within individual--- commands ("pier build -V TARGETS"). However, we want them to only appear--- in "pier --help", not "pier build --help". Doing so is slightly--- cumbersome with optparse-applicative.-parseCommonOptions :: Hidden -> Parser CommonOptions-parseCommonOptions h = CommonOptions <$> parsePierYaml <*> parseShakeFlags h- <*> parseHandleTemps- <*> parseDownloadLocation- where- parsePierYaml :: Parser (Last FilePath)- parsePierYaml = fmap Last $ optional $ strOption- $ long "pier-yaml" <> metavar "YAML" <> hide h-- parseHandleTemps :: Parser (Last HandleTemps)- parseHandleTemps =- Last . Just <$>- flag RemoveTemps KeepTemps- (long "keep-temps"- <> help "Don't remove temporary directories")-- parseDownloadLocation :: Parser (Last DownloadLocation)- parseDownloadLocation =- Last . Just <$>- flag DownloadToHome DownloadLocal- (long "download-local"- <> help "Store downloads in the local _pier directory")--data Hidden = Hidden | Shown--hide :: Hidden -> Mod f a-hide Hidden = hidden <> internal-hide Shown = mempty--parseShakeFlags :: Hidden -> Parser [String]-parseShakeFlags h =- mconcat <$> sequenceA [verbosity, many parallelism, many shakeArg]- where- shakeArg = strOption (long "shake-arg" <> metavar "SHAKEARG" <> hide h)-- parallelism =- fmap ("--jobs=" ++) . strOption- $ long "jobs"- <> short 'j'- <> help "Number of job/threads at once [default CPUs]"- <> hide h-- verbosity =- fmap combineFlags . many . flag' 'V'- $ long "verbose"- <> short 'V'- <> help "Increase the verbosity level"- <> hide h-- combineFlags [] = []- combineFlags vs = ['-':vs]--parser :: ParserInfo (CommonOptions, CommandOpt)-parser = fmap (\(x,(y,z)) -> (x <> y, z))- $ info (helper <*> liftA2 (,) (parseCommonOptions Shown)- parseCommand)- $ progDesc "Yet another Haskell build tool"--parseCommand :: Parser (CommonOptions, CommandOpt)-parseCommand = subparser $ mconcat- [ make "clean" cleanCommand "Clean project"- , make "clean-all" cleanAllCommand "Clean project & dependencies"- , make "build" buildCommand "Build project"- , make "run" runCommand "Run executable"- , make "which" whichCommand "Build executable and print its location"- ]- where- make name act desc =- command name $ info (liftA2 (,) (parseCommonOptions Hidden)- (helper <*> act))- $ progDesc desc--cleanCommand :: Parser CommandOpt-cleanCommand = pure Clean--cleanAllCommand :: Parser CommandOpt-cleanAllCommand = pure CleanAll--buildCommand :: Parser CommandOpt-buildCommand = Build <$> many parseTarget--runCommand :: Parser CommandOpt-runCommand = Run <$> parseSandboxed <*> parseTarget- <*> many (strArgument (metavar "ARGUMENT"))--whichCommand :: Parser CommandOpt-whichCommand = Which <$> parseTarget---findPierYamlFile :: Maybe FilePath -> IO FilePath-findPierYamlFile (Just f) = return f-findPierYamlFile Nothing = getCurrentDirectory >>= loop- where- loop dir = do- let baseFile = "pier.yaml"- let candidate = dir </> baseFile- let parent = takeDirectory dir- exists <- Directory.doesFileExist candidate- if- | exists -> return candidate- | parent == dir ->- error $ "Couldn't locate " ++ baseFile- ++ " from the current directory"- | otherwise -> loop parent--runWithOptions- :: IORef (IO ()) -- ^ Sink for what to do after the build- -> HandleTemps- -> CommandOpt- -> Rules ()-runWithOptions _ _ Clean = cleaning True-runWithOptions _ _ CleanAll = do- liftIO unfreezeArtifacts- cleaning True- cleanAll-runWithOptions _ _ (Build targets) = do- cleaning False- action $ do- -- Build everything if the targets list is empty- targets' <- if null targets- then map (,TargetAll) . HM.keys . localPackages- <$> askConfig- else pure targets- -- Keep track of the number of targets.- -- TODO: count transitive deps as well.- let numTargets = length targets'- successCount <- liftIO $ newIORef (0::Int)- forP targets' $ \(p,t) -> do- buildTarget p t- k <- liftIO $ atomicModifyIORef' successCount- $ \n -> let n' = n+1 in (n', n')- putLoud $ "Built " ++ showTarget p t- ++ " (" ++ show k ++ "/" ++ show numTargets ++ ")"-runWithOptions next ht (Run sandbox (pkg, target) args) = do- cleaning False- action $ do- exe <- buildExeTarget pkg target- liftIO $ writeIORef next $- case sandbox of- Sandbox -> callArtifact ht (builtExeDataFiles exe)- (builtBinary exe) args- NoSandbox -> cmd_ (WithStderr False)- (pathIn $ builtBinary exe) args-runWithOptions _ _ (Which (pkg, target)) = do- cleaning False- action $ do- exe <- buildExeTarget pkg target- -- TODO: nicer output format.- putNormal $ pathIn (builtBinary exe)--buildExeTarget :: PackageName -> Target -> Action BuiltExecutable-buildExeTarget pkg target = do- name <- case target of- TargetExe name -> return name- TargetAll -> return $ display pkg- TargetAllExes -> return $ display pkg- TargetLib -> error "command can't be used with a \"lib\" target"- askBuiltExecutable pkg name--main :: IO ()-main = do- (commonOpts, cmdOpt) <- execParser parser- -- A store for an optional action to run after building.- -- It may be set by runWithOptions. This lets `pier run` "break" out- -- of the Rules/Action monads.- next <- newIORef $ pure ()- -- Run relative to the `pier.yaml` file.- -- Afterwards, move explicitly back into the original directory in case- -- this code is being interpreted by ghci.- -- TODO (#69): don't rely on setCurrentDirectory; just use absolute paths- -- everywhere in the code.- (root, pierYamlFile)- <- splitFileName <$> findPierYamlFile (getLast $ pierYaml commonOpts)- let ht = handleTemps commonOpts- bracket getCurrentDirectory setCurrentDirectory $ const $ do- setCurrentDirectory root- withArgs (shakeFlags commonOpts) $ runPier $ do- buildPlanRules- buildPackageRules- artifactRules ht- downloadRules $ downloadLocation commonOpts- installGhcRules- configRules pierYamlFile- runWithOptions next ht cmdOpt- join $ readIORef next---- TODO: move into Build.hs-data Target- = TargetAll- | TargetLib- | TargetAllExes- | TargetExe String- deriving Show--showTarget :: PackageName -> Target -> String-showTarget pkg t = display pkg ++ case t of- TargetAll -> ""- TargetLib -> ":lib"- TargetAllExes -> ":exe"- TargetExe e -> ":exe:" ++ e--parseTarget :: Parser (PackageName, Target)-parseTarget = argument (eitherReader readTarget) (metavar "TARGET")- where- readTarget :: String -> Either String (PackageName, Target)- readTarget s = case splitOn ":" s of- [n] -> (, TargetAll) <$> readPackageName n- [n, "lib"] -> (, TargetLib) <$> readPackageName n- [n, "exe"] -> (, TargetAllExes) <$> readPackageName n- [n, "exe", e] -> (, TargetExe e) <$> readPackageName n- _ -> Left $ "Error parsing target " ++ show s- readPackageName n = case simpleParse n of- Just p -> return p- Nothing -> Left $ "Error parsing package name " ++ show n--buildTarget :: PackageName -> Target -> Action ()-buildTarget n TargetAll = void $ askMaybeBuiltLibrary n >> askBuiltExecutables n-buildTarget n TargetLib = void $ askBuiltLibrary n-buildTarget n TargetAllExes = void $ askBuiltExecutables n-buildTarget n (TargetExe e) = void $ askBuiltExecutable n e
pier.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: pier-version: 0.1.0.0+version: 0.2.0.0 license: BSD3 license-file: LICENSE maintainer: judah.jacobson@gmail.com@@ -16,8 +16,10 @@ type: git location: https://github.com/judah/pier -library- exposed-modules:+executable pier+ main-is: Main.hs+ hs-source-dirs: src+ other-modules: Pier.Build.CFlags Pier.Build.Components Pier.Build.Config@@ -28,65 +30,30 @@ Pier.Build.Package Pier.Build.Stackage Pier.Build.TargetInfo- Pier.Core.Artifact- Pier.Core.Directory- Pier.Core.Download- Pier.Core.Persistent- Pier.Core.Run Pier.Orphans- hs-source-dirs: src- other-modules: Paths_pier default-language: Haskell2010 default-extensions: BangPatterns DeriveGeneric FlexibleContexts LambdaCase MultiWayIf NondecreasingIndentation ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances+ ghc-options: -threaded -with-rtsopts=-I0 build-depends:- Cabal >=2.0.1.1 && <2.1,- aeson >=1.2.4.0 && <1.3,- base >=4.10.1.0 && <4.11,- base64-bytestring >=1.0.0.1 && <1.1,+ Cabal >=2.2.0.0 && <2.3,+ aeson >=1.3.1.1 && <1.4,+ base >=4.11.0 && <4.12, binary >=0.8.5.1 && <0.9, binary-orphans >=0.1.8.0 && <0.2,- bytestring >=0.10.8.2 && <0.11,- containers >=0.5.10.2 && <0.6,- cryptohash-sha256 >=0.11.101.0 && <0.12,- directory >=1.3.0.2 && <1.4,- hashable >=1.2.6.1 && <1.3,- http-client >=0.5.10 && <0.6,- http-client-tls >=0.3.5.3 && <0.4,- http-types >=0.9.1 && <0.10,- process >=1.6.1.0 && <1.7,- shake >=0.16.3 && <0.17,- temporary >=1.2.1.1 && <1.3,- text >=1.2.2.2 && <1.3,- transformers >=0.5.2.0 && <0.6,- unix >=2.7.2.2 && <2.8,- unordered-containers >=0.2.8.0 && <0.3,- yaml >=0.8.28 && <0.9- - if os(osx)- ghc-options: -optP-Wno-nonportable-include-path--executable pier- main-is: Main.hs- hs-source-dirs: app- other-modules:- Paths_pier- default-language: Haskell2010- default-extensions: BangPatterns DeriveGeneric FlexibleContexts- LambdaCase MultiWayIf NondecreasingIndentation ScopedTypeVariables- StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances- ghc-options: -threaded -with-rtsopts=-I0- build-depends:- Cabal >=2.0.1.1 && <2.1,- base >=4.10.1.0 && <4.11,- directory >=1.3.0.2 && <1.4,- optparse-applicative >=0.14.1.0 && <0.15,- pier -any,- shake >=0.16.3 && <0.17,+ containers >=0.5.11.0 && <0.6,+ directory >=1.3.1 && <1.4,+ hashable >=1.2.7.0 && <1.3,+ optparse-applicative >=0.14.2.0 && <0.15,+ pier-core ==0.2.*,+ shake ==0.16.*, split >=0.2.3.3 && <0.3,- unordered-containers >=0.2.8.0 && <0.3+ text >=1.2.3.0 && <1.3,+ transformers >=0.5.5.0 && <0.6,+ unordered-containers >=0.2.9.0 && <0.3,+ yaml >=0.8.32 && <0.9 if os(osx) ghc-options: -optP-Wno-nonportable-include-path
+ src/Main.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE MultiWayIf #-}+module Main (main) where++import Control.Exception (bracket)+import Control.Monad (join, void)+import Data.IORef+import Data.List.Split (splitOn)+import Data.Maybe (fromMaybe)+import Data.Monoid (Last(..))+import Data.Semigroup (Semigroup, (<>))+import Development.Shake hiding (command)+import Development.Shake.FilePath ((</>), takeDirectory, splitFileName)+import Distribution.Package+import Distribution.Text (display, simpleParse)+import Options.Applicative hiding (action)+import System.Directory as Directory+import System.Environment++import qualified Data.HashMap.Strict as HM++import Pier.Build.Components+import Pier.Build.Config+import Pier.Build.Stackage+import Pier.Core.Artifact hiding (runCommand)+import Pier.Core.Download+import Pier.Core.Persistent+import Pier.Core.Run++data CommandOpt+ = Clean+ | CleanAll+ | Setup+ | Build [(PackageName, Target)]+ | Run Sandboxed (PackageName, Target) [String]+ | Test Sandboxed [(PackageName, Target)]+ | Which (PackageName, Target)++data Sandboxed = Sandbox | NoSandbox++parseSandboxed :: Parser Sandboxed+parseSandboxed =+ flag NoSandbox Sandbox+ $ long "sandbox"+ <> help "Run hermetically in a temporary folder"++data CommonOptions = CommonOptions+ { pierYaml :: Last FilePath+ , shakeFlags :: [String]+ , lastHandleTemps :: Last HandleTemps+ , lastDownloadLocation :: Last DownloadLocation+ , lastSharedCache :: Last UseSharedCache+ }++instance Semigroup CommonOptions where+ CommonOptions y f ht dl sc <> CommonOptions y' f' ht' dl' sc'+ = CommonOptions (y <> y') (f <> f') (ht <> ht') (dl <> dl') (sc <> sc')++handleTemps :: CommonOptions -> HandleTemps+handleTemps = fromMaybe RemoveTemps . getLast . lastHandleTemps++downloadLocation :: CommonOptions -> DownloadLocation+downloadLocation = fromMaybe DownloadToHome . getLast . lastDownloadLocation++sharedCache :: CommonOptions -> UseSharedCache+sharedCache = fromMaybe DontUseSharedCache . getLast . lastSharedCache++-- | Parse command-independent options.+--+-- These are allowed both at the top level+-- (for example, "-V" in "pier -V build TARGETS") and within individual+-- commands ("pier build -V TARGETS"). However, we want them to only appear+-- in "pier --help", not "pier build --help". Doing so is slightly+-- cumbersome with optparse-applicative.+parseCommonOptions :: Hidden -> Parser CommonOptions+parseCommonOptions h = CommonOptions <$> parsePierYaml+ <*> parseShakeFlags h+ <*> parseHandleTemps+ <*> parseDownloadLocation+ <*> parseSharedCache+ where+ parsePierYaml :: Parser (Last FilePath)+ parsePierYaml = fmap Last $ optional $ strOption+ $ long "pier-yaml" <> metavar "YAML" <> hide h++ parseHandleTemps :: Parser (Last HandleTemps)+ parseHandleTemps =+ Last <$>+ flag Nothing (Just KeepTemps)+ (long "keep-temps"+ <> help "Don't remove temporary directories")++ -- OK, this doesn't work! Nice catch.+ -- Last isn't what we want I guess.+ parseDownloadLocation :: Parser (Last DownloadLocation)+ parseDownloadLocation =+ Last <$>+ flag Nothing (Just DownloadLocal)+ (long "download-local"+ <> help "Store downloads in the local _pier directory")++ parseSharedCache :: Parser (Last UseSharedCache)+ parseSharedCache = Last <$>+ flag Nothing (Just UseSharedCache)+ ( long "shared-cache"+ <> help "Use a shared cache at ~/.pier/artifact")++data UseSharedCache = UseSharedCache | DontUseSharedCache+ deriving Show++data Hidden = Hidden | Shown++hide :: Hidden -> Mod f a+hide Hidden = hidden <> internal+hide Shown = mempty++parseShakeFlags :: Hidden -> Parser [String]+parseShakeFlags h =+ mconcat <$> sequenceA [verbosity, parallelism, keepGoing, shakeArg]+ where+ shakeArg = many $ strOption (long "shake-arg" <> metavar "SHAKEARG" <> hide h)++ verbosity, parallelism, keepGoing, shakeArg :: Parser [String]+ parallelism =+ fmap (maybe [] (\j -> ["--jobs=" ++ j]))+ $ optional $ strOption+ $ long "jobs"+ <> short 'j'+ <> help "Number of job/threads at once [default CPUs]"+ <> hide h++ keepGoing = flag [] ["--keep-going"]+ $ long "keep-going"+ <> help "Keep going when some targets can't be built."++ verbosity =+ fmap combineFlags . many . flag' 'V'+ $ long "verbose"+ <> short 'V'+ <> help "Increase the verbosity level"+ <> hide h++ combineFlags [] = []+ combineFlags vs = ['-':vs]++parser :: ParserInfo (CommonOptions, CommandOpt)+parser = fmap (\(x,(y,z)) -> (x <> y, z))+ $ info (helper <*> liftA2 (,) (parseCommonOptions Shown)+ parseCommand)+ $ progDesc "Yet another Haskell build tool"++parseCommand :: Parser (CommonOptions, CommandOpt)+parseCommand = subparser $ mconcat+ [ make "clean" cleanCommand "Clean project"+ , make "clean-all" cleanAllCommand "Clean project & dependencies"+ , make "setup" setupCommand "Only configure the compiler and build plan"+ , make "build" buildCommand "Build project"+ , make "run" runCommand "Run executable"+ , make "test" testCommand "Run test suites"+ , make "which" whichCommand "Build executable and print its location"+ ]+ where+ make name act desc =+ command name $ info (liftA2 (,) (parseCommonOptions Hidden)+ (helper <*> act))+ $ progDesc desc++cleanCommand :: Parser CommandOpt+cleanCommand = pure Clean++cleanAllCommand :: Parser CommandOpt+cleanAllCommand = pure CleanAll++setupCommand :: Parser CommandOpt+setupCommand = pure Setup++buildCommand :: Parser CommandOpt+buildCommand = Build <$> many parseTarget++runCommand :: Parser CommandOpt+runCommand = Run <$> parseSandboxed <*> parseTarget+ <*> many (strArgument (metavar "ARGUMENT"))++testCommand :: Parser CommandOpt+testCommand = Test <$> parseSandboxed <*> many parseTarget++whichCommand :: Parser CommandOpt+whichCommand = Which <$> parseTarget+++findPierYamlFile :: Maybe FilePath -> IO FilePath+findPierYamlFile (Just f) = return f+findPierYamlFile Nothing = getCurrentDirectory >>= loop+ where+ loop dir = do+ let baseFile = "pier.yaml"+ let candidate = dir </> baseFile+ let parent = takeDirectory dir+ exists <- Directory.doesFileExist candidate+ if+ | exists -> return candidate+ | parent == dir ->+ error $ "Couldn't locate " ++ baseFile+ ++ " from the current directory"+ | otherwise -> loop parent++runWithOptions+ :: IORef (IO ()) -- ^ Sink for what to do after the build+ -> HandleTemps+ -> CommandOpt+ -> Rules ()+runWithOptions _ _ Clean = cleaning True+runWithOptions _ _ CleanAll = do+ liftIO unfreezeArtifacts+ cleaning True+ cleanAll+runWithOptions _ _ Setup = do+ cleaning False+ action $ void askConfig+runWithOptions _ _ (Build targets) = do+ cleaning False+ action $ do+ targets' <- targetsOrEverything targets+ -- Keep track of the number of targets.+ -- TODO: count transitive deps as well.+ let numTargets = length targets'+ successCount <- liftIO $ newIORef (0::Int)+ forP targets' $ \(p,t) -> do+ buildTarget p t+ k <- liftIO $ atomicModifyIORef' successCount+ $ \n -> let n' = n+1 in (n', n')+ putLoud $ "Built " ++ showTarget p t+ ++ " (" ++ show k ++ "/" ++ show numTargets ++ ")"+runWithOptions next ht (Run sandbox (pkg, target) args) = do+ cleaning False+ action $ do+ exe <- buildExeTarget pkg target+ liftIO $ writeIORef next $ runBin ht sandbox exe args+runWithOptions next ht (Test sandbox targets) = do+ cleaning False+ action $ do+ targets' <- targetsOrEverything targets+ tests <- concat <$> mapM (uncurry buildTestTargets) targets'+ liftIO $ writeIORef next $ mapM_ (\t -> runBin ht sandbox t []) tests+runWithOptions _ _ (Which (pkg, target)) = do+ cleaning False+ action $ do+ exe <- buildExeTarget pkg target+ -- TODO: nicer output format.+ putNormal $ pathIn (builtBinary exe)++-- Post-process command-line input. If it's empty, build all local packages.+targetsOrEverything :: [(PackageName, Target)] -> Action [(PackageName, Target)]+targetsOrEverything [] = map (, TargetAll) . HM.keys . localPackages+ <$> askConfig+targetsOrEverything ts = return ts++runBin :: HandleTemps -> Sandboxed -> BuiltBinary -> [String] -> IO ()+runBin ht sandbox exe args =+ case sandbox of+ Sandbox -> callArtifact ht (builtBinaryDataFiles exe)+ (builtBinary exe) args+ NoSandbox -> cmd_ (WithStderr False)+ (pathIn $ builtBinary exe) args++buildExeTarget :: PackageName -> Target -> Action BuiltBinary+buildExeTarget pkg target = case target of+ TargetExe name -> askBuiltExecutable pkg name+ TargetAll -> askBuiltExecutable pkg $ display pkg+ TargetAllExes -> askBuiltExecutable pkg $ display pkg+ TargetLib -> error "command can't be used with a \"lib\" target"+ TargetAllTests -> error "command can't be used with multiple \"test\" targets"+ TargetTest name -> askBuiltTestSuite pkg name++buildTestTargets :: PackageName -> Target -> Action [BuiltBinary]+buildTestTargets pkg target = case target of+ TargetExe _ -> error "command can't be used with an \"exe\" target"+ TargetAll -> askBuiltTestSuites pkg+ TargetAllTests -> askBuiltTestSuites pkg+ TargetTest name -> (: []) <$> askBuiltTestSuite pkg name+ TargetAllExes -> error "command can't be used with \"exe\" targets"+ TargetLib -> error "command can't be used with \"lib\" targets"++main :: IO ()+main = do+ (commonOpts, cmdOpt) <- execParser parser+ -- A store for an optional action to run after building.+ -- It may be set by runWithOptions. This lets `pier run` "break" out+ -- of the Rules/Action monads.+ next <- newIORef $ pure ()+ -- Run relative to the `pier.yaml` file.+ -- Afterwards, move explicitly back into the original directory in case+ -- this code is being interpreted by ghci.+ -- TODO (#69): don't rely on setCurrentDirectory; just use absolute paths+ -- everywhere in the code.+ (root, pierYamlFile)+ <- splitFileName <$> findPierYamlFile (getLast $ pierYaml commonOpts)+ let ht = handleTemps commonOpts+ cache <- getSharedCache $ sharedCache commonOpts+ bracket getCurrentDirectory setCurrentDirectory $ const $ do+ setCurrentDirectory root+ withArgs (shakeFlags commonOpts) $ runPier $ do+ buildPlanRules+ buildPackageRules+ artifactRules cache ht+ downloadRules $ downloadLocation commonOpts+ installGhcRules+ configRules pierYamlFile+ runWithOptions next ht cmdOpt+ join $ readIORef next++getSharedCache :: UseSharedCache -> IO (Maybe SharedCache)+getSharedCache DontUseSharedCache = return Nothing+getSharedCache UseSharedCache = do+ h <- getHomeDirectory+ return $ Just $ SharedCache $ h </> ".pier" </> "artifact"++-- TODO: move into Build.hs+data Target+ = TargetAll+ | TargetLib+ | TargetAllExes+ | TargetExe String+ | TargetAllTests+ | TargetTest String+ deriving Show++showTarget :: PackageName -> Target -> String+showTarget pkg t = display pkg ++ case t of+ TargetAll -> ""+ TargetLib -> ":lib"+ TargetAllExes -> ":exe"+ TargetExe e -> ":exe:" ++ e+ TargetAllTests -> ":test-suite"+ TargetTest s -> ":test-suite:" ++ s++parseTarget :: Parser (PackageName, Target)+parseTarget = argument (eitherReader readTarget) (metavar "TARGET")+ where+ readTarget :: String -> Either String (PackageName, Target)+ readTarget s = case splitOn ":" s of+ [n] -> (, TargetAll) <$> readPackageName n+ [n, "lib"] -> (, TargetLib) <$> readPackageName n+ [n, "exe"] -> (, TargetAllExes) <$> readPackageName n+ [n, "exe", e] -> (, TargetExe e) <$> readPackageName n+ [n, "test"] -> (, TargetAllTests) <$> readPackageName n+ [n, "test", e] -> (, TargetTest e) <$> readPackageName n+ _ -> Left $ "Error parsing target " ++ show s+ readPackageName n = case simpleParse n of+ Just p -> return p+ Nothing -> Left $ "Error parsing package name " ++ show n++buildTarget :: PackageName -> Target -> Action ()+buildTarget n TargetAll = void $ askMaybeBuiltLibrary n >> askBuiltExecutables n+buildTarget n TargetLib = void $ askBuiltLibrary n+buildTarget n TargetAllExes = void $ askBuiltExecutables n+buildTarget n (TargetExe e) = void $ askBuiltExecutable n e+buildTarget n TargetAllTests = void $ askBuiltTestSuites n+buildTarget n (TargetTest s) = void $ askBuiltTestSuite n s
src/Pier/Build/CFlags.hs view
@@ -8,7 +8,6 @@ import Control.Applicative (liftA2) import Control.Monad (guard)-import Data.Semigroup import Data.Set (Set) import Development.Shake import Development.Shake.Classes@@ -31,7 +30,8 @@ , transitiveDataFiles :: Set Artifact } deriving (Show, Eq, Typeable, Generic, Hashable, Binary, NFData) -instance Semigroup TransitiveDeps+instance Semigroup TransitiveDeps where+ (<>) = mappend instance Monoid TransitiveDeps where mempty = TransitiveDeps Set.empty Set.empty Set.empty Set.empty
src/Pier/Build/Components.hs view
@@ -5,14 +5,16 @@ , askMaybeBuiltLibrary , askBuiltExecutables , askBuiltExecutable- , BuiltExecutable(..)+ , askBuiltTestSuite+ , askBuiltTestSuites+ , BuiltBinary(..) ) where import Control.Applicative (liftA2)-import Control.Monad (filterM)+import Control.Monad (filterM, (>=>)) import Data.List (find)-import Data.Semigroup+import Data.Maybe (fromMaybe) import Development.Shake import Development.Shake.Classes import Development.Shake.FilePath hiding (exe)@@ -20,7 +22,6 @@ import Distribution.PackageDescription import Distribution.System (buildOS, OS(..)) import Distribution.Text-import Distribution.Version (mkVersion) import GHC.Generics hiding (packageName) import qualified Data.Map as Map@@ -43,6 +44,8 @@ addPersistent getBuiltinLib addPersistent buildExecutables addPersistent buildExecutable+ addPersistent buildTestSuites+ addPersistent buildTestSuite newtype BuiltLibraryQ = BuiltLibraryQ PackageName deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)@@ -104,7 +107,8 @@ getBuiltinLib :: BuiltinLibraryR -> Action TransitiveDeps getBuiltinLib (BuiltinLibraryR p) = do- ghc <- configGhc <$> askConfig+ conf <- askConfig+ let ghc = configGhc conf result <- runCommandStdout $ ghcPkgProg ghc ["describe" , display p]@@ -164,6 +168,7 @@ (liftA2 (,) (output hiDir) (output dynLibFile)) $ message (display pkg ++ ": building library") <> ghcCommand ghc deps confd tinfo+ (ghcOptions conf ++ [ "-this-unit-id", display pkg , "-hidir", hiDir , "-hisuf", "dyn_hi"@@ -171,7 +176,7 @@ , "-odir", oDir , "-shared", "-dynamic" , "-o", dynLibFile- ]+ ]) return $ Just (libHSName, lib, dynLib, hiDir') (pkgDb, libFiles) <- registerPackage ghc pkg lbi (targetCFlags tinfo) maybeLib@@ -195,63 +200,127 @@ newtype BuiltExecutablesQ = BuiltExecutablesQ PackageName deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)-type instance RuleResult BuiltExecutablesQ = Map.Map String BuiltExecutable+type instance RuleResult BuiltExecutablesQ = [BuiltBinary] instance Show BuiltExecutablesQ where show (BuiltExecutablesQ p) = "Executables from " ++ display p -askBuiltExecutables :: PackageName -> Action (Map.Map String BuiltExecutable)+askBuiltExecutables :: PackageName -> Action [BuiltBinary] askBuiltExecutables = askPersistent . BuiltExecutablesQ -buildExecutables :: BuiltExecutablesQ -> Action (Map.Map String BuiltExecutable)+data BuiltTestSuiteQ = BuiltTestSuiteQ PackageName String+ deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)+type instance RuleResult BuiltTestSuiteQ = BuiltBinary++instance Show BuiltTestSuiteQ where+ show (BuiltTestSuiteQ p s) = "TestSuite " ++ s ++ " from " ++ display p++askBuiltTestSuite :: PackageName -> String -> Action BuiltBinary+askBuiltTestSuite p e = askPersistent $ BuiltTestSuiteQ p e++buildExecutables :: BuiltExecutablesQ -> Action [BuiltBinary] buildExecutables (BuiltExecutablesQ p) = getConfiguredPackage p >>= \case- Left _ -> return Map.empty+ Left _ -> return [] Right confd ->- fmap Map.fromList- . mapM (\e -> (display $ exeName e,)- <$> buildExecutableFromPkg confd e)+ mapM (buildBinaryFromPkg confd . exeSpec) . filter (buildable . buildInfo) $ executables (confdDesc confd) -- TODO: error if not buildable?-buildExecutable :: BuiltExecutableQ -> Action BuiltExecutable+buildExecutable :: BuiltExecutableQ -> Action BuiltBinary buildExecutable (BuiltExecutableQ p e) = getConfiguredPackage p >>= \case Left pid -> error $ "Built-in package " ++ display pid ++ " has no executables" Right confd | Just exe <- find ((== e) . display . exeName) (executables $ confdDesc confd)- -> buildExecutableFromPkg confd exe+ -> buildBinaryFromPkg confd (exeSpec exe) | otherwise -> error $ "Package " ++ display (packageId confd) ++ " has no executable named " ++ e -buildExecutableFromPkg+data BinarySpec = BinarySpec+ { binaryTypeName :: String+ , binaryName :: String+ , binaryPath :: FilePath+ , binaryBuildInfo :: BuildInfo+ }++exeSpec :: Executable -> BinarySpec+exeSpec e = BinarySpec+ { binaryTypeName = "executable"+ , binaryName = display $ exeName e+ , binaryPath = modulePath e+ , binaryBuildInfo = buildInfo e+ }++testSpec :: TestSuite -> Action BinarySpec+testSpec t@TestSuite { testInterface = TestSuiteExeV10 _ path }+ = return BinarySpec+ { binaryTypeName = "test-suite"+ , binaryName = display $ testName t+ , binaryPath = path+ , binaryBuildInfo = testBuildInfo t+ }+testSpec t = fail $ "Unknown test type " ++ show (testInterface t)+ ++ " for test " ++ display (testName t)++buildBinaryFromPkg :: ConfiguredPackage- -> Executable- -> Action BuiltExecutable-buildExecutableFromPkg confd exe = do- let name = display $ exeName exe+ -> BinarySpec+ -> Action BuiltBinary+buildBinaryFromPkg confd bin = do let desc = confdDesc confd deps@(BuiltDeps _ transDeps)- <- askBuiltDeps $ targetDepNamesOrAllDeps desc (buildInfo exe)- ghc <- configGhc <$> askConfig- let out = "exe" </> name- tinfo <- getTargetInfo confd (buildInfo exe) (TargetBinary $ modulePath exe)+ <- askBuiltDeps $ exeDepNames desc (binaryBuildInfo bin)+ conf <- askConfig+ let ghc = configGhc conf+ let out = "bin" </> binaryName bin+ tinfo <- getTargetInfo confd (binaryBuildInfo bin) (TargetBinary $ binaryPath bin) transDeps ghc- bin <- runCommand (output out)- $ message (display (package desc) ++ ": building executable "- ++ name)+ result <- runCommand (output out)+ $ message (display (package desc) ++ ": building "+ ++ binaryTypeName bin ++ " " ++ binaryName bin) <> ghcCommand ghc deps confd tinfo+ (ghcOptions conf ++ [ "-o", out , "-hidir", "hi" , "-odir", "o" , "-dynamic" , "-threaded"- ]- return BuiltExecutable- { builtBinary = bin- , builtExeDataFiles = foldr Set.insert (transitiveDataFiles transDeps)+ ])+ return BuiltBinary+ { builtBinary = result+ , builtBinaryDataFiles = foldr Set.insert (transitiveDataFiles transDeps) (confdDataFiles confd) } +newtype BuiltTestSuitesQ = BuiltTestSuitesQ PackageName+ deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)+type instance RuleResult BuiltTestSuitesQ = [BuiltBinary]+instance Show BuiltTestSuitesQ where+ show (BuiltTestSuitesQ p) = "Test suites from " ++ display p++askBuiltTestSuites :: PackageName -> Action [BuiltBinary]+askBuiltTestSuites = askPersistent . BuiltTestSuitesQ++buildTestSuites :: BuiltTestSuitesQ -> Action [BuiltBinary]+buildTestSuites (BuiltTestSuitesQ p) = getConfiguredPackage p >>= \case+ Left _ -> return []+ Right confd ->+ mapM (testSpec >=> buildBinaryFromPkg confd)+ . filter (buildable . testBuildInfo)+ $ testSuites (confdDesc confd)++-- TODO: error if not buildable?+buildTestSuite :: BuiltTestSuiteQ -> Action BuiltBinary+buildTestSuite (BuiltTestSuiteQ p s) = getConfiguredPackage p >>= \case+ Left pid -> error $ "Built-in package " ++ display pid+ ++ " has no test suites"+ Right confd+ | Just suite <-+ find ((== s) . display . testName) (testSuites $ confdDesc confd)+ -> testSpec suite >>= buildBinaryFromPkg confd+ | otherwise -> error $ "Package " ++ display (packageId confd)+ ++ " has no test suite named " ++ s+ ghcCommand :: InstalledGhc -> BuiltDeps@@ -263,7 +332,6 @@ = inputs (transitiveDBs transDeps) <> inputs (transitiveLibFiles transDeps) <> inputList (targetSourceInputs tinfo ++ targetOtherInputs tinfo)- <> input (confdMacros confd) -- Embed extra-source-files two ways: as regular inputs, and shadowed -- directly into the working directory. -- They're needed as regular inputs so that, if they're headers, they@@ -297,7 +365,6 @@ ++ map ("-I" ++) (targetIncludeDirs tinfo) ++ targetOptions tinfo ++ map ("-optP" ++) (cppFlags cflags)- ++ ["-optP-include", "-optP" ++ pathIn (confdMacros confd)] ++ ["-optc" ++ opt | opt <- ccFlags cflags] ++ ["-l" ++ libDep | libDep <- linkLibs cflags] ++ ["-optl" ++ f | f <- linkFlags cflags]@@ -323,6 +390,7 @@ registerPackage ghc pkg bi cflags maybeLib (BuiltDeps depPkgs transDeps) = do let pre = "files"+ let depsByName = Map.fromList [(packageName p, p) | p <- depPkgs] let (collectLibInputs, libDesc) = case maybeLib of Nothing -> (createDirectoryA pre, []) Just (libHSName, lib, dynLibA, hi) ->@@ -332,7 +400,10 @@ , "library-dirs: ${pkgroot}" </> pre , "dynamic-library-dirs: ${pkgroot}" </> pre , "import-dirs: ${pkgroot}" </> pre </> "hi"- , "exposed-modules: " ++ unwords (map display $ exposedModules lib)+ , "exposed-modules: " +++ unwords (map display (exposedModules lib)+ ++ map (renderReexport depsByName)+ (reexportedModules lib)) , "hidden-modules: " ++ unwords (map display $ otherModules bi) ] )@@ -351,7 +422,7 @@ | not (null $ macFrameworks cflags) ] ++ libDesc- let db = "db"+ let db = display pkg runCommand (liftA2 (,) (output db) (output pre)) $ collectLibInputs <> ghcPkgProg ghc ["init", db]@@ -371,6 +442,18 @@ OSX -> "dylib" _ -> "so" +renderReexport ::+ Map.Map PackageName PackageIdentifier -> ModuleReexport -> String+renderReexport deps re = display (moduleReexportName re) ++ " from "+ ++ maybe "" (\pkg -> display (originalPkg pkg) ++ ":")+ (moduleReexportOriginalPackage re)+ ++ display (moduleReexportOriginalName re)+ where+ originalPkg p =+ fromMaybe (error $ "Unknown package name " ++ display p+ ++ " for module reexport " ++ display re)+ $ Map.lookup p deps+ collectInstallIncludes :: Artifact -> BuildInfo -> Action (Maybe Artifact) collectInstallIncludes dir bi | null (installIncludes bi) = pure Nothing@@ -386,13 +469,3 @@ case existing of (d, _):_ -> return (d </> f, f) _ -> error $ "Couldn't locate install-include " ++ show f---- | In older versions of Cabal, executables could use packages that were only--- explicitly depended on in the library or in other executables. Some existing--- packages still assume this behavior.-targetDepNamesOrAllDeps :: PackageDescription -> BuildInfo -> [PackageName]-targetDepNamesOrAllDeps desc bi- | specVersion desc >= mkVersion [1,8] = targetDepNames bi- | otherwise = maybe [] (const [packageName desc]) (library desc)- ++ allDependencies desc-
src/Pier/Build/Config.hs view
@@ -6,7 +6,6 @@ , Config(..) , Resolved(..) , resolvePackage- , resolvedPackageId ) where import Control.Exception (throw)@@ -50,6 +49,7 @@ , packages :: [FilePath] , extraDeps :: [PackageIdentifier] , systemGhc :: Bool+ , yamlGhcOptions :: [String] } deriving (Show, Eq, Typeable, Generic) instance Hashable PierYaml instance Binary PierYaml@@ -61,11 +61,13 @@ pkgs <- o .:? "packages" ed <- o .:? "extra-deps" sysGhc <- o .:? "system-ghc"+ opts <- o .:? "ghc-options" return PierYaml { resolver = r , packages = fromMaybe [] pkgs , extraDeps = fromMaybe [] ed , systemGhc = fromMaybe False sysGhc+ , yamlGhcOptions = fromMaybe [] opts } data PierYamlQ = PierYamlQ@@ -84,6 +86,7 @@ , configExtraDeps :: HM.HashMap PackageName Version , localPackages :: HM.HashMap PackageName (Artifact, Version) , configGhc :: InstalledGhc+ , ghcOptions :: [String] } deriving Show -- TODO: cache?@@ -107,6 +110,7 @@ , configExtraDeps = HM.fromList [ (packageName pkg, packageVersion pkg) | pkg <- extraDeps yaml ]+ , ghcOptions = yamlGhcOptions yaml } data Resolved@@ -134,8 +138,3 @@ = Hackage (PackageIdentifier n $ planPackageVersion p) (planPackageFlags p) | otherwise = error $ "Couldn't find package " ++ show (display n)--resolvedPackageId :: Resolved -> PackageIdentifier-resolvedPackageId (Builtin p) = p-resolvedPackageId (Hackage p _) = p-resolvedPackageId (Local _ p) = p
src/Pier/Build/ConfiguredPackage.hs view
@@ -2,15 +2,15 @@ ( ConfiguredPackage(..) , getConfiguredPackage , targetDepNames- , allDependencies+ , exeDepNames ) where import Data.List (nub) import Development.Shake import Distribution.Package import Distribution.PackageDescription-import Distribution.Simple.Build.Macros (generatePackageVersionMacros) import Distribution.Text (display)+import Distribution.Version (mkVersion) import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set@@ -24,8 +24,6 @@ data ConfiguredPackage = ConfiguredPackage { confdDesc :: PackageDescription , confdSourceDir :: Artifact- , confdMacros :: Artifact- -- ^ Provides Cabal macros like VERSION_* , confdDataFiles :: Maybe Artifact , confdExtraSrcFiles :: [FilePath] -- relative to source dir }@@ -50,29 +48,25 @@ getConfigured :: Config -> Flags -> Artifact -> Action ConfiguredPackage getConfigured conf flags dir = do (desc, dir') <- configurePackage (plan conf) flags dir- macros <- genCabalMacros conf desc datas <- collectDataFiles (configGhc conf) desc dir' extras <- fmap (nub . concat) . mapM (matchArtifactGlob dir') . extraSrcFiles $ desc- return $ ConfiguredPackage desc dir' macros datas extras---- For compatibility with Cabal, we generate a single macros file for the--- entire package, rather than separately for the library, executables, etc.--- For example, `pandoc-1.19.2.1`'s `pandoc` executable references--- `VERSION_texmath` in `pandoc.hs`, despite not directly depending on the--- `texmath` package.-genCabalMacros :: Config -> PackageDescription -> Action Artifact-genCabalMacros conf =- writeArtifact "macros.h"- . generatePackageVersionMacros- . map (resolvedPackageId . resolvePackage conf)- . allDependencies+ return $ ConfiguredPackage desc dir' datas extras targetDepNames :: BuildInfo -> [PackageName] targetDepNames bi = [n | Dependency n _ <- targetBuildDepends bi] +-- | In older versions of Cabal, executables could use packages that were only+-- explicitly depended on in the library or in other executables. Some existing+-- packages still assume this behavior.+exeDepNames :: PackageDescription -> BuildInfo -> [PackageName]+exeDepNames desc bi+ | specVersion desc >= mkVersion [1,8] = targetDepNames bi+ | otherwise = maybe [] (const [packageName desc]) (library desc)+ ++ allDependencies desc+ allDependencies :: PackageDescription -> [PackageName] allDependencies desc = let allBis = [libBuildInfo l | Just l <- [library desc]]@@ -103,5 +97,5 @@ if null (dataFiles desc) then return Nothing else Just <$> do- files <- concat <$> mapM (matchArtifactGlob dir) (dataFiles desc)+ files <- concat <$> mapM (matchArtifactGlob inDir) (dataFiles desc) groupFiles inDir . map (\x -> (x,x)) $ files
src/Pier/Build/Custom.hs view
@@ -9,7 +9,6 @@ ) where import Data.Char (isDigit)-import Data.Monoid import Development.Shake import Development.Shake.FilePath import Distribution.PackageDescription
src/Pier/Build/Executable.hs view
@@ -2,11 +2,10 @@ module Pier.Build.Executable ( askBuiltExecutable , BuiltExecutableQ(..)- , BuiltExecutable(..)- , progExe+ , BuiltBinary(..)+ , progBinary ) where -import Data.Semigroup import Data.Set (Set) import Development.Shake import Development.Shake.Classes@@ -16,23 +15,24 @@ import Pier.Core.Artifact import Pier.Core.Persistent+import Pier.Orphans () -data BuiltExecutable = BuiltExecutable+data BuiltBinary = BuiltBinary { builtBinary :: Artifact- , builtExeDataFiles :: Set Artifact+ , builtBinaryDataFiles :: Set Artifact } deriving (Show, Eq, Generic, Hashable, Binary, NFData) data BuiltExecutableQ = BuiltExecutableQ PackageName String deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)-type instance RuleResult BuiltExecutableQ = BuiltExecutable+type instance RuleResult BuiltExecutableQ = BuiltBinary instance Show BuiltExecutableQ where show (BuiltExecutableQ p e) = "Executable " ++ e ++ " from " ++ display p -askBuiltExecutable :: PackageName -> String -> Action BuiltExecutable+askBuiltExecutable :: PackageName -> String -> Action BuiltBinary askBuiltExecutable p e = askPersistent $ BuiltExecutableQ p e -progExe :: BuiltExecutable -> [String] -> Command-progExe exe args = progA (builtBinary exe) args- <> inputs (builtExeDataFiles exe)+progBinary :: BuiltBinary -> [String] -> Command+progBinary exe args = progA (builtBinary exe) args+ <> inputs (builtBinaryDataFiles exe)
src/Pier/Build/Module.hs view
@@ -10,7 +10,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.List (intercalate)-import Data.Semigroup import Development.Shake import Distribution.ModuleName import Distribution.Package (PackageIdentifier(..), mkPackageName)@@ -111,8 +110,8 @@ let relOutput = toFilePath m <.> "hs" happy <- lift $ askBuiltExecutable (mkPackageName "happy") "happy" lift . runCommand (output relOutput)- $ progExe happy- ["-o", relOutput, pathIn yFile]+ $ progBinary happy+ ["-agc", "-o", relOutput, pathIn yFile] <> input yFile genHsc2hs = do@@ -137,8 +136,8 @@ -- TODO: mkPackageName doesn't exist in older ones alex <- lift $ askBuiltExecutable (mkPackageName "alex") "alex" lift . runCommand (output relOutput)- $ progExe alex- ["-o", relOutput, pathIn xFile]+ $ progBinary alex+ ["-g", "-o", relOutput, pathIn xFile] <> input xFile genC2hs = do let chsFile = srcDir /> toFilePath m <.> "chs"@@ -148,7 +147,7 @@ lift . runCommand (output relOutput) $ input chsFile <> inputs (cIncludeDirs flags)- <> progExe c2hs+ <> progBinary c2hs (["-o", relOutput, pathIn chsFile] ++ ["--include=" ++ pathIn f | f <- Set.toList (cIncludeDirs flags)] ++ ["--cppopts=" ++ f | f <- ccFlags flags ++ cppFlags flags
src/Pier/Build/Package.hs view
@@ -11,7 +11,7 @@ import Distribution.Compiler import Distribution.Package import Distribution.PackageDescription-import Distribution.PackageDescription.Parse+import Distribution.PackageDescription.Parsec import Distribution.System (buildOS, buildArch) import Distribution.Text (display) import Distribution.Types.CondTree (CondBranch(..))@@ -29,7 +29,7 @@ askDownload Download { downloadFilePrefix = "hackage" , downloadName = n <.> "tar.gz"- , downloadUrlPrefix = "https://hackage.haskell.org/package" </> n+ , downloadUrlPrefix = "https://hackage.haskell.org/package/" ++ n } getPackageSourceDir :: PackageIdentifier -> Action Artifact@@ -48,7 +48,7 @@ let desc = flattenToDefaultFlags plan flags gdesc let name = display (packageName desc) case buildType desc of- Just Configure -> do+ Configure -> do let configuredDir = name configuredPackage <- runCommand (output configuredDir) $ shadow packageSourceDir configuredDir@@ -59,11 +59,8 @@ buildInfoExists <- doesArtifactExist buildInfoFile desc' <- if buildInfoExists then do- hookedBIParse <- parseHookedBuildInfo <$> readArtifact buildInfoFile- case hookedBIParse of- ParseFailed e -> error $ "Error reading buildinfo " ++ show buildInfoFile- ++ ": " ++ show e- ParseOk _ hookedBI -> return $ updatePackageDescription hookedBI desc+ hookedBI <- readHookedBuildInfoA buildInfoFile+ return $ updatePackageDescription hookedBI desc else return desc return (desc', configuredPackage) -- Best effort: ignore custom setup scripts.@@ -72,12 +69,20 @@ parseCabalFileInDir :: Artifact -> Action GenericPackageDescription parseCabalFileInDir dir = do cabalFile <- findCabalFile dir- cabalContents <- readArtifact cabalFile+ cabalContents <- readArtifactB cabalFile -- TODO: better error message when parse fails; and maybe warnings too?- case parseGenericPackageDescription cabalContents of- ParseFailed err -> error $ show err ++ "\n" ++ cabalContents- ParseOk _ pkg -> return pkg+ case runParseResult $ parseGenericPackageDescription cabalContents of+ (_, Right pkg) -> return pkg+ e -> error $ show e ++ "\n" ++ show cabalContents +readHookedBuildInfoA :: Artifact -> Action HookedBuildInfo+readHookedBuildInfoA file = do+ hookedBIParse <- parseHookedBuildInfo <$> readArtifactB file+ case runParseResult hookedBIParse of+ (_,Right hookedBI) -> return hookedBI+ e -> error $ "Error reading buildinfo " ++ show file+ ++ ": " ++ show e+ findCabalFile :: Artifact -> Action Artifact findCabalFile dir = do cabalFiles <- matchArtifactGlob dir "*.cabal"@@ -99,6 +104,8 @@ { library = resolve plan flags <$> condLibrary gdesc , executables = map (\(n, e) -> (resolve plan flags e) { exeName = n }) $ condExecutables gdesc+ , testSuites = map (\(n, s) -> (resolve plan flags s) { testName = n })+ $ condTestSuites gdesc } resolve
src/Pier/Build/Stackage.hs view
@@ -7,7 +7,6 @@ , installGhcRules , InstalledGhc(..) , GhcDistro(..)- , ghcArtifacts , ghcProg , ghcPkgProg , hsc2hsProg@@ -140,9 +139,6 @@ packageConfD :: String packageConfD = "package.conf.d"--ghcArtifacts :: InstalledGhc -> Set.Set Artifact-ghcArtifacts g = Set.fromList [ghcLibRoot g] askInstalledGhc :: BuildPlan -> GhcDistro -> Action InstalledGhc askInstalledGhc plan distro
− src/Pier/Core/Artifact.hs
@@ -1,685 +0,0 @@-{- | A generic approach to building and caching file outputs.--This is a layer on top of Shake which enables build actions to be written in a-"forwards" style. For example:--> runPier $ action $ do-> contents <- lines <$> readArtifactA (externalFile "result.txt")-> let result = "result.tar"-> runCommand (output result)-> $ foldMap input contents-> <> prog "tar" (["-cf", result] ++ map pathIn contents)--This approach generally leads to simpler logic than backwards-defined build systems such as-make or (normal) Shake, where each step of the build logic must be written as a-new build rule.--Inputs and outputs of a command must be declared up-front, using the 'input'-and 'output' functions respectively. This enables isolated, deterministic-build steps which are each run in their own temporary directory.--Output files are stored in the location--> _pier/artifact/HASH/path/to/file--where @HASH@ is a string that uniquely determines the action generating-that file. In particular, there is no need to worry about choosing distinct names-for outputs of different commands.--Note that 'Development.Shake.Forward' has similar motivation to this module,-but instead uses @fsatrace@ to detect what files changed after the fact.-Unfortunately, that approach is not portable. Additionally, it makes it-difficult to isolate steps and make the build more reproducible (for example,-to prevent the output of one step being mutated by a later one) since every-output file could potentially be an input to every action. Finally, by-explicitly declaring outputs we can detect sooner when a command doesn't-produce the files that we expect.---}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE TypeOperators #-}-module Pier.Core.Artifact- ( -- * Rules- artifactRules- -- * Artifact- , Artifact- , externalFile- , (/>)- , replaceArtifactExtension- , readArtifact- , readArtifactB- , doesArtifactExist- , matchArtifactGlob- , unfreezeArtifacts- , callArtifact- -- * Creating artifacts- , writeArtifact- , runCommand- , runCommand_- , runCommandStdout- , Command- , message- -- ** Command outputs- , Output- , output- -- ** Command inputs- , input- , inputs- , inputList- , shadow- , groupFiles- -- * Running commands- , prog- , progA- , progTemp- , pathIn- , withCwd- , createDirectoryA- ) where--import Control.Monad (forM_, when, unless)-import Control.Monad.IO.Class-import Crypto.Hash.SHA256-import Data.ByteString.Base64-import Data.Semigroup-import Data.Set (Set)-import Development.Shake-import Development.Shake.Classes hiding (hash)-import Development.Shake.FilePath-import Distribution.Simple.Utils (matchDirFileGlob)-import GHC.Generics-import System.Directory as Directory-import System.Exit (ExitCode(..))-import System.Posix.Files (createSymbolicLink)-import System.Process.Internals (translate)--import qualified Data.Binary as Binary-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.List as List-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Encoding as T--import Pier.Core.Directory-import Pier.Core.Persistent-import Pier.Core.Run-import Pier.Orphans ()---- | A hermetic build step. Consists of a sequence of calls to 'message',--- 'prog'/'progA'/'progTemp', and/or 'shadow', which may be combined using '<>'/'mappend'.--- Also specifies the input 'Artifacts' that are used by those commands.-data Command = Command- { _commandProgs :: [Prog]- , commandInputs :: Set Artifact- }- deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)--data Call- = CallEnv String -- picked up from $PATH- | CallArtifact Artifact- | CallTemp FilePath -- Local file to this Command- -- (e.g. generated by an earlier call)- -- (This is a hack around shake which tries to resolve- -- local files in the env.)- deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)--data Prog- = ProgCall { _progCall :: Call- , _progArgs :: [String]- , progCwd :: FilePath -- relative to the root of the sandbox- }- | Message String- | Shadow Artifact FilePath- deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)--instance Monoid Command where- Command ps is `mappend` Command ps' is' = Command (ps ++ ps') (is <> is')- mempty = Command [] Set.empty--instance Semigroup Command---- | Run an external command-line program with the given arguments.-prog :: String -> [String] -> Command-prog p as = Command [ProgCall (CallEnv p) as "."] Set.empty---- | Run an artifact as an command-line program with the given arguments.-progA :: Artifact -> [String] -> Command-progA p as = Command [ProgCall (CallArtifact p) as "."] (Set.singleton p)---- | Run a command-line program with the given arguments, where the program--- was created by a previous program.-progTemp :: FilePath -> [String] -> Command-progTemp p as = Command [ProgCall (CallTemp p) as "."] Set.empty---- | Prints a status message for the user when this command runs.-message :: String -> Command-message s = Command [Message s] Set.empty---- | Runs a command within the given (relative) directory.-withCwd :: FilePath -> Command -> Command-withCwd path (Command ps as)- | isAbsolute path = error $ "withCwd: expected relative path, got " ++ show path- | otherwise = Command (map setPath ps) as- where- setPath m@Message{} = m- setPath p = p { progCwd = path }---- | Specify that an 'Artifact' should be made available to program calls within this--- 'Command'.------ Note that the order does not matter; `input f <> cmd === cmd <> input f`.-input :: Artifact -> Command-input = inputs . Set.singleton--inputList :: [Artifact] -> Command-inputList = inputs . Set.fromList---- | Specify that a set of 'Artifact's should be made available to program calls within this--- 'Command'.-inputs :: Set Artifact -> Command-inputs = Command []---- | Make a "shadow" copy of the given input artifact's by create a symlink of--- this artifact (if it is a file) or of each sub-file (transitively, if it is--- a directory).------ The result may be captured as output, for example when grouping multiple outputs--- of separate commands into a common directory structure.-shadow :: Artifact -> FilePath -> Command-shadow a f- | isAbsolute f = error $ "shadowArtifact: need relative destination, found "- ++ show f- | otherwise = Command [Shadow a f] Set.empty---- | The output of a given command.------ Multiple outputs may be combined using the 'Applicative' instance.-data Output a = Output [FilePath] (Hash -> a)--instance Functor Output where- fmap f (Output g h) = Output g (f . h)--instance Applicative Output where- pure = Output [] . const- Output f g <*> Output f' g' = Output (f ++ f') (g <*> g')---- | Register a single output of a command.------ The input must be a relative path and nontrivial (i.e., not @"."@ or @""@).-output :: FilePath -> Output Artifact-output f- | normalise f == "." = error $ "Can't output empty path " ++ show f- | isAbsolute f = error $ "Can't output absolute path " ++ show f- | otherwise = Output [f] $ flip Artifact (normalise f) . Built---- | Unique identifier of a command-newtype Hash = Hash B.ByteString- deriving (Show, Eq, Ord, Binary, NFData, Hashable, Generic)--makeHash :: Binary a => a -> Hash-makeHash = Hash . fixChars . dropPadding . encode . hashlazy . Binary.encode- where- -- Remove slashes, since the strings will appear in filepaths.- -- Also remove `+` to reduce shell errors.- fixChars = BC.map $ \case- '/' -> '-'- '+' -> '.'- c -> c- -- Padding just adds noise, since we don't have length requirements (and indeed- -- every sha256 hash is 32 bytes)- dropPadding c- | BC.last c == '=' = BC.init c- -- Shouldn't happen since each hash is the same length:- | otherwise = c--hashDir :: Hash -> FilePath-hashDir h = artifactDir </> hashString h--artifactDir :: FilePath-artifactDir = pierFile "artifact"--externalArtifactDir :: FilePath-externalArtifactDir = artifactDir </> "external"--hashString :: Hash -> String-hashString (Hash h) = BC.unpack h---- | An 'Artifact' is a file or folder that was created by a build command.-data Artifact = Artifact Source FilePath- deriving (Eq, Ord, Generic, Hashable, Binary, NFData)--instance Show Artifact where- show (Artifact External f) = "external:" ++ show f- show (Artifact (Built h) f) = hashString h ++ ":" ++ show f--data Source = Built Hash | External- deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData)---- | Create an 'Artifact' from an input file to the build (for example, a--- source file created by the user).------ If it is a relative path, changes to the file will cause rebuilds of--- Commands and Rules that dependended on it.-externalFile :: FilePath -> Artifact-externalFile f- | null f' = error "externalFile: empty input"- | artifactDir `List.isPrefixOf` f' = error $ "externalFile: forbidden prefix: " ++ show f'- | otherwise = Artifact External f'- where- f' = normalise f---- | Create a reference to a sub-file of the given 'Artifact', which must--- refer to a directory.-(/>) :: Artifact -> FilePath -> Artifact-Artifact source f /> g = Artifact source $ normalise $ f </> g--infixr 5 /> -- Same as </>--artifactRules :: HandleTemps -> Rules ()-artifactRules ht = do- liftIO createExternalLink- commandRules ht- writeArtifactRules--createExternalLink :: IO ()-createExternalLink = do- exists <- doesPathExist externalArtifactDir- unless exists $ do- createParentIfMissing externalArtifactDir- createSymbolicLink "../.." externalArtifactDir---- | The build rule type for commands.-data CommandQ = CommandQ- { commandQCmd :: Command- , _commandQOutputs :: [FilePath]- }- deriving (Eq, Generic)--instance Show CommandQ where- show CommandQ { commandQCmd = Command progs _ }- = let msgs = List.intercalate "; " [m | Message m <- progs]- in "Command" ++- if null msgs- then ""- else ": " ++ msgs--instance Hashable CommandQ-instance Binary CommandQ-instance NFData CommandQ--type instance RuleResult CommandQ = Hash---- TODO: sanity-check filepaths; for example, normalize, should be relative, no--- "..", etc.-commandHash :: CommandQ -> Action Hash-commandHash cmdQ = do- let externalFiles = [f | Artifact External f <- Set.toList $ commandInputs- $ commandQCmd cmdQ- , isRelative f- ]- need externalFiles- -- TODO: streaming hash- userFileHashes <- liftIO $ map hash <$> mapM B.readFile externalFiles- return $ makeHash ("commandHash", cmdQ, userFileHashes)---- | Run the given command, capturing the specified outputs.-runCommand :: Output t -> Command -> Action t-runCommand (Output outs mk) c- = mk <$> askPersistent (CommandQ c outs)---- Run the given command and record its stdout.-runCommandStdout :: Command -> Action String-runCommandStdout c = do- out <- runCommand (output stdoutOutput) c- liftIO $ readFile $ pathIn out---- | Run the given command without capturing its output. Can be used to check--- consistency of the outputs of previous commands.-runCommand_ :: Command -> Action ()-runCommand_ = runCommand (pure ())--commandRules :: HandleTemps -> Rules ()-commandRules ht = addPersistent $ \cmdQ@(CommandQ (Command progs inps) outs) -> do- putChatty $ showCommand cmdQ- h <- commandHash cmdQ- createArtifacts h $ \resultDir ->- -- Run the command within a separate temporary directory.- -- When it's done, we'll move the explicit set of outputs into- -- the result location.- withPierTempDirectoryAction ht (hashString h) $ \tmpDir -> do- let tmpPathOut = (tmpDir </>)-- liftIO $ collectInputs inps tmpDir- mapM_ (createParentIfMissing . tmpPathOut) outs-- -- Run the command, and write its stdout to a special file.- root <- liftIO getCurrentDirectory- stdoutStr <- B.concat <$> mapM (readProg (root </> tmpDir)) progs-- let stdoutPath = tmpPathOut stdoutOutput- createParentIfMissing stdoutPath- liftIO $ B.writeFile stdoutPath stdoutStr-- -- Check that all the output files exist, and move them- -- into the output directory.- liftIO $ forM_ outs $ \f -> do- let src = tmpPathOut f- let dest = resultDir </> f- exist <- Directory.doesPathExist src- unless exist $- error $ "runCommand: missing output "- ++ show f- ++ " in temporary directory "- ++ show tmpDir- createParentIfMissing dest- renamePath src dest- return h--putChatty :: String -> Action ()-putChatty s = do- v <- shakeVerbosity <$> getShakeOptions- when (v >= Chatty) $ putNormal s---- TODO: more hermetic?-collectInputs :: Set Artifact -> FilePath -> IO ()-collectInputs inps tmp = do- let inps' = dedupArtifacts inps- checkAllDistinctPaths inps'- liftIO $ mapM_ (linkArtifact tmp) inps'---- | Create a directory containing Artifacts.------ If the output directory already exists, don't do anything. Otherwise, run--- the given function with a temporary directory, and then move that directory--- atomically to the final output directory for those Artifacts.--- Files and (sub)directories, as well as the directory itself, will--- be made read-only.-createArtifacts :: Hash -> (FilePath -> Action ()) -> Action ()-createArtifacts h act = do- let destDir = hashDir h- -- Skip if the output directory already exists; we'll produce it atomically- -- below. This could happen if Shake's database was cleaned, or if the- -- action stops before Shake registers it as complete, due to either a- -- synchronous or asynchronous exception.- exists <- liftIO $ Directory.doesDirectoryExist destDir- unless exists $ do- tempDir <- createPierTempDirectory $ hashString h ++ "-result"- -- Run the given action.- act tempDir- liftIO $ do- -- Move the created directory to its final location,- -- with all the files and directories inside set to- -- read-only.- getRegularContents tempDir- >>= mapM_ (forFileRecursive_ freezePath . (tempDir </>))- createParentIfMissing destDir- Directory.renameDirectory tempDir destDir- -- Also set the directory itself to read-only, but wait- -- until the last step since read-only files can't be moved.- freezePath destDir---- Call a process inside the given directory and capture its stdout.--- TODO: more flexibility around the env vars--- Also: limit valid parameters for the *prog* binary (rather than taking it--- from the PATH that the `pier` executable sees).-readProg :: FilePath -> Prog -> Action B.ByteString-readProg _ (Message s) = do- putNormal s- return B.empty-readProg dir (ProgCall p as cwd) = readProgCall dir p as cwd-readProg dir (Shadow a0 f0) = do- liftIO $ linkShadow dir a0 f0- return B.empty--readProgCall :: FilePath -> Call -> [String] -> FilePath -> Action BC.ByteString-readProgCall dir p as cwd = do- -- hack around shake weirdness w.r.t. relative binary paths- let p' = case p of- CallEnv s -> s- CallArtifact f -> dir </> pathIn f- CallTemp f -> dir </> f- (ret, Stdout out, Stderr err)- <- quietly $ command- [ Cwd $ dir </> cwd- , Env defaultEnv- -- stderr will get printed if there's an error.- , EchoStderr False- ]- p' (map (spliceTempDir dir) as)- case ret of- ExitSuccess -> return out- ExitFailure ec -> do- v <- shakeVerbosity <$> getShakeOptions- fail $ if v < Loud- -- TODO: remove trailing newline- then err- else unlines- [ showProg (ProgCall p as cwd)- , "Working dir: " ++ translate (dir </> cwd)- , "Exit code: " ++ show ec- , "Stderr:"- , err- ]---- TODO: check the destination files actually exist.-linkShadow :: FilePath -> Artifact -> FilePath -> IO ()-linkShadow dir a0 f0 = do- let out = dir </> f0- createParentIfMissing out- rootDir <- Directory.getCurrentDirectory- deepLink (rootDir </> pathIn a0) out- where- deepLink a f = do- isDir <- Directory.doesDirectoryExist a- if isDir- then do- Directory.createDirectoryIfMissing False f- cs <- getRegularContents a- mapM_ (\c -> deepLink (a </> c) (f </> c)) cs- else do- srcExists <- Directory.doesFileExist a- destExists <- Directory.doesPathExist f- if- | not srcExists -> error $ "linkShadow: missing source " ++ show a- | destExists -> error $ "linkShadow: destination already exists: "- ++ show f- | otherwise -> createSymbolicLink a f--showProg :: Prog -> String-showProg (Shadow a f) = unwords ["Shadow:", pathIn a, "=>", f]-showProg (Message m) = "Message: " ++ show m-showProg (ProgCall call args cwd) =- wrapCwd- . List.intercalate " \\\n "- $ showCall call : args- where- wrapCwd s = case cwd of- "." -> s- _ -> "(cd " ++ translate cwd ++ " &&\n " ++ s ++ ")"-- showCall (CallArtifact a) = pathIn a- showCall (CallEnv f) = f- showCall (CallTemp f) = f -- TODO: differentiate from CallEnv--showCommand :: CommandQ -> String-showCommand (CommandQ (Command progs inps) outputs) = unlines $- map showOutput outputs- ++ map showInput (Set.toList inps)- ++ map showProg progs- where- showInput i = "Input: " ++ pathIn i- showOutput a = "Output: " ++ a--stdoutOutput :: FilePath-stdoutOutput = "_stdout"--defaultEnv :: [(String, String)]-defaultEnv = [("PATH", "/usr/bin:/bin")]--spliceTempDir :: FilePath -> String -> String-spliceTempDir tmp = T.unpack . T.replace (T.pack "${TMPDIR}") (T.pack tmp) . T.pack--checkAllDistinctPaths :: Monad m => [Artifact] -> m ()-checkAllDistinctPaths as =- case Map.keys . Map.filter (> 1) . Map.fromListWith (+)- . map (\a -> (pathIn a, 1 :: Integer)) $ as of- [] -> return ()- -- TODO: nicer error, telling where they came from:- fs -> error $ "Artifacts generated from more than one command: " ++ show fs---- Remove duplicate artifacts that are both outputs of the same command, and where--- one is a subdirectory of the other (for example, constructed via `/>`).-dedupArtifacts :: Set Artifact -> [Artifact]-dedupArtifacts = loop . Set.toAscList- where- -- Loop over artifacts built from the same command.- -- toAscList plus lexicographic sorting means that- -- subdirectories with the same hash will appear consecutively after directories- -- that contain them.- loop (a@(Artifact (Built h) f) : Artifact (Built h') f' : fs)- -- TODO BUG: "Picture", "Picture.hs" and Picture/Foo.hs" sort in the wrong way- -- so "Picture" and "Picture/Foo.hs" aren't deduped.- | h == h', (f <//> "*") ?== f' = loop (a:fs)- loop (f:fs) = f : loop fs- loop [] = []--freezePath :: FilePath -> IO ()-freezePath f =- getPermissions f >>= setPermissions f . setOwnerWritable False---- | Make all artifacts user-writable, so they can be deleted by `clean-all`.-unfreezeArtifacts :: IO ()-unfreezeArtifacts = do- exists <- Directory.doesDirectoryExist artifactDir- when exists $ forFileRecursive_ unfreeze artifactDir- where- unfreeze f = do- sym <- pathIsSymbolicLink f- unless sym $ getPermissions f >>= setPermissions f . setOwnerWritable True---- TODO: don't loop on symlinks, and be more efficient?-forFileRecursive_ :: (FilePath -> IO ()) -> FilePath -> IO ()-forFileRecursive_ act f = do- isSymLink <- pathIsSymbolicLink f- unless isSymLink $ do- isDir <- Directory.doesDirectoryExist f- if not isDir- then act f- else do- getRegularContents f >>= mapM_ (forFileRecursive_ act . (f </>))- act f--getRegularContents :: FilePath -> IO [FilePath]-getRegularContents f =- filter (not . specialFile) <$> Directory.getDirectoryContents f- where- specialFile "." = True- specialFile ".." = True- specialFile _ = False---- Symlink the artifact into the given destination directory.-linkArtifact :: FilePath -> Artifact -> IO ()-linkArtifact _ (Artifact External f)- | isAbsolute f = return ()-linkArtifact dir a = do- curDir <- getCurrentDirectory- let realPath = curDir </> realPathIn a- let localPath = dir </> pathIn a- checkExists realPath- createParentIfMissing localPath- createSymbolicLink realPath localPath- where- -- Sanity check- checkExists f = do- isFile <- Directory.doesFileExist f- isDir <- Directory.doesDirectoryExist f- when (not isFile && not isDir)- $ error $ "linkArtifact: source does not exist: " ++ show f- ++ " for artifact " ++ show a----- | Returns the relative path to an Artifact within the sandbox, when provided--- to a 'Command' by 'input'.-pathIn :: Artifact -> FilePath-pathIn (Artifact External f) = externalArtifactDir </> f-pathIn (Artifact (Built h) f) = hashDir h </> f---- | Returns the relative path to an artifact within the root directory.-realPathIn :: Artifact -> FilePath-realPathIn (Artifact External f) = f-realPathIn (Artifact (Built h) f) = hashDir h </> f----- | Replace the extension of an Artifact. In particular,------ > pathIn (replaceArtifactExtension f ext) == replaceExtension (pathIn f) ext@-replaceArtifactExtension :: Artifact -> String -> Artifact-replaceArtifactExtension (Artifact s f) ext- = Artifact s $ replaceExtension f ext---- | Read the contents of an Artifact.-readArtifact :: Artifact -> Action String-readArtifact (Artifact External f) = readFile' f -- includes need-readArtifact f = liftIO $ readFile $ pathIn f--readArtifactB :: Artifact -> Action B.ByteString-readArtifactB (Artifact External f) = need [f] >> liftIO (B.readFile f)-readArtifactB f = liftIO $ B.readFile $ pathIn f--data WriteArtifactQ = WriteArtifactQ- { writePath :: FilePath- , writeContents :: String- }- deriving (Eq, Typeable, Generic, Hashable, Binary, NFData)--instance Show WriteArtifactQ where- show w = "Write " ++ writePath w--type instance RuleResult WriteArtifactQ = Artifact--writeArtifact :: FilePath -> String -> Action Artifact-writeArtifact path contents = askPersistent $ WriteArtifactQ path contents--writeArtifactRules :: Rules ()-writeArtifactRules = addPersistent- $ \WriteArtifactQ {writePath = path, writeContents = contents} -> do- let h = makeHash . T.encodeUtf8 . T.pack- $ "writeArtifact: " ++ contents- createArtifacts h $ \tmpDir -> do- let out = tmpDir </> path- createParentIfMissing out- liftIO $ writeFile out contents- return $ Artifact (Built h) $ normalise path--doesArtifactExist :: Artifact -> Action Bool-doesArtifactExist (Artifact External f) = Development.Shake.doesFileExist f-doesArtifactExist f = liftIO $ Directory.doesFileExist (pathIn f)---- Note: this throws an exception if there's no match.-matchArtifactGlob :: Artifact -> FilePath -> Action [FilePath]--- TODO: match the behavior of Cabal-matchArtifactGlob (Artifact External f) g- = getDirectoryFiles f [g]-matchArtifactGlob a g- = liftIO $ matchDirFileGlob (pathIn a) g---- TODO: merge more with above code? How hermetic should it be?-callArtifact :: HandleTemps -> Set Artifact -> Artifact -> [String] -> IO ()-callArtifact ht inps bin args = withPierTempDirectory ht "exec" $ \tmp -> do- dir <- getCurrentDirectory- collectInputs (Set.insert bin inps) tmp- cmd_ [Cwd tmp]- (dir </> tmp </> pathIn bin) args--createDirectoryA :: FilePath -> Command-createDirectoryA f = prog "mkdir" ["-p", f]---- | Group source files by shadowing into a single directory.-groupFiles :: Artifact -> [(FilePath, FilePath)] -> Action Artifact-groupFiles dir files = let out = "group"- in runCommand (output out)- $ createDirectoryA out- <> foldMap (\(f, g) -> shadow (dir /> f) (out </> g))- files
− src/Pier/Core/Directory.hs
@@ -1,12 +0,0 @@-module Pier.Core.Directory- ( createParentIfMissing- ) where--import Control.Monad.IO.Class-import Development.Shake.FilePath-import System.Directory---- | Create recursively the parent of the given path, if it doesn't exist.-createParentIfMissing :: MonadIO m => FilePath -> m ()-createParentIfMissing path- = liftIO $ createDirectoryIfMissing True (takeDirectory path)
− src/Pier/Core/Download.hs
@@ -1,90 +0,0 @@-module Pier.Core.Download- ( askDownload- , Download(..)- , downloadRules- , DownloadLocation(..)- ) where--import Control.Exception (bracketOnError)-import Control.Monad (unless)-import Development.Shake-import Development.Shake.Classes-import Development.Shake.FilePath-import GHC.Generics-import Network.HTTP.Client-import Network.HTTP.Client.TLS-import Network.HTTP.Types.Status--import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L-import qualified System.Directory as Directory--import Pier.Core.Artifact-import Pier.Core.Directory-import Pier.Core.Persistent-import Pier.Core.Run---- | Downloads @downloadUrlPrefix </> downloadName@ to--- @downloadFilePrefix </> downloadName@.--- Everything is stored in `~/.pier/downloads`.-data Download = Download- { downloadUrlPrefix :: String- , downloadName :: FilePath- , downloadFilePrefix :: FilePath- }- deriving (Typeable, Eq, Generic)--instance Show Download where- show d = "Download " ++ show (downloadName d)- ++ " from " ++ show (downloadUrlPrefix d)- ++ " into " ++ show (downloadFilePrefix d)--instance Hashable Download-instance Binary Download-instance NFData Download--type instance RuleResult Download = Artifact--askDownload :: Download -> Action Artifact-askDownload = askPersistent---- TODO: make this its own rule type?-downloadRules :: DownloadLocation -> Rules ()-downloadRules loc = do- manager <- liftIO $ newManager tlsManagerSettings- addPersistent $ \d -> do- -- Download to a shared location under $HOME/.pier, if it doesn't- -- already exist (atomically); then make an artifact that symlinks to it.- downloadsDir <- liftIO $ pierDownloadsDir loc- let result = downloadsDir </> downloadFilePrefix d- </> downloadName d- exists <- liftIO $ Directory.doesFileExist result- unless exists $ do- putNormal $ "Downloading " ++ downloadName d- -- TODO: fix the race- liftIO $ bracketOnError- (createPierTempFile $ takeFileName $ downloadName d)- Directory.removeFile- $ \tmp -> do- let url = downloadUrlPrefix d </> downloadName d- req <- parseRequest url- resp <- httpLbs req manager- unless (statusIsSuccessful . responseStatus $ resp)- $ error $ "Unable to download " ++ show url- ++ "\nStatus: " ++ showStatus (responseStatus resp)- liftIO . L.writeFile tmp . responseBody $ resp- createParentIfMissing result- Directory.renameFile tmp result- return $ externalFile result- where- showStatus s = show (statusCode s) ++ " " ++ BC.unpack (statusMessage s)--pierDownloadsDir :: DownloadLocation -> IO FilePath-pierDownloadsDir DownloadToHome = do- home <- Directory.getHomeDirectory- return $ home </> ".pier/downloads"-pierDownloadsDir DownloadLocal = return $ pierFile "downloads"--data DownloadLocation- = DownloadToHome- | DownloadLocal
− src/Pier/Core/Persistent.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-module Pier.Core.Persistent- ( addPersistent- , askPersistent- , askPersistents- , cleaning- ) where--import Data.Binary (encode, decodeOrFail)-import Development.Shake-import Development.Shake.Classes-import Development.Shake.Rule-import GHC.Generics--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS--newtype Persistent question = Persistent question- deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)---- Improve error messages by just forwarding the instance of the--- wrapped type.-instance Show q => Show (Persistent q) where- show (Persistent q) = show q--newtype PersistentA answer = PersistentA { unPersistentA :: answer }- deriving (Show, Typeable, Eq, Generic, Hashable, Binary, NFData)--type instance RuleResult (Persistent q) = PersistentA (RuleResult q)--addPersistent- :: (RuleResult q ~ a, ShakeValue q, ShakeValue a)- => (q -> Action a)- -> Rules ()-addPersistent act = addBuiltinRule noLint $ \(Persistent q) old depsChanged- -> case old of- Just old' | not depsChanged- , Just val <- decode' old'- -> return $ RunResult ChangedNothing old' val- _ -> do- rerunIfCleaned- new <- PersistentA <$> act q- return $ RunResult- (if (old >>= decode') == Just new- then ChangedRecomputeSame- else ChangedRecomputeDiff)- (encode' new)- new- where- encode' :: Binary a => a -> BS.ByteString- encode' = BS.concat . LBS.toChunks . encode-- decode' :: Binary a => BS.ByteString -> Maybe a- decode' b = case decodeOrFail $ LBS.fromChunks [b] of- Right (bs,_,x)- | LBS.null bs -> Just x- _ -> Nothing---askPersistent- :: (RuleResult q ~ a, ShakeValue q, ShakeValue a)- => q- -> Action a-askPersistent question = do- PersistentA answer <- apply1 $ Persistent question- return answer--askPersistents- :: (RuleResult q ~ a, ShakeValue q, ShakeValue a)- => [q]- -> Action [a]-askPersistents = fmap (map unPersistentA) . apply . map Persistent---data Cleaner = Cleaner- deriving (Show, Typeable, Eq, Generic, Binary, NFData, Hashable)--type instance RuleResult Cleaner = ()--cleaning :: Bool -> Rules ()-cleaning shouldClean = do- action rerunIfCleaned- addBuiltinRule noLint $ \Cleaner _ _ ->- let change = if shouldClean- then ChangedRecomputeDiff- else ChangedNothing- in return $ RunResult change BS.empty ()--rerunIfCleaned :: Action ()-rerunIfCleaned = apply1 Cleaner
− src/Pier/Core/Run.hs
@@ -1,70 +0,0 @@-module Pier.Core.Run- ( -- * Build directory- runPier- , pierFile- , cleanAll- -- * Temporary files and directories- , HandleTemps(..)- , withPierTempDirectory- , withPierTempDirectoryAction- , createPierTempDirectory- , createPierTempFile- ) where--import Control.Monad.IO.Class-import Development.Shake-import Development.Shake.FilePath-import System.Directory-import System.IO.Temp--pierDir :: FilePath-pierDir = "_pier"---- TODO: newtype describing inputs/outputs:-pierFile :: FilePattern -> FilePattern-pierFile = (pierDir </>)--runPier :: Rules () -> IO ()-runPier = shakeArgs shakeOptions- { shakeFiles = pierDir- , shakeProgress = progressSimple- , shakeChange = ChangeDigest- -- Detect the number of threads:- , shakeThreads = 0- }--cleanAll :: Rules ()-cleanAll = action $ do- putNormal $ "Removing " ++ pierDir- removeFilesAfter pierDir ["//"]--data HandleTemps = RemoveTemps | KeepTemps--withPierTempDirectoryAction- :: HandleTemps -> String -> (FilePath -> Action a) -> Action a-withPierTempDirectoryAction KeepTemps template f =- createPierTempDirectory template >>= f-withPierTempDirectoryAction RemoveTemps template f = do- tmp <- createPierTempDirectory template- f tmp `actionFinally` removeDirectoryRecursive tmp--withPierTempDirectory- :: HandleTemps -> String -> (FilePath -> IO a) -> IO a-withPierTempDirectory KeepTemps template f =- createPierTempDirectory template >>= f-withPierTempDirectory RemoveTemps template f = do- createDirectoryIfMissing True pierTempDirectory- withTempDirectory pierTempDirectory template f--pierTempDirectory :: String-pierTempDirectory = pierDir </> "tmp"--createPierTempDirectory :: MonadIO m => String -> m FilePath-createPierTempDirectory template = liftIO $ do- createDirectoryIfMissing True pierTempDirectory- createTempDirectory pierTempDirectory template--createPierTempFile :: MonadIO m => String -> m FilePath-createPierTempFile template = liftIO $ do- createDirectoryIfMissing True pierTempDirectory- writeTempFile pierTempDirectory template ""
src/Pier/Orphans.hs view
@@ -1,5 +1,4 @@ -- | All-purpose module for defining orphan instances.-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} module Pier.Orphans () where @@ -22,7 +21,6 @@ hashWithSalt k = hashWithSalt k . Set.toList instance Hashable FlagName-instance NFData FlagName instance Hashable PackageId instance Hashable PackageName instance Hashable ComponentId