pier (empty) → 0.1.0.0
raw patch · 19 files changed
+3107/−0 lines, 19 filesdep +Cabaldep +aesondep +base
Dependencies added: Cabal, aeson, base, base64-bytestring, binary, binary-orphans, bytestring, containers, cryptohash-sha256, directory, hashable, http-client, http-client-tls, http-types, optparse-applicative, pier, process, shake, split, temporary, text, transformers, unix, unordered-containers, yaml
Files
- LICENSE +13/−0
- app/Main.hs +287/−0
- pier.cabal +92/−0
- src/Pier/Build/CFlags.hs +87/−0
- src/Pier/Build/Components.hs +398/−0
- src/Pier/Build/Config.hs +141/−0
- src/Pier/Build/ConfiguredPackage.hs +107/−0
- src/Pier/Build/Custom.hs +155/−0
- src/Pier/Build/Executable.hs +38/−0
- src/Pier/Build/Module.hs +178/−0
- src/Pier/Build/Package.hs +133/−0
- src/Pier/Build/Stackage.hs +359/−0
- src/Pier/Build/TargetInfo.hs +111/−0
- src/Pier/Core/Artifact.hs +685/−0
- src/Pier/Core/Directory.hs +12/−0
- src/Pier/Core/Download.hs +90/−0
- src/Pier/Core/Persistent.hs +90/−0
- src/Pier/Core/Run.hs +70/−0
- src/Pier/Orphans.hs +61/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright Judah Jacobson 2017.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++
+ app/Main.hs view
@@ -0,0 +1,287 @@+{-# 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
@@ -0,0 +1,92 @@+cabal-version: >=1.10+name: pier+version: 0.1.0.0+license: BSD3+license-file: LICENSE+maintainer: judah.jacobson@gmail.com+homepage: https://github.com/judah/pier#readme+bug-reports: https://github.com/judah/pier/issues+synopsis: Yet another Haskell build system.+description:+ A build system for Haskell projects, built on top of [shake](http://shakebuild.com).+category: Development+build-type: Simple++source-repository head+ type: git+ location: https://github.com/judah/pier++library+ exposed-modules:+ Pier.Build.CFlags+ Pier.Build.Components+ Pier.Build.Config+ Pier.Build.ConfiguredPackage+ Pier.Build.Custom+ Pier.Build.Executable+ Pier.Build.Module+ 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+ 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,+ 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,+ split >=0.2.3.3 && <0.3,+ unordered-containers >=0.2.8.0 && <0.3+ + if os(osx)+ ghc-options: -optP-Wno-nonportable-include-path
+ src/Pier/Build/CFlags.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveAnyClass #-}+module Pier.Build.CFlags+ ( TransitiveDeps(..)+ , CFlags(..)+ , getCFlags+ , ghcDefines+ ) where++import Control.Applicative (liftA2)+import Control.Monad (guard)+import Data.Semigroup+import Data.Set (Set)+import Development.Shake+import Development.Shake.Classes+import Distribution.PackageDescription+import Distribution.System (buildOS, OS(OSX))+import Distribution.Text (display)+import Distribution.Types.PkgconfigDependency+import Distribution.Version (versionNumbers)+import GHC.Generics (Generic(..))++import qualified Data.Set as Set++import Pier.Build.Stackage+import Pier.Core.Artifact++data TransitiveDeps = TransitiveDeps+ { transitiveDBs :: Set Artifact+ , transitiveLibFiles :: Set Artifact+ , transitiveIncludeDirs :: Set Artifact+ , transitiveDataFiles :: Set Artifact+ } deriving (Show, Eq, Typeable, Generic, Hashable, Binary, NFData)++instance Semigroup TransitiveDeps++instance Monoid TransitiveDeps where+ mempty = TransitiveDeps Set.empty Set.empty Set.empty Set.empty+ TransitiveDeps dbs files is datas+ `mappend` TransitiveDeps dbs' files' is' datas'+ = TransitiveDeps (dbs <> dbs') (files <> files') (is <> is')+ (datas <> datas')++-- TODO: macros file also+data CFlags = CFlags+ { ccFlags :: [String]+ , cppFlags :: [String]+ , cIncludeDirs :: Set Artifact+ , linkFlags :: [String]+ , linkLibs :: [String]+ , macFrameworks :: [String]+ }++-- TODO: include macros file too+getCFlags :: TransitiveDeps -> Artifact -> BuildInfo -> Action CFlags+getCFlags deps pkgDir bi = do+ pkgConfFlags <- mconcat <$> mapM getPkgConfFlags (pkgconfigDepends bi)+ return CFlags+ { ccFlags = ccOptions bi ++ fst pkgConfFlags+ , cppFlags = cppOptions bi+ , cIncludeDirs =+ Set.fromList (map (pkgDir />) $ includeDirs bi)+ <> transitiveIncludeDirs deps+ , linkFlags = ldOptions bi ++ snd pkgConfFlags+ , linkLibs = extraLibs bi+ , macFrameworks = guard (buildOS == OSX)+ >> frameworks bi+ }++-- TODO: handle version numbers too+getPkgConfFlags :: PkgconfigDependency -> Action ([String], [String])+getPkgConfFlags (PkgconfigDependency name _) = liftA2 (,)+ (runPkgConfig [display name, "--cflags"])+ (runPkgConfig [display name, "--libs"])+ where+ runPkgConfig = fmap words . runCommandStdout . prog "pkg-config"+++-- | Definitions that GHC provides by default+ghcDefines :: InstalledGhc -> [String]+ghcDefines ghc = ["-D__GLASGOW_HASKELL__=" +++ cppVersion (ghcInstalledVersion ghc)]+ where+ cppVersion v = case versionNumbers v of+ (v1:v2:_) -> show v1 ++ if v2 < 10 then '0':show v2 else show v2+ _ -> error $ "cppVersion: " ++ display v++
+ src/Pier/Build/Components.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE DeriveAnyClass #-}+module Pier.Build.Components+ ( buildPackageRules+ , askBuiltLibrary+ , askMaybeBuiltLibrary+ , askBuiltExecutables+ , askBuiltExecutable+ , BuiltExecutable(..)+ )+ where++import Control.Applicative (liftA2)+import Control.Monad (filterM)+import Data.List (find)+import Data.Semigroup+import Development.Shake+import Development.Shake.Classes+import Development.Shake.FilePath hiding (exe)+import Distribution.Package+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+import qualified Data.Set as Set+import qualified Distribution.InstalledPackageInfo as IP++import Pier.Build.Config+import Pier.Build.ConfiguredPackage+import Pier.Build.Executable+import Pier.Build.CFlags+import Pier.Build.Stackage+import Pier.Build.TargetInfo+import Pier.Core.Artifact+import Pier.Core.Persistent+++buildPackageRules :: Rules ()+buildPackageRules = do+ addPersistent buildLibrary+ addPersistent getBuiltinLib+ addPersistent buildExecutables+ addPersistent buildExecutable++newtype BuiltLibraryQ = BuiltLibraryQ PackageName+ deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)+type instance RuleResult BuiltLibraryQ = Maybe BuiltLibrary++instance Show BuiltLibraryQ where+ show (BuiltLibraryQ p) = "Library " ++ display p+++-- ghc --package-db .../text-1234.pkg/db --package text-1234+data BuiltLibrary = BuiltLibrary+ { builtPackageId :: PackageIdentifier+ , builtPackageTrans :: TransitiveDeps+ }+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)++askBuiltLibraries :: [PackageName] -> Action [BuiltLibrary]+askBuiltLibraries = flip forP askBuiltLibrary++askMaybeBuiltLibrary :: PackageName -> Action (Maybe BuiltLibrary)+askMaybeBuiltLibrary pkg = askPersistent (BuiltLibraryQ pkg)++askBuiltLibrary :: PackageName -> Action BuiltLibrary+askBuiltLibrary pkg = askMaybeBuiltLibrary pkg >>= helper+ where+ helper Nothing = error $ "buildFromDesc: " ++ display pkg+ ++ " does not have a buildable library"+ helper (Just lib) = return lib+++data BuiltDeps = BuiltDeps [PackageIdentifier] TransitiveDeps+ deriving Show++askBuiltDeps+ :: [PackageName]+ -> Action BuiltDeps+askBuiltDeps pkgs = do+ deps <- askBuiltLibraries pkgs+ return $ BuiltDeps (dedup $ map builtPackageId deps)+ (foldMap builtPackageTrans deps)+ where+ dedup = Set.toList . Set.fromList++buildLibrary :: BuiltLibraryQ -> Action (Maybe BuiltLibrary)+buildLibrary (BuiltLibraryQ pkg) =+ getConfiguredPackage pkg >>= \case+ Left p -> Just . BuiltLibrary p <$> askBuiltinLibrary+ (packageIdToUnitId p)+ Right confd+ | Just lib <- library (confdDesc confd)+ , let bi = libBuildInfo lib+ , buildable bi -> Just <$> do+ deps <- askBuiltDeps $ targetDepNames bi+ buildLibraryFromDesc deps confd lib+ | otherwise -> return Nothing+ where+ packageIdToUnitId :: PackageId -> UnitId+ packageIdToUnitId = mkUnitId . display++getBuiltinLib :: BuiltinLibraryR -> Action TransitiveDeps+getBuiltinLib (BuiltinLibraryR p) = do+ ghc <- configGhc <$> askConfig+ result <- runCommandStdout+ $ ghcPkgProg ghc+ ["describe" , display p]+ info <- case IP.parseInstalledPackageInfo result of+ IP.ParseFailed err -> error (show err)+ IP.ParseOk _ info -> return info+ deps <- mapM askBuiltinLibrary $ IP.depends info+ let paths f = Set.fromList . map (parseGlobalPackagePath ghc)+ . f $ info+ return $ mconcat deps <> TransitiveDeps+ { transitiveDBs = Set.empty+ -- Don't bother tracking compile-time files for built-in+ -- libraries, since they're already provided implicitly+ -- by `ghcProg`.+ , transitiveLibFiles = Set.empty+ , transitiveIncludeDirs = paths IP.includeDirs+ -- Make dynamic libraries available at runtime,+ -- falling back to the regular dir if it's not set+ -- (usually these will be the same).+ , transitiveDataFiles = paths IP.libraryDirs+ <> paths IP.libraryDynDirs+ }++askBuiltinLibrary :: UnitId -> Action TransitiveDeps+askBuiltinLibrary = askPersistent . BuiltinLibraryR++newtype BuiltinLibraryR = BuiltinLibraryR UnitId+ deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)+type instance RuleResult BuiltinLibraryR = TransitiveDeps++instance Show BuiltinLibraryR where+ show (BuiltinLibraryR p) = "Library " ++ display p ++ " (built-in)"+++buildLibraryFromDesc+ :: BuiltDeps+ -> ConfiguredPackage+ -> Library+ -> Action BuiltLibrary+buildLibraryFromDesc deps@(BuiltDeps _ transDeps) confd lib = do+ let pkg = package $ confdDesc confd+ conf <- askConfig+ let ghc = configGhc conf+ let lbi = libBuildInfo lib+ tinfo <- getTargetInfo confd lbi (TargetLibrary $ exposedModules lib)+ transDeps ghc+ maybeLib <- if null $ exposedModules lib+ then return Nothing+ else do+ let hiDir = "hi"+ let oDir = "o"+ let libHSName = "HS" ++ display (packageName pkg)+ let dynLibFile = "lib" ++ libHSName+ ++ "-ghc" ++ display (ghcVersion $ plan conf)+ <.> dynExt+ (hiDir', dynLib) <- runCommand+ (liftA2 (,) (output hiDir) (output dynLibFile))+ $ message (display pkg ++ ": building library")+ <> ghcCommand ghc deps confd tinfo+ [ "-this-unit-id", display pkg+ , "-hidir", hiDir+ , "-hisuf", "dyn_hi"+ , "-osuf", "dyn_o"+ , "-odir", oDir+ , "-shared", "-dynamic"+ , "-o", dynLibFile+ ]+ return $ Just (libHSName, lib, dynLib, hiDir')+ (pkgDb, libFiles) <- registerPackage ghc pkg lbi+ (targetCFlags tinfo) maybeLib+ deps+ let linkerData = maybe Set.empty (\(_,_,dyn,_) -> Set.singleton dyn)+ maybeLib+ transInstallIncludes <- collectInstallIncludes (confdSourceDir confd) lbi+ return $ BuiltLibrary pkg+ $ transDeps <> TransitiveDeps+ { transitiveDBs = Set.singleton pkgDb+ , transitiveLibFiles = Set.singleton libFiles+ , transitiveIncludeDirs =+ maybe Set.empty Set.singleton transInstallIncludes+ , transitiveDataFiles = linkerData+ -- TODO: just the lib+ <> Set.singleton libFiles+ }+++-- TODO: double-check no two executables with the same name++newtype BuiltExecutablesQ = BuiltExecutablesQ PackageName+ deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)+type instance RuleResult BuiltExecutablesQ = Map.Map String BuiltExecutable+instance Show BuiltExecutablesQ where+ show (BuiltExecutablesQ p) = "Executables from " ++ display p++askBuiltExecutables :: PackageName -> Action (Map.Map String BuiltExecutable)+askBuiltExecutables = askPersistent . BuiltExecutablesQ++buildExecutables :: BuiltExecutablesQ -> Action (Map.Map String BuiltExecutable)+buildExecutables (BuiltExecutablesQ p) = getConfiguredPackage p >>= \case+ Left _ -> return Map.empty+ Right confd ->+ fmap Map.fromList+ . mapM (\e -> (display $ exeName e,)+ <$> buildExecutableFromPkg confd e)+ . filter (buildable . buildInfo)+ $ executables (confdDesc confd)++-- TODO: error if not buildable?+buildExecutable :: BuiltExecutableQ -> Action BuiltExecutable+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+ | otherwise -> error $ "Package " ++ display (packageId confd)+ ++ " has no executable named " ++ e++buildExecutableFromPkg+ :: ConfiguredPackage+ -> Executable+ -> Action BuiltExecutable+buildExecutableFromPkg confd exe = do+ let name = display $ exeName exe+ 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)+ transDeps ghc+ bin <- runCommand (output out)+ $ message (display (package desc) ++ ": building executable "+ ++ name)+ <> ghcCommand ghc deps confd tinfo+ [ "-o", out+ , "-hidir", "hi"+ , "-odir", "o"+ , "-dynamic"+ , "-threaded"+ ]+ return BuiltExecutable+ { builtBinary = bin+ , builtExeDataFiles = foldr Set.insert (transitiveDataFiles transDeps)+ (confdDataFiles confd)+ }++ghcCommand+ :: InstalledGhc+ -> BuiltDeps+ -> ConfiguredPackage+ -> TargetInfo+ -> [String]+ -> Command+ghcCommand ghc (BuiltDeps depPkgs transDeps) confd tinfo args+ = 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+ -- stay next to c-sources (which the C include system expects).+ -- They're needed directly in the working directory to be available to+ -- template haskell splices.+ <> inputList (map pkgFile $ confdExtraSrcFiles confd)+ <> foldMap (\f -> shadow (pkgFile f) f) (confdExtraSrcFiles confd)+ <> ghcProg ghc (allArgs ++ map pathIn (targetSourceInputs tinfo))+ where+ cflags = targetCFlags tinfo+ pkgFile = (confdSourceDir confd />)+ allArgs =+ -- Rely on GHC for module ordering and hs-boot files:+ [ "--make"+ , "-v0"+ , "-fPIC"+ , "-i"+ ]+ -- Necessary for boot files:+ ++ map (("-i" ++) . pathIn) (targetSourceDirs tinfo)+ +++ concatMap (\p -> ["-package-db", pathIn p])+ (Set.toList $ transitiveDBs transDeps)+ +++ concat [["-package", display d] | d <- depPkgs]+ -- Include files which are sources+ ++ map (("-I" ++) . pathIn . pkgFile) (targetIncludeDirs tinfo)+ -- Include files which are listed as extra-src-files, and thus shadowed directly into+ -- the working dir:+ ++ 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]+ ++ concat [["-framework", f] | f <- macFrameworks cflags]+ -- TODO: configurable+ ++ ["-O0"]+ -- TODO: just for local builds+ ++ ["-w"]+ ++ args++registerPackage+ :: InstalledGhc+ -> PackageIdentifier+ -> BuildInfo+ -> CFlags+ -> Maybe ( String -- Library name for linking+ , Library+ , Artifact -- dyn lib archive+ , Artifact -- hi+ )+ -> BuiltDeps+ -> Action (Artifact, Artifact)+registerPackage ghc pkg bi cflags maybeLib (BuiltDeps depPkgs transDeps)+ = do+ let pre = "files"+ let (collectLibInputs, libDesc) = case maybeLib of+ Nothing -> (createDirectoryA pre, [])+ Just (libHSName, lib, dynLibA, hi) ->+ ( shadow dynLibA (pre </> takeFileName (pathIn dynLibA))+ <> shadow hi (pre </> "hi")+ , [ "hs-libraries: " ++ libHSName+ , "library-dirs: ${pkgroot}" </> pre+ , "dynamic-library-dirs: ${pkgroot}" </> pre+ , "import-dirs: ${pkgroot}" </> pre </> "hi"+ , "exposed-modules: " ++ unwords (map display $ exposedModules lib)+ , "hidden-modules: " ++ unwords (map display $ otherModules bi)+ ]+ )+ spec <- writeArtifact "spec" $ unlines $+ [ "name: " ++ display (packageName pkg)+ , "version: " ++ display (packageVersion pkg)+ , "id: " ++ display pkg+ , "key: " ++ display pkg+ , "extra-libraries: " ++ unwords (linkLibs cflags)+ -- TODO: this list should be string-separated, and make sure+ -- to quote flags that contain strings (e.g. "-Wl,-E" from hslua).+ -- , "ld-options: " ++ unwords (linkFlags cflags)+ , "depends: " ++ unwords (map display depPkgs)+ ]+ ++ [ "frameworks: " ++ unwords (macFrameworks cflags)+ | not (null $ macFrameworks cflags)+ ]+ ++ libDesc+ let db = "db"+ runCommand (liftA2 (,) (output db) (output pre))+ $ collectLibInputs+ <> ghcPkgProg ghc ["init", db]+ <> ghcPkgProg ghc+ (["-v0"]+ ++ [ "--package-db=" ++ pathIn f+ | f <- Set.toList $ transitiveDBs transDeps+ ]+ ++ ["--package-db", db, "register",+ pathIn spec])+ <> input spec+ <> inputs (transitiveDBs transDeps)+++dynExt :: String+dynExt = case buildOS of+ OSX -> "dylib"+ _ -> "so"++collectInstallIncludes :: Artifact -> BuildInfo -> Action (Maybe Artifact)+collectInstallIncludes dir bi+ | null (installIncludes bi) = pure Nothing+ | otherwise = fmap Just (mapM locateHeader (installIncludes bi)+ >>= groupFiles dir)+ where+ -- | Returns the actual location of that header (potentially in some includeDir)+ -- paired with the original name of that header without the dir.+ locateHeader :: FilePath -> Action (FilePath, FilePath)+ locateHeader f = do+ let candidates = map (\d -> (d, dir /> d </> f)) ("" : includeDirs bi)+ existing <- filterM (doesArtifactExist . snd) candidates+ 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
@@ -0,0 +1,141 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+module Pier.Build.Config+ ( configRules+ , askConfig+ , Config(..)+ , Resolved(..)+ , resolvePackage+ , resolvedPackageId+ ) where++import Control.Exception (throw)+import Control.Monad (void)+import Data.Maybe (fromMaybe)+import Data.Yaml+import Development.Shake+import Development.Shake.Classes+import Distribution.Package+import Distribution.Text (display)+import Distribution.Version+import GHC.Generics hiding (packageName)++import qualified Data.HashMap.Strict as HM++import Pier.Build.Package+import Pier.Build.Stackage+import Pier.Core.Artifact+import Pier.Core.Persistent++data PierYamlPath = PierYamlPath+ deriving (Show, Eq, Typeable, Generic)+instance Hashable PierYamlPath+instance Binary PierYamlPath+instance NFData PierYamlPath++type instance RuleResult PierYamlPath = FilePath++configRules :: FilePath -> Rules ()+configRules f = do+ void $ addOracle $ \PierYamlPath -> return f+ void $ addPersistent $ \PierYamlQ -> do+ path <- askOracle PierYamlPath+ need [path]+ yamlE <- liftIO $ decodeFileEither path+ either (liftIO . throw) return yamlE++-- TODO: rename; maybe ConfigSpec and ConfigEnv? Or Config and Env?+data PierYaml = PierYaml+ { resolver :: PlanName+ , packages :: [FilePath]+ , extraDeps :: [PackageIdentifier]+ , systemGhc :: Bool+ } deriving (Show, Eq, Typeable, Generic)+instance Hashable PierYaml+instance Binary PierYaml+instance NFData PierYaml++instance FromJSON PierYaml where+ parseJSON = withObject "PierYaml" $ \o -> do+ r <- o .: "resolver"+ pkgs <- o .:? "packages"+ ed <- o .:? "extra-deps"+ sysGhc <- o .:? "system-ghc"+ return PierYaml+ { resolver = r+ , packages = fromMaybe [] pkgs+ , extraDeps = fromMaybe [] ed+ , systemGhc = fromMaybe False sysGhc+ }++data PierYamlQ = PierYamlQ+ deriving (Eq, Typeable, Generic)+instance Hashable PierYamlQ+instance Binary PierYamlQ+instance NFData PierYamlQ++type instance RuleResult PierYamlQ = PierYaml++instance Show PierYamlQ where+ show _ = "Pier YAML configuration"++data Config = Config+ { plan :: BuildPlan+ , configExtraDeps :: HM.HashMap PackageName Version+ , localPackages :: HM.HashMap PackageName (Artifact, Version)+ , configGhc :: InstalledGhc+ } deriving Show++-- TODO: cache?+askConfig :: Action Config+askConfig = do+ yaml <- askPersistent PierYamlQ+ p <- askBuildPlan (resolver yaml)+ ghc <- askInstalledGhc p (if systemGhc yaml then SystemGhc else StackageGhc)+ -- TODO: don't parse local package defs twice.+ -- We do it again later so the full PackageDescription+ -- doesn't need to get saved in the cache.+ pkgDescs <- mapM (\f -> do+ let a = externalFile f+ pkg <- parseCabalFileInDir a+ return (packageName pkg, (a, packageVersion pkg)))+ $ packages yaml+ return Config+ { plan = p+ , configGhc = ghc+ , localPackages = HM.fromList pkgDescs+ , configExtraDeps = HM.fromList [ (packageName pkg, packageVersion pkg)+ | pkg <- extraDeps yaml+ ]+ }++data Resolved+ = Builtin PackageId+ | Hackage PackageId Flags+ -- TODO: flags for local packages as well+ | Local Artifact PackageId+ deriving (Show,Typeable,Eq,Generic)+instance Hashable Resolved+instance Binary Resolved+instance NFData Resolved++resolvePackage :: Config -> PackageName -> Resolved+resolvePackage conf n+ -- TODO: nicer syntax+ -- core packages can't be overridden. (TODO: is this right?)+ | Just v <- HM.lookup n (corePackageVersions $ plan conf)+ = Builtin $ PackageIdentifier n v+ | Just (a, v) <- HM.lookup n (localPackages conf)+ = Local a $ PackageIdentifier n v+ -- Extra-deps override packages in the build plan:+ | Just v <- HM.lookup n (configExtraDeps conf)+ = Hackage (PackageIdentifier n v) HM.empty+ | Just p <- HM.lookup n (planPackages $ plan conf)+ = 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
@@ -0,0 +1,107 @@+module Pier.Build.ConfiguredPackage+ ( ConfiguredPackage(..)+ , getConfiguredPackage+ , targetDepNames+ , allDependencies+ ) 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 qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set++import Pier.Build.Config+import Pier.Build.Custom+import Pier.Build.Package+import Pier.Build.Stackage (Flags, InstalledGhc)+import Pier.Core.Artifact++data ConfiguredPackage = ConfiguredPackage+ { confdDesc :: PackageDescription+ , confdSourceDir :: Artifact+ , confdMacros :: Artifact+ -- ^ Provides Cabal macros like VERSION_*+ , confdDataFiles :: Maybe Artifact+ , confdExtraSrcFiles :: [FilePath] -- relative to source dir+ }++instance Package ConfiguredPackage where+ packageId = packageId . confdDesc++-- TODO: merge with Resolved+-- TODO: don't copy everything if configuring a local package? Or at least+-- treat deps less coarsely?+getConfiguredPackage+ :: PackageName -> Action (Either PackageId ConfiguredPackage)+getConfiguredPackage p = do+ conf <- askConfig+ case resolvePackage conf p of+ Builtin pid -> return $ Left pid+ Hackage pid flags -> do+ dir <- getPackageSourceDir pid+ Right . addHappyAlexSourceDirs <$> getConfigured conf flags dir+ Local dir _ -> Right <$> getConfigured conf HM.empty dir+ where+ 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++targetDepNames :: BuildInfo -> [PackageName]+targetDepNames bi = [n | Dependency n _ <- targetBuildDepends bi]++allDependencies :: PackageDescription -> [PackageName]+allDependencies desc = let+ allBis = [libBuildInfo l | Just l <- [library desc]]+ ++ map buildInfo (executables desc)+ ++ map testBuildInfo (testSuites desc)+ ++ map benchmarkBuildInfo (benchmarks desc)+ in Set.toList . Set.fromList . concatMap targetDepNames $ allBis++addHappyAlexSourceDirs :: ConfiguredPackage -> ConfiguredPackage+addHappyAlexSourceDirs confd+ | packageName (confdDesc confd) `elem` map mkPackageName ["happy", "alex"]+ = confd { confdDesc = addDistSourceDirs $ confdDesc confd }+ | otherwise = confd++collectDataFiles+ :: InstalledGhc -> PackageDescription -> Artifact -> Action (Maybe Artifact)+collectDataFiles ghc desc dir = case display (packageName desc) of+ "happy" -> Just <$> collectHappyDataFiles ghc dir+ "alex" -> Just <$> collectAlexDataFiles ghc dir+ _ -> collectPlainDataFiles desc dir++-- TODO: should we filter out packages without data-files?+-- Or short-cut it somewhere else?+collectPlainDataFiles+ :: PackageDescription -> Artifact -> Action (Maybe Artifact)+collectPlainDataFiles desc dir = do+ let inDir = dir /> dataDir desc+ if null (dataFiles desc)+ then return Nothing+ else Just <$> do+ files <- concat <$> mapM (matchArtifactGlob dir) (dataFiles desc)+ groupFiles inDir . map (\x -> (x,x)) $ files
+ src/Pier/Build/Custom.hs view
@@ -0,0 +1,155 @@+-- Hacks around Happy and Alex's custom setup scripts, which are used to+-- generate the templates they use at runtime.+--+-- TODO: find a more generic solution for this.+module Pier.Build.Custom+ ( collectHappyDataFiles+ , collectAlexDataFiles+ , addDistSourceDirs+ ) where++import Data.Char (isDigit)+import Data.Monoid+import Development.Shake+import Development.Shake.FilePath+import Distribution.PackageDescription+import Distribution.Text (display)++import Pier.Build.Stackage+import Pier.Core.Artifact++-- | Older versions of Happy and Alex were distributed with a "dist" directory+-- (remnant of Cabal) that contained some bootstrapped source files.+-- Add that directory to the hs-source-dirs for every executable in the package.+addDistSourceDirs :: PackageDescription -> PackageDescription+addDistSourceDirs pkg+ = pkg { executables = map addDistToExe+ $ executables pkg+ }+ where+ addDistToExe e = e {+ buildInfo = (buildInfo e) {+ hsSourceDirs = distPath (display $ exeName e)+ : hsSourceDirs (buildInfo e)+ }+ }+ distPath name = "dist/build" </> name </> name ++ "-tmp"++collectHappyDataFiles+ :: InstalledGhc -> Artifact -> Action Artifact+collectHappyDataFiles ghc dir = do+ as <- concat <$> sequence+ [ mapM (uncurry $ processTemplate ghc (dir /> "templates/GenericTemplate.hs"))+ templates+ , mapM (uncurry $ processTemplate ghc (dir /> "templates/GLR_Base.hs"))+ glr_base_templates+ , mapM (uncurry $ processTemplate ghc (dir /> "templates/GLR_Lib.hs"))+ glr_templates+ ]+ let files = "data-files"+ runCommand (output files) $+ foldMap (\a -> shadow a $ files </> takeBaseName (pathIn a))+ as+ where+ templates :: [(FilePath,[String])]+ templates = [+ ("HappyTemplate" , []),+ ("HappyTemplate-ghc" , ["-DHAPPY_GHC"]),+ ("HappyTemplate-coerce" , ["-DHAPPY_GHC","-DHAPPY_COERCE"]),+ ("HappyTemplate-arrays" , ["-DHAPPY_ARRAY"]),+ ("HappyTemplate-arrays-ghc" , ["-DHAPPY_ARRAY","-DHAPPY_GHC"]),+ ("HappyTemplate-arrays-coerce" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_COERCE"]),+ ("HappyTemplate-arrays-debug" , ["-DHAPPY_ARRAY","-DHAPPY_DEBUG"]),+ ("HappyTemplate-arrays-ghc-debug" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_DEBUG"]),+ ("HappyTemplate-arrays-coerce-debug" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_COERCE","-DHAPPY_DEBUG"])+ ]++ glr_base_templates :: [(FilePath,[String])]+ glr_base_templates = [+ ("GLR_Base" , [])+ ]++ glr_templates :: [(FilePath,[String])]+ glr_templates = [+ ("GLR_Lib" , []),+ ("GLR_Lib-ghc" , ["-DHAPPY_GHC"]),+ ("GLR_Lib-ghc-debug" , ["-DHAPPY_GHC", "-DHAPPY_DEBUG"])+ ]+++++collectAlexDataFiles+ :: InstalledGhc -> Artifact -> Action Artifact+collectAlexDataFiles ghc dir = do+ as <- concat <$> sequence+ [ mapM (uncurry $ processTemplate ghc (dir /> "templates/GenericTemplate.hs"))+ templates+ , mapM (uncurry $ processTemplate ghc (dir /> "templates/wrappers.hs"))+ wrappers+ ]+ let files = "data-files"+ runCommand (output files) $+ foldMap (\a -> shadow a $ files </> takeBaseName (pathIn a))+ as+ where+ templates :: [(FilePath,[String])]+ templates = [+ ("AlexTemplate", []),+ ("AlexTemplate-ghc", ["-DALEX_GHC"]),+ ("AlexTemplate-ghc-nopred",["-DALEX_GHC", "-DALEX_NOPRED"]),+ ("AlexTemplate-ghc-debug", ["-DALEX_GHC","-DALEX_DEBUG"]),+ ("AlexTemplate-debug", ["-DALEX_DEBUG"])+ ]++ wrappers :: [(FilePath,[String])]+ wrappers = [+ ("AlexWrapper-basic", ["-DALEX_BASIC"]),+ ("AlexWrapper-basic-bytestring", ["-DALEX_BASIC_BYTESTRING"]),+ ("AlexWrapper-strict-bytestring", ["-DALEX_STRICT_BYTESTRING"]),+ ("AlexWrapper-posn", ["-DALEX_POSN"]),+ ("AlexWrapper-posn-bytestring", ["-DALEX_POSN_BYTESTRING"]),+ ("AlexWrapper-monad", ["-DALEX_MONAD"]),+ ("AlexWrapper-monad-bytestring", ["-DALEX_MONAD_BYTESTRING"]),+ ("AlexWrapper-monadUserState", ["-DALEX_MONAD", "-DALEX_MONAD_USER_STATE"]),+ ("AlexWrapper-monadUserState-bytestring", ["-DALEX_MONAD_BYTESTRING", "-DALEX_MONAD_USER_STATE"]),+ ("AlexWrapper-gscan", ["-DALEX_GSCAN"])+ ]++processTemplate+ :: InstalledGhc -> Artifact -> String -> [String] -> Action Artifact+processTemplate ghc baseTemplate outFile args = do+ a <- runCommand (output outFile)+ $ ghcProg ghc+ (["-o", outFile, "-E", "-cpp", pathIn baseTemplate] ++ args)+ <> input baseTemplate+ writeArtifact outFile . unlines . map mungeLinePragma . lines+ =<< readArtifact a+++--------------------------------------------------------------------------------+-- Copied from Setup.hs scripts for happy/alex++-- hack to turn cpp-style '# 27 "GenericTemplate.hs"' into+-- '{-# LINE 27 "GenericTemplate.hs" #-}'.+mungeLinePragma :: String -> String+mungeLinePragma line = case symbols line of+ syms | Just prag <- getLinePrag syms -> prag+ -- Also convert old-style CVS lines, no idea why we do this...+ ("--":"$":"Id":":":_) -> filter (/='$') line+ ( "$":"Id":":":_) -> filter (/='$') line+ _ -> line+ where+ getLinePrag :: [String] -> Maybe String+ getLinePrag ("#" : n : string : rest)+ | length rest <= 1 -- clang puts an extra field+ , length string >= 2 && head string == '"' && last string == '"'+ , all isDigit n+ = Just $ "{-# LINE " ++ n ++ " " ++ string ++ " #-}"+ getLinePrag _ = Nothing++ symbols :: String -> [String]+ symbols cs = case lex cs of+ (sym, cs'):_ | not (null sym) -> sym : symbols cs'+ _ -> []+
+ src/Pier/Build/Executable.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveAnyClass #-}+module Pier.Build.Executable+ ( askBuiltExecutable+ , BuiltExecutableQ(..)+ , BuiltExecutable(..)+ , progExe+ ) where++import Data.Semigroup+import Data.Set (Set)+import Development.Shake+import Development.Shake.Classes+import Distribution.Package (PackageName)+import Distribution.Text (display)+import GHC.Generics (Generic(..))++import Pier.Core.Artifact+import Pier.Core.Persistent++data BuiltExecutable = BuiltExecutable+ { builtBinary :: Artifact+ , builtExeDataFiles :: 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++instance Show BuiltExecutableQ where+ show (BuiltExecutableQ p e) = "Executable " ++ e ++ " from " ++ display p++askBuiltExecutable :: PackageName -> String -> Action BuiltExecutable+askBuiltExecutable p e = askPersistent $ BuiltExecutableQ p e++progExe :: BuiltExecutable -> [String] -> Command+progExe exe args = progA (builtBinary exe) args+ <> inputs (builtExeDataFiles exe)
+ src/Pier/Build/Module.hs view
@@ -0,0 +1,178 @@+module Pier.Build.Module+ ( findModule+ , findMainFile+ , findBootFile+ , sourceDirArtifacts+ ) where++import Control.Applicative ((<|>))+import Control.Monad (guard, msum)+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)+import Distribution.PackageDescription+import Distribution.Version (versionNumbers)+import Development.Shake.FilePath+import Distribution.Text (display)++import qualified Data.Set as Set++import Pier.Build.ConfiguredPackage+import Pier.Build.Executable+import Pier.Build.CFlags+import Pier.Build.Stackage+import Pier.Core.Artifact++findModule+ :: InstalledGhc+ -> ConfiguredPackage+ -> CFlags+ -> [Artifact] -- ^ Source directory to check+ -> ModuleName+ -> Action Artifact+findModule ghc confd flags paths m = do+ found <- runMaybeT $ genPathsModule m confd <|>+ msum (map (search ghc flags m) paths)+ maybe (error $ "Missing module " ++ display m+ ++ "; searched " ++ show paths)+ return found++findMainFile+ :: InstalledGhc+ -> CFlags+ -> [Artifact] -- ^ Source directory to check+ -> FilePath+ -> Action Artifact+findMainFile ghc flags paths f = do+ found <- runMaybeT $ msum $+ map findFileDirectly paths +++ map (search ghc flags $ filePathToModule f) paths+ maybe (error $ "Missing main file " ++ f+ ++ "; searched " ++ show paths)+ return found+ where+ findFileDirectly path = do+ let candidate = path /> f+ exists candidate+ return candidate++genPathsModule+ :: ModuleName -> ConfiguredPackage -> MaybeT Action Artifact+genPathsModule m confd = do+ guard $ m == pathsModule+ lift $ writeArtifact ("paths" </> display m <.> "hs") $ unlines+ [ "{-# LANGUAGE CPP #-}"+ , "{-# LANGUAGE ImplicitPrelude #-}"+ , "module " ++ display m ++ " (getDataFileName, getDataDir, version) where"+ , "import Data.Version (Version(..))"+ , "version = Version " ++ show (versionNumbers+ $ pkgVersion pkg)+ ++ ""+ ++ " []" -- tags are deprecated+ , "getDataFileName :: FilePath -> IO FilePath"+ , "getDataFileName f = (\\d -> d ++ \"/\" ++ f) <$> getDataDir"+ , "getDataDir :: IO FilePath"+ , "getDataDir = " ++ maybe err (("return " ++) . show . pathIn)+ (confdDataFiles confd)+ ]+ where+ pkg = package (confdDesc confd)+ pathsModule = fromString $ "Paths_" ++ map fixHyphen (display $ pkgName pkg)+ fixHyphen '-' = '_'+ fixHyphen c = c+ err = "error " ++ show ("Missing data files from package " ++ display pkg)+++search+ :: InstalledGhc+ -> CFlags+ -> ModuleName+ -> Artifact -- ^ Source directory to check+ -> MaybeT Action Artifact+search ghc flags m srcDir+ = genHsc2hs <|>+ genHappy "y" <|>+ genHappy "ly" <|>+ genAlex "x" <|>+ genC2hs <|>+ existing "lhs" <|>+ existing "hs"+ where+ existing ext = let f = srcDir /> toFilePath m <.> ext+ in exists f >> return f++ genHappy ext = do+ let yFile = srcDir /> toFilePath m <.> ext+ exists yFile+ let relOutput = toFilePath m <.> "hs"+ happy <- lift $ askBuiltExecutable (mkPackageName "happy") "happy"+ lift . runCommand (output relOutput)+ $ progExe happy+ ["-o", relOutput, pathIn yFile]+ <> input yFile++ genHsc2hs = do+ let hsc = srcDir /> toFilePath m <.> "hsc"+ exists hsc+ let relOutput = toFilePath m <.> "hs"+ lift $ runCommand (output relOutput)+ $ hsc2hsProg ghc+ (["-o", relOutput+ , pathIn hsc+ ]+ ++ ["--cflag=" ++ f | f <- ccFlags flags+ ++ cppFlags flags]+ ++ ["-I" ++ pathIn f | f <- Set.toList $ cIncludeDirs flags]+ ++ ghcDefines ghc)+ <> input hsc <> inputs (cIncludeDirs flags)++ genAlex ext = do+ let xFile = srcDir /> toFilePath m <.> ext+ exists xFile+ let relOutput = toFilePath m <.> "hs"+ -- TODO: mkPackageName doesn't exist in older ones+ alex <- lift $ askBuiltExecutable (mkPackageName "alex") "alex"+ lift . runCommand (output relOutput)+ $ progExe alex+ ["-o", relOutput, pathIn xFile]+ <> input xFile+ genC2hs = do+ let chsFile = srcDir /> toFilePath m <.> "chs"+ exists chsFile+ let relOutput = toFilePath m <.> "hs"+ c2hs <- lift $ askBuiltExecutable (mkPackageName "c2hs") "c2hs"+ lift . runCommand (output relOutput)+ $ input chsFile+ <> inputs (cIncludeDirs flags)+ <> progExe c2hs+ (["-o", relOutput, pathIn chsFile]+ ++ ["--include=" ++ pathIn f | f <- Set.toList (cIncludeDirs flags)]+ ++ ["--cppopts=" ++ f | f <- ccFlags flags ++ cppFlags flags+ ++ ghcDefines ghc]+ )+-- TODO: issue if this doesn't preserve ".lhs" vs ".hs", for example?+filePathToModule :: FilePath -> ModuleName+filePathToModule = fromString . intercalate "." . splitDirectories . dropExtension++exists :: Artifact -> MaybeT Action ()+exists f = lift (doesArtifactExist f) >>= guard++-- Find the "hs-boot" file corresponding to a "hs" file.+findBootFile :: Artifact -> Action (Maybe Artifact)+findBootFile hs = do+ let hsBoot = replaceArtifactExtension hs "hs-boot"+ bootExists <- doesArtifactExist hsBoot+ return $ guard bootExists >> return hsBoot++sourceDirArtifacts :: Artifact -> BuildInfo -> [Artifact]+sourceDirArtifacts packageSourceDir bi+ = map (packageSourceDir />) $ ifNullDirs $ hsSourceDirs bi++-- TODO: Organize the arguments to this function better.+ifNullDirs :: [FilePath] -> [FilePath]+ifNullDirs [] = [""]+ifNullDirs xs = xs
+ src/Pier/Build/Package.hs view
@@ -0,0 +1,133 @@+module Pier.Build.Package+ ( getPackageSourceDir+ , configurePackage+ , parseCabalFileInDir+ ) where++import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup+import Development.Shake+import Development.Shake.FilePath+import Distribution.Compiler+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import Distribution.System (buildOS, buildArch)+import Distribution.Text (display)+import Distribution.Types.CondTree (CondBranch(..))+import Distribution.Version (withinRange)++import qualified Data.HashMap.Strict as HM++import Pier.Build.Stackage+import Pier.Core.Artifact+import Pier.Core.Download++downloadCabalPackage :: PackageIdentifier -> Action Artifact+downloadCabalPackage pkg = do+ let n = display pkg+ askDownload Download+ { downloadFilePrefix = "hackage"+ , downloadName = n <.> "tar.gz"+ , downloadUrlPrefix = "https://hackage.haskell.org/package" </> n+ }++getPackageSourceDir :: PackageIdentifier -> Action Artifact+getPackageSourceDir pkg = do+ tarball <- downloadCabalPackage pkg+ runCommand (output outDir)+ $ message ("Unpacking " ++ display pkg)+ <> prog "tar" ["-xzf", pathIn tarball, "-C", takeDirectory outDir]+ <> input tarball+ where+ outDir = "package/raw" </> display pkg++configurePackage :: BuildPlan -> Flags -> Artifact -> Action (PackageDescription, Artifact)+configurePackage plan flags packageSourceDir = do+ gdesc <- parseCabalFileInDir packageSourceDir+ let desc = flattenToDefaultFlags plan flags gdesc+ let name = display (packageName desc)+ case buildType desc of+ Just Configure -> do+ let configuredDir = name+ configuredPackage <- runCommand (output configuredDir)+ $ shadow packageSourceDir configuredDir+ <> message ("Configuring " ++ name)+ <> withCwd configuredDir (progTemp (configuredDir </> "configure") [])+ let buildInfoFile = configuredPackage />+ (name <.> "buildinfo")+ 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+ else return desc+ return (desc', configuredPackage)+ -- Best effort: ignore custom setup scripts.+ _ -> return (desc, packageSourceDir)++parseCabalFileInDir :: Artifact -> Action GenericPackageDescription+parseCabalFileInDir dir = do+ cabalFile <- findCabalFile dir+ cabalContents <- readArtifact 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++findCabalFile :: Artifact -> Action Artifact+findCabalFile dir = do+ cabalFiles <- matchArtifactGlob dir "*.cabal"+ case cabalFiles of+ [f] -> return (dir /> f)+ [] -> error $ "No *.cabal files found in " ++ show dir+ _ -> error $ "Multiple *.cabal files found: " ++ show cabalFiles++flattenToDefaultFlags+ :: BuildPlan -> Flags -> GenericPackageDescription -> PackageDescription+flattenToDefaultFlags plan planFlags gdesc = let+ desc0 = packageDescription gdesc+ -- Bias towards plan flags (since they override the defaults)+ flags = planFlags `HM.union` HM.fromList [(flagName f, flagDefault f)+ | f <- genPackageFlags gdesc+ ]+ in desc0+ -- TODO: Nothing vs Nothing?+ { library = resolve plan flags <$> condLibrary gdesc+ , executables = map (\(n, e) -> (resolve plan flags e) { exeName = n })+ $ condExecutables gdesc+ }++resolve+ :: Semigroup a+ => BuildPlan+ -> HM.HashMap FlagName Bool+ -> CondTree ConfVar [Dependency] a+ -> a+resolve plan flags node+ = sconcat+ $ condTreeData node :|+ [ resolve plan flags t+ | CondBranch cond ifTrue ifFalse+ <- condTreeComponents node+ , Just t <- [if isTrue plan flags cond+ then Just ifTrue+ else ifFalse]]++isTrue :: BuildPlan -> HM.HashMap FlagName Bool -> Condition ConfVar -> Bool+isTrue plan flags = loop+ where+ loop (Var (Flag f))+ | Just x <- HM.lookup f flags = x+ | otherwise = error $ "Unknown flag: " ++ show f+ loop (Var (Impl GHC range)) = withinRange (ghcVersion plan) range+ loop (Var (Impl _ _)) = False+ loop (Var (OS os)) = os == buildOS+ loop (Var (Arch arch)) = arch == buildArch+ loop (Lit x) = x+ loop (CNot x) = not $ loop x+ loop (COr x y) = loop x || loop y+ loop (CAnd x y) = loop x && loop y
+ src/Pier/Build/Stackage.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+module Pier.Build.Stackage+ ( buildPlanRules+ , askBuildPlan+ , askInstalledGhc+ , installGhcRules+ , InstalledGhc(..)+ , GhcDistro(..)+ , ghcArtifacts+ , ghcProg+ , ghcPkgProg+ , hsc2hsProg+ , parseGlobalPackagePath+ , PlanName(..)+ , BuildPlan(..)+ , PlanPackage(..)+ , Flags+ ) where++import Control.Exception (throw)+import Data.Binary.Orphans ()+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Yaml+import Development.Shake+import Development.Shake.Classes+import Development.Shake.FilePath+import Distribution.Package+import Distribution.PackageDescription (FlagName)+import Distribution.System (buildPlatform, Platform(..), Arch(..), OS(..))+import Distribution.Version+import GHC.Generics++import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Distribution.Text as Cabal++import Pier.Core.Artifact+import Pier.Core.Download+import Pier.Core.Persistent+import Pier.Orphans ()++newtype PlanName = PlanName { renderPlanName :: String }+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)++instance FromJSON PlanName where+ parseJSON = fmap PlanName . parseJSON++data BuildPlan = BuildPlan+ { corePackageVersions :: HM.HashMap PackageName Version+ , planPackages :: HM.HashMap PackageName PlanPackage+ , ghcVersion :: Version+ } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)++data PlanPackage = PlanPackage+ { planPackageVersion :: Version+ , planPackageFlags :: Flags+ } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)++type Flags = HM.HashMap FlagName Bool++instance FromJSON BuildPlan where+ parseJSON = withObject "Plan" $ \o -> do+ sys <- o .: "system-info"+ coreVersions <- sys .: "core-packages"+ ghcVers <- sys .: "ghc-version"+ pkgs <- o .: "packages"+ return BuildPlan { corePackageVersions = coreVersions+ , planPackages = pkgs+ , ghcVersion = ghcVers+ }++instance FromJSON PlanPackage where+ parseJSON = withObject "PlanPackage" $ \o ->+ PlanPackage <$> (o .: "version") <*> ((o .: "constraints") >>= (.: "flags"))++buildPlanRules :: Rules ()+buildPlanRules = addPersistent $ \(ReadPlan planName) -> do+ f <- askDownload Download+ { downloadFilePrefix = "stackage/plan"+ , downloadName = renderPlanName planName <.> "yaml"+ , downloadUrlPrefix = planUrlPrefix planName+ }+ cs <- readArtifactB f+ case decodeEither' cs of+ Left err -> throw err+ Right x -> return x++planUrlPrefix :: PlanName -> String+planUrlPrefix (PlanName name)+ | "lts-" `List.isPrefixOf` name = ltsBuildPlansUrl+ | "nightly-" `List.isPrefixOf` name = nightlyBuildPlansUrl+ | otherwise = error $ "Unrecognized plan name " ++ show name+ where+ ltsBuildPlansUrl = "https://raw.githubusercontent.com/fpco/lts-haskell/master/"+ nightlyBuildPlansUrl = "https://raw.githubusercontent.com/fpco/stackage-nightly/master/"++newtype ReadPlan = ReadPlan PlanName+ deriving (Typeable,Eq,Hashable,Binary,NFData,Generic)+type instance RuleResult ReadPlan = BuildPlan++instance Show ReadPlan where+ show (ReadPlan p) = "Read build plan: " ++ renderPlanName p++askBuildPlan :: PlanName -> Action BuildPlan+askBuildPlan = askPersistent . ReadPlan+++data InstalledGhcQ = InstalledGhcQ GhcDistro Version [PackageName]+ deriving (Typeable, Eq, Hashable, Binary, NFData, Generic)++data GhcDistro+ = SystemGhc+ | StackageGhc+ deriving (Show, Typeable, Eq, Hashable, Binary, NFData, Generic)++instance Show InstalledGhcQ where+ show (InstalledGhcQ d v pn) = "GHC"+ ++ " " ++ show d+ ++ ", version " ++ Cabal.display v+ ++ ", built-in packages "+ ++ List.intercalate ", " (map Cabal.display pn)++-- | TODO: make the below functions that use Version take InstalledGhc directly instead+data InstalledGhc = InstalledGhc+ { ghcLibRoot :: Artifact+ , ghcInstalledVersion :: Version+ } deriving (Show, Typeable, Eq, Generic)+instance Hashable InstalledGhc+instance Binary InstalledGhc+instance NFData InstalledGhc++type instance RuleResult InstalledGhcQ = InstalledGhc++globalPackageDb :: InstalledGhc -> Artifact+globalPackageDb ghc = ghcLibRoot ghc /> packageConfD++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+ = askPersistent $ InstalledGhcQ distro (ghcVersion plan)+ $ HM.keys $ corePackageVersions plan++-- | Convert @${pkgroot}@ prefixes, for utilities like hsc2hs that don't+-- see packages directly+--+parseGlobalPackagePath :: InstalledGhc -> FilePath -> Artifact+parseGlobalPackagePath ghc f+ | Just f' <- List.stripPrefix "${pkgroot}/" f+ = ghcLibRoot ghc /> f'+ | otherwise = externalFile f++ghcBinDir :: InstalledGhc -> Artifact+ghcBinDir ghc = ghcLibRoot ghc /> "bin"++ghcProg :: InstalledGhc -> [String] -> Command+ghcProg ghc args =+ progA (ghcBinDir ghc /> "ghc")+ (["-B" ++ pathIn (ghcLibRoot ghc)+ , "-clear-package-db"+ , "-hide-all-packages"+ , "-package-db=" ++ pathIn (globalPackageDb ghc)+ ] ++ args)+ <> input (ghcLibRoot ghc)+ <> input (globalPackageDb ghc)++ghcPkgProg :: InstalledGhc -> [String] -> Command+ghcPkgProg ghc args =+ progA (ghcBinDir ghc /> "ghc-pkg")+ ([ "--global-package-db=" ++ pathIn (globalPackageDb ghc)+ , "--no-user-package-db"+ , "--no-user-package-conf"+ ] ++ args)+ <> input (ghcLibRoot ghc)+ <> input (globalPackageDb ghc)++hsc2hsProg :: InstalledGhc -> [String] -> Command+hsc2hsProg ghc args =+ progA (ghcBinDir ghc /> "hsc2hs")+ (("--template=${TMPDIR}/" ++ pathIn template) : args)+ <> input template+ where+ template = ghcLibRoot ghc /> "template-hsc.h"++installGhcRules :: Rules ()+installGhcRules = addPersistent installGhc++installGhc :: InstalledGhcQ -> Action InstalledGhc+installGhc (InstalledGhcQ distro version corePkgs) = do+ installed <- case distro of+ StackageGhc -> downloadAndInstallGHC version+ SystemGhc -> getSystemGhc version+ fixed <- makeRelativeGlobalDb corePkgs installed+ runCommand_ $ ghcPkgProg fixed ["check"]+ return fixed++getSystemGhc :: Version -> Action InstalledGhc+getSystemGhc version = do+ path <- fmap (head . words) . runCommandStdout+ $ prog (versionedGhc version) ["--print-libdir"]+ return $ InstalledGhc (externalFile path) version++data DownloadInfo = DownloadInfo+ { downloadUrl :: String+ -- TODO: use these+ , _contentLength :: Int+ , _sha1 :: String+ }++instance FromJSON DownloadInfo where+ parseJSON = withObject "DownloadInfo" $ \o ->+ DownloadInfo <$> o .: "url"+ <*> o .: "content-length"+ <*> o .: "sha1"++-- TODO: multiple OSes, configure-env++newtype StackSetup = StackSetup { ghcVersions :: HM.HashMap Version DownloadInfo }++instance FromJSON StackSetup where+ parseJSON = withObject "StackSetup" $ \o -> do+ ghc <- o .: "ghc"+ StackSetup <$> (ghc .: platformKey)++-- TODO: make this more configurable (eventually, using+-- `LocalBuildInfo.hostPlatform` to help support cross-compilation)+platformKey :: Text+platformKey = case buildPlatform of+ Platform I386 Linux -> "linux32"+ Platform X86_64 Linux -> "linux64"+ Platform I386 OSX -> "macosx"+ Platform X86_64 OSX -> "macosx"+ Platform I386 FreeBSD -> "freebsd32"+ Platform X86_64 FreeBSD -> "freebsd64"+ Platform I386 OpenBSD -> "openbsd32"+ Platform X86_64 OpenBSD -> "openbsd64"+ Platform I386 Windows -> "windows32"+ Platform X86_64 Windows -> "windows64"+ Platform Arm Linux -> "linux-armv7"+ _ -> error $ "Unrecognized platform: " ++ Cabal.display buildPlatform++setupUrl :: String+setupUrl = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack"++downloadAndInstallGHC+ :: Version -> Action InstalledGhc+downloadAndInstallGHC version = do+ setupYaml <- askDownload Download+ { downloadFilePrefix = "stackage/setup"+ , downloadName = "stack-setup-2.yaml"+ , downloadUrlPrefix = setupUrl+ }+ -- TODO: don't re-parse the yaml for every GHC version+ cs <- readArtifactB setupYaml+ download <- case decodeEither' cs of+ Left err -> throw err+ Right x+ | Just download <- HM.lookup version (ghcVersions x)+ -> pure download+ | otherwise -> fail $ "Couldn't find GHC version" ++ Cabal.display version+ -- TODO: reenable this once we've fixed the issue with nondetermistic+ -- temp file locations.+ -- rerunIfCleaned+ let (url, f) = splitFileName $ downloadUrl download+ tar <- askDownload Download+ { downloadFilePrefix = "stackage/ghc"+ , downloadName = f+ , downloadUrlPrefix = url+ }+ -- TODO: check file size and sha1+ -- GHC's configure step requires an absolute prefix.+ -- We'll install it explicitly in ${TMPDIR}, but that puts explicit references+ -- to those paths in the package DB. So we'll then generate a new DB with+ -- relative paths.+ let installDir = "ghc-install"+ let unpackedDir = versionedGhc version+ installed <- runCommand+ (output installDir)+ $ message "Unpacking GHC"+ <> input tar+ <> prog "tar" ["-xJf", pathIn tar]+ <> withCwd unpackedDir+ (message "Installing GHC locally"+ <> progTemp (unpackedDir </> "configure")+ ["--prefix=${TMPDIR}/" ++ installDir]+ <> prog "make" ["install"])+ return InstalledGhc { ghcLibRoot = installed /> "lib" </> versionedGhc version+ , ghcInstalledVersion = version+ }++versionedGhc :: Version -> String+versionedGhc version = "ghc-" ++ Cabal.display version++makeRelativeGlobalDb :: [PackageName] -> InstalledGhc -> Action InstalledGhc+makeRelativeGlobalDb corePkgs ghc = do+ let corePkgsSet = Set.fromList corePkgs+ -- List all packages, excluding Cabal which stack doesn't consider a "core"+ -- package.+ -- TODO: if our package ids included a hash, this wouldn't be as big a problem+ -- because two versions of the same package could exist simultaneously.+ builtinPackages <- fmap (filter ((`Set.member` corePkgsSet) . mkPackageName)+ . words)+ . runCommandStdout+ $ ghcPkgProg ghc+ ["list", "--global", "--names-only",+ "--simple-output" ]+ let makePkgConf pkg = do+ desc <- runCommandStdout+ $ ghcPkgProg ghc ["describe", pkg]+ let tempRoot = parsePkgRoot desc+ let desc' =+ T.unpack+ . T.replace (T.pack tempRoot)+ (T.pack "${pkgroot}")+ . T.pack+ $ desc+ writeArtifact (pkg ++ ".conf") desc'+ confs <- mapM makePkgConf builtinPackages+ -- let globalRelativePackageDb = "global-packages/package-fixed.conf.d"+ let ghcFixed = "ghc-fixed"+ let db = ghcFixed </> packageConfD+ let ghcPkg = progTemp (ghcFixed </> "bin/ghc-pkg")+ ghcDir <- runCommand (output ghcFixed)+ $ shadow (ghcLibRoot ghc) ghcFixed+ <> inputList confs+ <> message "Making global DB relative"+ <> prog "rm" ["-rf", db]+ <> ghcPkg ["init", db]+ <> foldMap+ (\conf -> ghcPkg+ [ "register", pathIn conf+ , "--global-package-db=" ++ db+ , "--no-user-package-db"+ , "--no-user-package-conf"+ , "--no-expand-pkgroot"+ , "--force"+ ])+ confs+ return ghc { ghcLibRoot = ghcDir }++-- TODO: this gets the TMPDIR that was used when installing; consider allowing+-- that to be captured explicitly.+parsePkgRoot :: String -> String+parsePkgRoot desc = loop $ lines desc+ where+ loop [] = error "Couldn't parse pkgRoot: " ++ show desc+ loop (l:ls)+ | take (length prefix) l == prefix = takeDirectory+ $ drop (length prefix) l+ | otherwise = loop ls+ prefix = "library-dirs: "
+ src/Pier/Build/TargetInfo.hs view
@@ -0,0 +1,111 @@+module Pier.Build.TargetInfo+ ( TargetInfo(..)+ , TargetResult(..)+ , TransitiveDeps(..)+ , getTargetInfo+ ) where++import Control.Monad (filterM)+import Data.List (nub)+import Data.Maybe (catMaybes, fromMaybe)+import Development.Shake+import Development.Shake.FilePath ((</>))+import Distribution.Compiler (CompilerFlavor(GHC))+import Distribution.ModuleName+import Distribution.Package (packageName)+import Distribution.PackageDescription+import Distribution.Text (display)+import Language.Haskell.Extension++import Pier.Build.CFlags+import Pier.Build.ConfiguredPackage+import Pier.Build.Module+import Pier.Build.Stackage+import Pier.Core.Artifact++data TargetInfo = TargetInfo+ { targetCFlags :: CFlags+ , targetSourceInputs :: [Artifact]+ -- ^ Source files to pass on command line+ , targetOtherInputs :: [Artifact]+ -- ^ Other files to pass on command line+ , targetOptions :: [String]+ , targetIncludeDirs :: [FilePath]+ -- ^ Directories in which GHC should look for includes+ -- TODO: merge with CFlags? Make Artifact?+ , targetSourceDirs :: [Artifact]+ -- ^ Directories in which GHC should look for boot files+ , targetOtherModules :: [ModuleName]+ }++data TargetResult+ = TargetBinary { targetModulePath :: FilePath }+ | TargetLibrary+ { targetExposedModules :: [ModuleName]+ }++getTargetInfo ::+ ConfiguredPackage+ -> BuildInfo+ -> TargetResult+ -> TransitiveDeps+ -> InstalledGhc+ -> Action TargetInfo+getTargetInfo confd bi result deps ghc = do+ let packageSourceDir = confdSourceDir confd+ cflags <- getCFlags deps packageSourceDir bi+ let allOptions = map ("-X" ++)+ (display (fromMaybe Haskell98 $ defaultLanguage bi)+ : map display (defaultExtensions bi ++ oldExtensions bi))+ ++ concat [opts | (GHC,opts) <- options bi]+ let srcDirs = sourceDirArtifacts packageSourceDir bi+ let fixDashes = map $ \c -> if c == '-' then '_' else c+ let pathsMod = fromString $ "Paths_" ++ fixDashes (display $ packageName confd)+ let allModules = otherModules bi ++ case result of+ TargetLibrary exposed -> exposed+ TargetBinary _+ -- Add the Paths_ module automatically to other-modules+ -- of binaries.+ -- TODO: consider whether this is intended behavior of Cabal.+ -> [pathsMod | pathsMod `notElem` otherModules bi]+ moduleFiles <- mapM (findModule ghc confd cflags srcDirs)+ allModules+ moduleBootFiles <- catMaybes <$> mapM findBootFile moduleFiles+ let cFiles = map (packageSourceDir />) $ cSources bi+ cIncludes <- collectCIncludes (confdDesc confd) bi (packageSourceDir />)+ moduleMainFiles <- case result of+ TargetLibrary{} -> return []+ TargetBinary f -> do+ path <- findMainFile ghc cflags srcDirs f+ return [path | path `notElem` moduleFiles]+ return TargetInfo+ { targetCFlags = cflags+ , targetSourceInputs = cFiles ++ moduleFiles ++ moduleMainFiles+ , targetOtherInputs = cIncludes ++ moduleBootFiles+ , targetOptions = allOptions+ , targetIncludeDirs = includeDirs bi+ , targetSourceDirs = srcDirs+ , targetOtherModules = otherModules bi+ }+ ++collectCIncludes :: PackageDescription -> BuildInfo -> (FilePath -> Artifact) -> Action [Artifact]+collectCIncludes desc bi pkgDir = do+ includeInputs <- findIncludeInputs pkgDir bi+ extraTmps <- fmap catMaybes . mapM ((\f -> doesArtifactExist f >>= \case+ True -> return (Just f)+ False -> return Nothing)+ . pkgDir)+ $ extraTmpFiles desc+ return $ includeInputs ++ extraTmps++findIncludeInputs :: (FilePath -> Artifact) -> BuildInfo -> Action [Artifact]+findIncludeInputs pkgDir bi = filterM doesArtifactExist candidates+ where+ candidates = nub -- TODO: more efficient+ [ pkgDir $ d </> f+ -- TODO: maybe just installIncludes shouldn't be prefixed+ -- with include dir?+ | d <- "" : includeDirs bi+ , f <- includes bi ++ installIncludes bi+ ]
+ src/Pier/Core/Artifact.hs view
@@ -0,0 +1,685 @@+{- | 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 view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,90 @@+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 view
@@ -0,0 +1,90 @@+{-# 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 view
@@ -0,0 +1,70 @@+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
@@ -0,0 +1,61 @@+-- | All-purpose module for defining orphan instances.+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Pier.Orphans () where++import Data.Aeson.Types+import Development.Shake.Classes+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Utils.ShortText+import Distribution.Version++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Distribution.Text as Cabal++instance (Hashable k, Hashable v) => Hashable (Map.Map k v) where+ hashWithSalt k = hashWithSalt k . Map.toList++instance Hashable a => Hashable (Set.Set a) where+ hashWithSalt k = hashWithSalt k . Set.toList++instance Hashable FlagName+instance NFData FlagName+instance Hashable PackageId+instance Hashable PackageName+instance Hashable ComponentId+instance Hashable UnitId+instance Hashable ShortText+instance Hashable Version++instance FromJSON Version where+ parseJSON = withText "Version" simpleParser++instance FromJSONKey Version where+ fromJSONKey = cabalKeyTextParser++instance FromJSON PackageName where+ parseJSON = withText "PackageName" simpleParser++instance FromJSONKey PackageName where+ fromJSONKey = cabalKeyTextParser++instance FromJSON FlagName where+ parseJSON = fmap mkFlagName . parseJSON++instance FromJSONKey FlagName where+ fromJSONKey = FromJSONKeyText (mkFlagName . T.unpack)++instance FromJSON PackageIdentifier where+ parseJSON = withText "PackageIdentifier" simpleParser++simpleParser :: Cabal.Text a => T.Text -> Parser a+simpleParser t = case Cabal.simpleParse (T.unpack t) of+ Just v -> pure v+ Nothing -> fail $ "Unable to parse: "+ ++ show t++cabalKeyTextParser :: Cabal.Text a => FromJSONKeyFunction a+cabalKeyTextParser = FromJSONKeyTextParser simpleParser