build-env 1.1.0.0 → 1.2.0.0
raw patch · 14 files changed
+1115/−648 lines, 14 filesdep +semaphore-compatdep ~aesondep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: semaphore-compat
Dependency ranges changed: aeson, base, containers, filepath, text, time, transformers
API changes (from Hackage documentation)
- BuildEnv.BuildOne: getPkgDbDirsForBuild :: Paths ForBuild -> IO (PkgDbDirs ForBuild)
- BuildEnv.BuildOne: getPkgDbDirsForPrep :: Paths ForPrep -> PkgDbDirs ForPrep
- BuildEnv.Config: NoSem :: AsyncSem
- BuildEnv.Utils: [progPath] :: ProgPath -> !FilePath
- BuildEnv.Utils: newAbstractSem :: AsyncSem -> IO AbstractSem
+ BuildEnv.BuildOne: getPkgDbDirForBuild :: Paths ForBuild -> IO (PkgDbDir ForBuild)
+ BuildEnv.BuildOne: getPkgDbDirForPrep :: Paths ForPrep -> PkgDbDir ForPrep
+ BuildEnv.Config: ExistingJSem :: !String -> AsyncSem
+ BuildEnv.Config: IndexState :: Text -> IndexState
+ BuildEnv.Config: NewJSem :: !Word16 -> AsyncSem
+ BuildEnv.Config: instance GHC.Classes.Eq BuildEnv.Config.IndexState
+ BuildEnv.Config: instance GHC.Show.Show (BuildEnv.Config.BuildPaths 'BuildEnv.Config.ForBuild)
+ BuildEnv.Config: instance GHC.Show.Show (BuildEnv.Config.BuildPaths 'BuildEnv.Config.ForPrep)
+ BuildEnv.Config: instance GHC.Show.Show (BuildEnv.Config.BuildPaths 'BuildEnv.Config.Raw)
+ BuildEnv.Config: instance GHC.Show.Show (BuildEnv.Config.BuildPaths use) => GHC.Show.Show (BuildEnv.Config.Paths use)
+ BuildEnv.Config: instance GHC.Show.Show BuildEnv.Config.IndexState
+ BuildEnv.Config: newtype IndexState
+ BuildEnv.Path: (<.>) :: FileLike p => p -> String -> p
+ BuildEnv.Path: (</>) :: PathLike p q r => p -> q -> r
+ BuildEnv.Path: Dir :: Type -> FileOrDir
+ BuildEnv.Path: File :: FileOrDir
+ BuildEnv.Path: absoluteSymbolicPath :: AbsolutePath to -> SymbolicPath from to
+ BuildEnv.Path: data AbsolutePath to
+ BuildEnv.Path: data CWD
+ BuildEnv.Path: data Fetch
+ BuildEnv.Path: data FileOrDir
+ BuildEnv.Path: data Install
+ BuildEnv.Path: data Logs
+ BuildEnv.Path: data Pkg
+ BuildEnv.Path: data PkgDb
+ BuildEnv.Path: data Prefix
+ BuildEnv.Path: data Project
+ BuildEnv.Path: data Tmp
+ BuildEnv.Path: getAbsolutePath :: AbsolutePath to -> FilePath
+ BuildEnv.Path: getSymbolicPath :: SymbolicPathX allowAbsolute from to -> FilePath
+ BuildEnv.Path: infixr 5 </>
+ BuildEnv.Path: infixr 7 <.>
+ BuildEnv.Path: instance (b1 GHC.Types.~ 'BuildEnv.Path.Dir b2, a3 GHC.Types.~ a1, c2 GHC.Types.~ c3) => BuildEnv.Path.PathLike (BuildEnv.Path.SymbolicPathX allowAbsolute a1 b1) (BuildEnv.Path.SymbolicPathX midAbsolute b2 c2) (BuildEnv.Path.SymbolicPathX allowAbsolute a3 c3)
+ BuildEnv.Path: instance (b1 GHC.Types.~ 'BuildEnv.Path.Dir b2, c2 GHC.Types.~ c3, midAbsolute GHC.Types.~ 'BuildEnv.Path.OnlyRelative) => BuildEnv.Path.PathLike (BuildEnv.Path.AbsolutePath b1) (BuildEnv.Path.SymbolicPathX midAbsolute b2 c2) (BuildEnv.Path.AbsolutePath c3)
+ BuildEnv.Path: instance (p GHC.Types.~ 'BuildEnv.Path.File) => BuildEnv.Path.FileLike (BuildEnv.Path.AbsolutePath p)
+ BuildEnv.Path: instance (p GHC.Types.~ 'BuildEnv.Path.File) => BuildEnv.Path.FileLike (BuildEnv.Path.SymbolicPathX allowAbsolute dir p)
+ BuildEnv.Path: instance (q GHC.Types.~ GHC.IO.FilePath) => BuildEnv.Path.PathLike GHC.IO.FilePath q GHC.IO.FilePath
+ BuildEnv.Path: instance BuildEnv.Path.FileLike GHC.IO.FilePath
+ BuildEnv.Path: instance GHC.Show.Show (BuildEnv.Path.AbsolutePath to)
+ BuildEnv.Path: instance GHC.Show.Show (BuildEnv.Path.SymbolicPathX allowAbsolute from to)
+ BuildEnv.Path: interpretSymbolicPath :: SymbolicPath CWD (Dir dir) -> SymbolicPathX allowAbsolute dir to -> FilePath
+ BuildEnv.Path: makeAbsolute :: SymbolicPath CWD (Dir dir) -> SymbolicPath dir to -> IO (AbsolutePath to)
+ BuildEnv.Path: mkAbsolutePath :: FilePath -> AbsolutePath to
+ BuildEnv.Path: mkRelativePath :: FilePath -> RelativePath from to
+ BuildEnv.Path: mkSymbolicPath :: FilePath -> SymbolicPath from to
+ BuildEnv.Path: sameDirectory :: SymbolicPathX allowAbsolute from to
+ BuildEnv.Path: type RelativePath = SymbolicPathX 'OnlyRelative
+ BuildEnv.Path: type SymbolicPath = SymbolicPathX 'AllowAbsolute
+ BuildEnv.Script: [scriptWorkingDir] :: ScriptConfig -> !SymbolicPath CWD (Dir Project)
+ BuildEnv.Utils: [absProgPath] :: ProgPath from -> !AbsolutePath File
+ BuildEnv.Utils: [relProgPath] :: ProgPath from -> !SymbolicPath from File
+ BuildEnv.Utils: withNewAbstractSem :: AsyncSem -> (AbstractSem -> Args -> IO r) -> IO r
- BuildEnv.Build: buildPlan :: Verbosity -> FilePath -> Paths ForPrep -> Paths ForBuild -> BuildStrategy -> Bool -> Maybe [UnitId] -> (ConfiguredUnit -> UnitArgs) -> CabalPlan -> IO ()
+ BuildEnv.Build: buildPlan :: Verbosity -> SymbolicPath CWD (Dir Project) -> Paths ForPrep -> Paths ForBuild -> Maybe (SymbolicPath Project (Dir Logs)) -> BuildStrategy -> Bool -> Maybe [UnitId] -> (ConfiguredUnit -> UnitArgs) -> CabalPlan -> IO ()
- BuildEnv.Build: cabalProjectContentsFromPackages :: FilePath -> UnitSpecs -> PkgSpecs -> AllowNewer -> Text
+ BuildEnv.Build: cabalProjectContentsFromPackages :: SymbolicPath CWD (Dir Project) -> UnitSpecs -> PkgSpecs -> AllowNewer -> Maybe IndexState -> IO Text
- BuildEnv.Build: computePlan :: TempDirPermanence -> Verbosity -> Compiler -> Cabal -> CabalFilesContents -> IO CabalPlanBinary
+ BuildEnv.Build: computePlan :: TempDirPermanence -> Verbosity -> Compiler -> Cabal -> SymbolicPath CWD (Dir Project) -> CabalFilesContents -> IO CabalPlanBinary
- BuildEnv.Build: fetchPlan :: Verbosity -> Cabal -> FilePath -> CabalPlan -> IO ()
+ BuildEnv.Build: fetchPlan :: Verbosity -> Cabal -> SymbolicPath CWD (Dir Project) -> Maybe IndexState -> SymbolicPath Project (Dir Fetch) -> CabalPlan -> IO ()
- BuildEnv.BuildOne: PkgDir :: !String -> !FilePath -> PkgDir use
+ BuildEnv.BuildOne: PkgDir :: !String -> !SymbolicPath Project (Dir Pkg) -> PkgDir use
- BuildEnv.BuildOne: [$sel:pkgDir:PkgDir] :: PkgDir use -> !FilePath
+ BuildEnv.BuildOne: [$sel:pkgDir:PkgDir] :: PkgDir use -> !SymbolicPath Project (Dir Pkg)
- BuildEnv.BuildOne: buildUnit :: Verbosity -> Compiler -> BuildPaths ForBuild -> PkgDbDirs ForBuild -> PkgDir ForBuild -> UnitArgs -> Map UnitId PlanUnit -> ConfiguredUnit -> BuildScript
+ BuildEnv.BuildOne: buildUnit :: Verbosity -> Compiler -> SymbolicPath CWD (Dir Project) -> BuildPaths ForBuild -> PkgDbDir ForBuild -> PkgDir ForBuild -> UnitArgs -> Map UnitId PlanUnit -> ConfiguredUnit -> BuildScript
- BuildEnv.BuildOne: data family PkgDbDirs use
+ BuildEnv.BuildOne: data family PkgDbDir use
- BuildEnv.BuildOne: getPkgDir :: FilePath -> Paths use -> ConfiguredUnit -> PkgDir use
+ BuildEnv.BuildOne: getPkgDir :: Paths use -> ConfiguredUnit -> PkgDir use
- BuildEnv.BuildOne: setupPackage :: Verbosity -> Compiler -> BuildPaths ForBuild -> PkgDbDirs ForBuild -> PkgDir ForPrep -> PkgDir ForBuild -> Map UnitId PlanUnit -> ConfiguredUnit -> IO BuildScript
+ BuildEnv.BuildOne: setupPackage :: Verbosity -> Compiler -> SymbolicPath CWD (Dir Project) -> BuildPaths ForBuild -> PkgDbDir ForBuild -> PkgDir ForPrep -> PkgDir ForBuild -> Map UnitId PlanUnit -> ConfiguredUnit -> IO BuildScript
- BuildEnv.CabalPlan: Local :: !FilePath -> PkgSrc
+ BuildEnv.CabalPlan: Local :: !SymbolicPath Project (Dir Pkg) -> PkgSrc
- BuildEnv.Config: Cabal :: !FilePath -> !Args -> Cabal
+ BuildEnv.Config: Cabal :: !AbsolutePath File -> !Args -> Cabal
- BuildEnv.Config: Compiler :: !FilePath -> !FilePath -> Compiler
+ BuildEnv.Config: Compiler :: !AbsolutePath File -> !AbsolutePath File -> Compiler
- BuildEnv.Config: Paths :: !FilePath -> BuildPaths use -> Paths use
+ BuildEnv.Config: Paths :: !SymbolicPath Project (Dir Fetch) -> BuildPaths use -> Paths use
- BuildEnv.Config: Script :: !FilePath -> !Bool -> BuildStrategy
+ BuildEnv.Config: Script :: !SymbolicPath CWD File -> !Bool -> BuildStrategy
- BuildEnv.Config: [$sel:cabalPath:Cabal] :: Cabal -> !FilePath
+ BuildEnv.Config: [$sel:cabalPath:Cabal] :: Cabal -> !AbsolutePath File
- BuildEnv.Config: [$sel:fetchDir:Paths] :: Paths use -> !FilePath
+ BuildEnv.Config: [$sel:fetchDir:Paths] :: Paths use -> !SymbolicPath Project (Dir Fetch)
- BuildEnv.Config: [$sel:ghcPath:Compiler] :: Compiler -> !FilePath
+ BuildEnv.Config: [$sel:ghcPath:Compiler] :: Compiler -> !AbsolutePath File
- BuildEnv.Config: [$sel:ghcPkgPath:Compiler] :: Compiler -> !FilePath
+ BuildEnv.Config: [$sel:ghcPkgPath:Compiler] :: Compiler -> !AbsolutePath File
- BuildEnv.Config: [$sel:scriptPath:Execute] :: BuildStrategy -> !FilePath
+ BuildEnv.Config: [$sel:scriptPath:Execute] :: BuildStrategy -> !SymbolicPath CWD File
- BuildEnv.Config: canonicalizePaths :: Compiler -> BuildStrategy -> Paths Raw -> IO (Paths ForPrep, Paths ForBuild)
+ BuildEnv.Config: canonicalizePaths :: Compiler -> BuildStrategy -> SymbolicPath CWD (Dir Project) -> Paths Raw -> IO (Paths ForPrep, Paths ForBuild)
- BuildEnv.Script: CallProcess :: CallProcess -> BuildStep
+ BuildEnv.Script: CallProcess :: CallProcess dir -> BuildStep
- BuildEnv.Script: CreateDir :: FilePath -> BuildStep
+ BuildEnv.Script: CreateDir :: AbsolutePath (Dir dir) -> BuildStep
- BuildEnv.Script: ScriptConfig :: !ScriptOutput -> !Style -> !Maybe Word -> ScriptConfig
+ BuildEnv.Script: ScriptConfig :: !ScriptOutput -> !SymbolicPath CWD (Dir Project) -> !Style -> !Maybe Word -> ScriptConfig
- BuildEnv.Script: callProcess :: CallProcess -> BuildScript
+ BuildEnv.Script: callProcess :: CallProcess dir -> BuildScript
- BuildEnv.Script: createDir :: FilePath -> BuildScript
+ BuildEnv.Script: createDir :: AbsolutePath (Dir dir) -> BuildScript
- BuildEnv.Script: executeBuildScript :: Maybe Counter -> BuildScript -> IO ()
+ BuildEnv.Script: executeBuildScript :: SymbolicPath CWD (Dir Project) -> Maybe Counter -> BuildScript -> IO ()
- BuildEnv.Script: hostRunCfg :: Maybe Word -> ScriptConfig
+ BuildEnv.Script: hostRunCfg :: SymbolicPath CWD (Dir Project) -> Maybe Word -> ScriptConfig
- BuildEnv.Utils: AbsPath :: !FilePath -> ProgPath
+ BuildEnv.Utils: AbsPath :: !AbsolutePath File -> ProgPath from
- BuildEnv.Utils: CP :: !FilePath -> ![FilePath] -> ![(String, String)] -> !ProgPath -> !Args -> !Maybe FilePath -> !AbstractSem -> CallProcess
+ BuildEnv.Utils: CP :: !SymbolicPath CWD (Dir dir) -> ![FilePath] -> ![(String, String)] -> !ProgPath dir -> !Args -> !Maybe (AbsolutePath File) -> !AbstractSem -> CallProcess dir
- BuildEnv.Utils: RelPath :: !FilePath -> ProgPath
+ BuildEnv.Utils: RelPath :: !SymbolicPath from File -> ProgPath from
- BuildEnv.Utils: [args] :: CallProcess -> !Args
+ BuildEnv.Utils: [args] :: CallProcess dir -> !Args
- BuildEnv.Utils: [cwd] :: CallProcess -> !FilePath
+ BuildEnv.Utils: [cwd] :: CallProcess dir -> !SymbolicPath CWD (Dir dir)
- BuildEnv.Utils: [extraEnvVars] :: CallProcess -> ![(String, String)]
+ BuildEnv.Utils: [extraEnvVars] :: CallProcess dir -> ![(String, String)]
- BuildEnv.Utils: [extraPATH] :: CallProcess -> ![FilePath]
+ BuildEnv.Utils: [extraPATH] :: CallProcess dir -> ![FilePath]
- BuildEnv.Utils: [logBasePath] :: CallProcess -> !Maybe FilePath
+ BuildEnv.Utils: [logBasePath] :: CallProcess dir -> !Maybe (AbsolutePath File)
- BuildEnv.Utils: [prog] :: CallProcess -> !ProgPath
+ BuildEnv.Utils: [prog] :: CallProcess dir -> !ProgPath dir
- BuildEnv.Utils: [sem] :: CallProcess -> !AbstractSem
+ BuildEnv.Utils: [sem] :: CallProcess dir -> !AbstractSem
- BuildEnv.Utils: callProcessInIO :: HasCallStack => Maybe Counter -> CallProcess -> IO ()
+ BuildEnv.Utils: callProcessInIO :: HasCallStack => Maybe Counter -> CallProcess dir -> IO ()
- BuildEnv.Utils: data CallProcess
+ BuildEnv.Utils: data CallProcess dir
- BuildEnv.Utils: data ProgPath
+ BuildEnv.Utils: data ProgPath from
- BuildEnv.Utils: withTempDir :: TempDirPermanence -> String -> (FilePath -> IO a) -> IO a
+ BuildEnv.Utils: withTempDir :: TempDirPermanence -> String -> (AbsolutePath (Dir Tmp) -> IO a) -> IO a
Files
- app/BuildEnv/Options.hs +41/−28
- app/BuildEnv/Parse.hs +150/−74
- app/Main.hs +114/−94
- build-env.cabal +11/−8
- changelog.md +14/−1
- readme.md +18/−2
- src/BuildEnv/Build.hs +199/−155
- src/BuildEnv/BuildOne.hs +140/−160
- src/BuildEnv/CabalPlan.hs +13/−5
- src/BuildEnv/Config.hs +68/−47
- src/BuildEnv/File.hs +2/−3
- src/BuildEnv/Path.hs +212/−0
- src/BuildEnv/Script.hs +47/−32
- src/BuildEnv/Utils.hs +86/−39
app/BuildEnv/Options.hs view
@@ -15,17 +15,26 @@ -- build-env import BuildEnv.CabalPlan import BuildEnv.Config +import BuildEnv.Path -------------------------------------------------------------------------------- -- | The command-line options for the @build-env@ application. -data Opts = Opts { compiler :: Compiler - , cabal :: Cabal - , mode :: Mode - , verbosity :: Verbosity - , delTemp :: TempDirPermanence - , workDir :: FilePath - } +data GlobalOpts = + GlobalOpts + { compiler :: !Compiler + -- ^ The compiler to use to build packages + , cabal :: !Cabal + -- ^ The @cabal-install@ executable to use for computing and fetching build plans + , verbosity :: !Verbosity + -- ^ Verbosity + , delTemp :: !TempDirPermanence + -- ^ Whether to preserve temporary directories (for debugging purposes) + , workDir :: !( SymbolicPath CWD ( Dir Project ) ) + -- ^ Working directory + , indexState :: !( Maybe IndexState ) + -- ^ Hackage index state (optional) + } -- | The mode in which to run the executable: -- @@ -35,22 +44,22 @@ data Mode -- | Find a build plan. = PlanMode - { planModeInputs :: PlanInputs - , planOutput :: FilePath + { planModeInputs :: !PlanInputs + , planOutput :: !( SymbolicPath Project File ) -- ^ Where to output the @plan.json@ file. } -- | Fetch sources from a build plan. | FetchMode - FetchDescription -- ^ what to fetch - NewOrExisting -- ^ whether to create a new directory + !FetchDescription -- ^ what to fetch + !NewOrExisting -- ^ whether to create a new directory -- or add to an existing one -- | Build and register packages from fetched sources. - | BuildMode Build + | BuildMode !Build -- | How to specify which packages/units to constraint/build. data PackageData pkgs -- | Explicit description of packages/units. - = Explicit pkgs + = Explicit !pkgs -- | Parse package information from the given file. -- -- The file contents will be interpreted as follows: @@ -61,17 +70,17 @@ -- - seed units: this is a list of seed units to build, -- with inline flags and constraints, and allow-newer stanzas. -- See 'parseSeedFile'. - | FromFile FilePath + | FromFile !( SymbolicPath Project File ) deriving stock Show -- | Inputs for the computation of a cabal plan. data PlanInputs = PlanInputs - { planUnits :: PackageData UnitSpecs + { planUnits :: !( PackageData UnitSpecs ) -- ^ Seed dependencies for the build plan. - , planPins :: Maybe (PackageData PkgSpecs) + , planPins :: !( Maybe ( PackageData PkgSpecs ) ) -- ^ Additional package constraints. - , planAllowNewer :: AllowNewer + , planAllowNewer :: !AllowNewer -- ^ Allow-newer specification. } deriving stock Show @@ -80,9 +89,9 @@ -- and what build plan they correspond to. data FetchDescription = FetchDescription - { rawFetchDir :: FilePath + { fetchDir :: !( SymbolicPath Project ( Dir Fetch ) ) -- ^ Directory for fetched sources. - , fetchInputPlan :: Plan + , fetchInputPlan :: !Plan -- ^ The build plan corresponding to the fetched sources. } deriving stock Show @@ -92,20 +101,20 @@ data Plan -- | Compute a plan. = ComputePlan - PlanInputs + !PlanInputs -- ^ Input needed to compute the plan. - (Maybe FilePath) + !( Maybe ( SymbolicPath Project File ) ) -- ^ Optional filepath at which to write out the computed plan. -- | Use an existing @plan.json@ by reading the given file. | UsePlan - { planJSONPath :: FilePath } + { planJSONPath :: !( SymbolicPath Project File ) } deriving stock Show -- | At which point to start/continue a build. data BuildStart -- | Fetch sources and start a new build. - = Fetch NewOrExisting + = Fetch !NewOrExisting -- | Start a new build from prefetched sources. | Prefetched -- | Resume a previous build. @@ -123,20 +132,24 @@ -- | Information needed to perform a build. data Build = Build - { buildRawPaths :: Paths Raw + { buildRawPaths :: !( Paths Raw ) -- ^ The directories relevant for the build: -- -- - fetched sources directory, -- - build output directory structure - , buildStart :: BuildStart + , buildStart :: !BuildStart -- ^ At which stage should the build start? - , buildBuildPlan :: Plan + , buildBuildPlan :: !Plan -- ^ The build plan to follow. - , buildStrategy :: BuildStrategy + , buildStrategy :: !BuildStrategy -- ^ How to perform the build (see 'BuildStrategy'). - , mbOnlyDepsOf :: Maybe ( Set PkgName ) + , mbOnlyDepsOf :: !( Maybe ( Set PkgName ) ) -- ^ @Just pkgs@ <=> only build @pkgs@ (and their dependencies). -- @Nothing@ <=> build all units in the build plan. + , eventLogDir :: !( Maybe ( SymbolicPath Project ( Dir Logs ) ) ) + -- ^ Optional output directory in which to output GHC eventlogs + -- for the build. , userUnitArgs :: ConfiguredUnit -> UnitArgs -- ^ Extra per-unit arguments. } +
app/BuildEnv/Parse.hs view
@@ -11,12 +11,18 @@ module BuildEnv.Parse ( options, runOptionsParser ) where -- base +import Control.Concurrent + ( getNumCapabilities ) import Data.Char ( isSpace ) import Data.Bool ( bool ) +import Data.Word + ( Word16 ) import System.Environment ( getArgs ) +import Text.Read + ( readMaybe ) -- containers import qualified Data.Map.Strict as Map @@ -28,6 +34,8 @@ -- optparse-applicative import Options.Applicative +import Options.Applicative.Help.Pretty + ( (.$.) ) -- text import Data.Text @@ -39,21 +47,24 @@ import BuildEnv.CabalPlan import BuildEnv.Config import BuildEnv.Options +import BuildEnv.Path import BuildEnv.Utils ( splitOn ) -------------------------------------------------------------------------------- -- | Run the command-line options parser. -runOptionsParser :: FilePath -> IO Opts -runOptionsParser currWorkDir = do +runOptionsParser :: IO ( GlobalOpts, Mode ) +runOptionsParser = do args <- getArgs - handleParseResult $ execParserPure pPrefs pInfo args - where + caps <- NumCapabilities . fromIntegral <$> getNumCapabilities + let pInfo = - info ( helper <*> options currWorkDir ) + info ( helper <*> options caps ) ( fullDesc <> header "build-env - compute, fetch and build Cabal build plans" ) + handleParseResult $ execParserPure pPrefs pInfo args + where pPrefs = prefs $ mconcat [ showHelpOnEmpty , subparserInline @@ -61,30 +72,45 @@ , multiSuffix "*" , columns 90 ] +newtype NumCapabilities = NumCapabilities { numCapabilities :: Word16 } + deriving stock ( Show, Eq, Ord ) + -- | The command-line options parser for the 'build-env' executable. -options :: FilePath -> Parser Opts -options currWorkDir = do - mode <- optMode - compiler <- optCompiler - cabal <- optCabal - workDir <- optChangeWorkingDirectory currWorkDir - verbosity <- optVerbosity - delTemp <- optTempDirPermanence - pure $ Opts { compiler, cabal, mode, verbosity, delTemp, workDir } +options :: NumCapabilities -> Parser ( GlobalOpts, Mode ) +options caps = do + mode <- optMode caps + globalOpts <- optGlobalOpts + pure ( globalOpts, mode ) +-- | Parse global options for 'build-env'. +optGlobalOpts :: Parser GlobalOpts +optGlobalOpts = do + compiler <- optCompiler + cabal <- optCabal + workDir <- optChangeWorkingDirectory + verbosity <- optVerbosity + indexState <- optIndexState + delTemp <- optTempDirPermanence + pure $ + GlobalOpts + { compiler, cabal + , verbosity, delTemp + , workDir, indexState + } + -- | Parse @ghc@ and @ghc-pkg@ paths. optCompiler :: Parser Compiler optCompiler = Compiler - <$> option str + <$> option ( fmap mkAbsolutePath str ) ( long "ghc" - <> value "ghc" + <> value ( mkAbsolutePath "ghc" ) <> help "'ghc' executable path" <> metavar "GHC" ) - <*> option str + <*> option ( fmap mkAbsolutePath str ) ( long "ghc-pkg" - <> value "ghc-pkg" + <> value ( mkAbsolutePath "ghc-pkg" ) <> help "'ghc-pkg' executable path" <> metavar "GHC-PKG" ) @@ -93,9 +119,9 @@ optCabal :: Parser Cabal optCabal = do cabalPath <- - option str + option ( fmap mkAbsolutePath str ) ( long "cabal" - <> value "cabal" + <> value ( mkAbsolutePath "cabal" ) <> help "'cabal' executable path" <> metavar "CABAL" ) globalCabalArgs <- @@ -105,11 +131,11 @@ pure $ Cabal { cabalPath, globalCabalArgs } -- | Parse a @cwd@ (change working directory) option. -optChangeWorkingDirectory :: FilePath -> Parser FilePath -optChangeWorkingDirectory currWorkDir = - option str +optChangeWorkingDirectory :: Parser ( SymbolicPath CWD ( Dir Project ) ) +optChangeWorkingDirectory = + option ( fmap mkSymbolicPath str ) ( long "cwd" - <> value currWorkDir + <> value sameDirectory <> help "Set working directory" <> metavar "DIR" ) @@ -131,9 +157,17 @@ switch ( long "preserve-tmp" <> help "Preserve temporary build directories (useful for debugging)" ) +-- | Parse a Hackage index state. +optIndexState :: Parser ( Maybe IndexState ) +optIndexState = + optional $ fmap ( IndexState . Text.pack ) $ + option str ( long "index-state" <> help helpStr <> metavar "DATE" ) + where + helpStr = "Use Hackage state as of DATE, e.g. 2022-12-25T00:00:00Z" + -- | Parse the mode in which to run the application: plan, fetch, build. -optMode :: Parser Mode -optMode = +optMode :: NumCapabilities -> Parser Mode +optMode caps = hsubparser . mconcat $ [ command "plan" $ info ( PlanMode <$> planInputs Planning <*> optOutput ) @@ -142,17 +176,18 @@ info ( FetchMode <$> fetchDescription <*> newOrExisting ) ( fullDesc <> fetchInfo ) , command "build" $ - info ( BuildMode <$> build ) + info ( BuildMode <$> build caps ) ( fullDesc <> buildInfo ) ] where - optOutput :: Parser FilePath + optOutput :: Parser ( SymbolicPath Project File ) optOutput = - option str ( short 'p' - <> long "plan" - <> help "Output 'plan.json' file" - <> metavar "OUTFILE" - ) + option ( fmap mkSymbolicPath str ) + ( short 'p' + <> long "plan" + <> help "Output 'plan.json' file" + <> metavar "OUTFILE" + ) planInfo, fetchInfo, buildInfo :: InfoMod a planInfo = progDesc "Compute a build plan from a collection of seeds" fetchInfo = progDesc "Fetch package sources" @@ -191,8 +226,9 @@ freeze :: ModeDescription -> Parser ( PackageData PkgSpecs ) freeze modeDesc = FromFile <$> freezeFile where - freezeFile :: Parser FilePath - freezeFile = option str ( long "freeze" <> help helpStr <> metavar "INFILE" ) + freezeFile :: Parser ( SymbolicPath Project File ) + freezeFile = option ( fmap mkSymbolicPath str ) + ( long "freeze" <> help helpStr <> metavar "INFILE" ) helpStr :: String helpStr = modeDescription modeDesc <> " 'cabal.config' freeze file" @@ -238,8 +274,9 @@ where - seeds :: Parser FilePath - seeds = option str ( long "seeds" <> help seedsHelp <> metavar "INFILE" ) + seeds :: Parser ( SymbolicPath Project File ) + seeds = option ( fmap mkSymbolicPath str ) + ( long "seeds" <> help seedsHelp <> metavar "INFILE" ) explicitUnits :: Parser ( PackageData UnitSpecs ) explicitUnits = do @@ -252,20 +289,20 @@ [ (pkg, (Local loc, emptyPkgSpec, mempty)) | (pkg, loc) <- locals ] - localPkg :: Parser (PkgName, FilePath) + localPkg :: Parser ( PkgName, SymbolicPath Project ( Dir Pkg ) ) localPkg = option readLocalPkg ( long "local" <> help "Local package source location" <> metavar "PKG=PATH" ) - readLocalPkg :: ReadM (PkgName, FilePath) + readLocalPkg :: ReadM ( PkgName, SymbolicPath Project ( Dir Pkg ) ) readLocalPkg = do ln <- str case Text.splitOn "=" ln of pkg:loc:_ | validPackageName pkg - -> return (PkgName pkg, Text.unpack loc) + -> return ( PkgName pkg, mkSymbolicPath $ Text.unpack loc ) _ -> readerError $ "Could not parse --local argument\n" ++ "Valid usage is of the form: --local PKG=PATH" @@ -292,17 +329,17 @@ <|> ( ComputePlan <$> planInputs modeDesc <*> optPlanOutput ) where - optPlanPath :: Parser FilePath + optPlanPath :: Parser ( SymbolicPath Project File ) optPlanPath = - option str + option ( fmap mkSymbolicPath str ) ( short 'p' <> long "plan" <> help "Input 'plan.json' file" <> metavar "INFILE" ) - optPlanOutput :: Parser (Maybe FilePath) + optPlanOutput :: Parser ( Maybe ( SymbolicPath Project File ) ) optPlanOutput = - option (fmap Just str) + option ( fmap ( Just . mkSymbolicPath ) str ) ( long "output-plan" <> value Nothing <> help "Output 'plan.json' file" @@ -313,13 +350,13 @@ fetchDescription :: Parser FetchDescription fetchDescription = do fetchInputPlan <- plan Fetching - rawFetchDir <- optFetchDir Fetching - pure $ FetchDescription { rawFetchDir, fetchInputPlan } + fetchDir <- optFetchDir Fetching + pure $ FetchDescription { fetchDir, fetchInputPlan } -- | Parse the fetch directory. -optFetchDir :: ModeDescription -> Parser FilePath +optFetchDir :: ModeDescription -> Parser ( SymbolicPath Project ( Dir Fetch ) ) optFetchDir modeDesc = - option str + option ( fmap mkSymbolicPath str ) ( short 'f' <> long "fetchdir" <> help "Directory for fetched sources" @@ -338,23 +375,24 @@ <> help "Update existing fetched sources directory" ) -- | Parse the options for the @build@ command. -build :: Parser Build -build = do - - buildBuildPlan <- plan Building - buildStart <- optStart - buildStrategy <- optStrategy - buildRawPaths <- optRawPaths - userUnitArgs <- optUnitArgs - mbOnlyDepsOf <- optOnlyDepsOf +build :: NumCapabilities -> Parser Build +build ( NumCapabilities numCaps ) = do + buildBuildPlan <- plan Building + buildStart <- optStart + buildStrategy <- optStrategy + buildRawPaths <- optRawPaths + userUnitArgs <- optUnitArgs + mbOnlyDepsOf <- optOnlyDepsOf + eventLogDir <- optEventLogDir pure $ Build { buildStart , buildBuildPlan , buildStrategy , buildRawPaths , userUnitArgs - , mbOnlyDepsOf } + , mbOnlyDepsOf + , eventLogDir } where @@ -366,12 +404,39 @@ asyncSem :: Parser AsyncSem asyncSem = - option (fmap NewQSem auto <|> pure NoSem) + option jsem + ( long "jsem" + <> help "Use a system semaphore to control parallelism" + <> metavar "[N|SEM_NAME]" ) + <|> + option ( fmap NewQSem j ) ( short 'j' - <> long "async" <> help "Use asynchronous package building" - <> metavar "N" ) + <> metavar "[N]" ) + j :: ReadM Word16 + j = do + x <- str + if null x + then return numCaps + else + case readMaybe x of + Just n -> return n + Nothing -> + readerError $ + "Invalid -j argument: " <> x + + jsem :: ReadM AsyncSem + jsem = do + x <- str + return $ + if null x + then NewJSem numCaps + else + case readMaybe x of + Just n -> NewJSem n + Nothing -> ExistingJSem x + optScript :: Parser BuildStrategy optScript = do scriptPath <- optScriptPath @@ -381,11 +446,12 @@ <> help "Use variables in the shell script output ($PREFIX etc)" ) pure $ Script { scriptPath, useVariables } - optScriptPath :: Parser FilePath + optScriptPath :: Parser ( SymbolicPath CWD File ) optScriptPath = - option str + option ( fmap mkSymbolicPath str ) ( long "script" - <> help "Output a shell script containing build steps" + <> helpDoc ( Just $ "Output a shell script containing build steps" + .$. " NB: path is interpreted relative to current work dir, NOT --cwd" ) <> metavar "OUTFILE" ) optStart :: Parser BuildStart @@ -404,7 +470,7 @@ ( long "prefetched" <> help "Start the build from the prefetched sources" ) - optRawPaths :: Parser (Paths Raw) + optRawPaths :: Parser ( Paths Raw ) optRawPaths = do fetchDir <- optFetchDir Building buildPaths <- optBuildPaths @@ -413,15 +479,17 @@ optBuildPaths :: Parser (BuildPaths Raw) optBuildPaths = do rawPrefix <- - option str ( short 'o' - <> long "prefix" - <> help "Installation prefix" - <> metavar "OUTDIR" ) + option ( fmap mkSymbolicPath str ) + ( short 'o' + <> long "prefix" + <> help "Installation prefix" + <> metavar "OUTDIR" ) rawDestDir <- - option str ( long "destdir" - <> help "Installation destination directory" - <> value "/" - <> metavar "OUTDIR" ) + option ( fmap mkSymbolicPath str ) + ( long "destdir" + <> help "Installation destination directory" + <> value ( mkSymbolicPath "/" ) + <> metavar "OUTDIR" ) pure $ RawBuildPaths { rawPrefix, rawDestDir } -- TODO: we only support passing arguments for all units at once, @@ -447,7 +515,7 @@ optHaddockArgs = do doHaddock <- switch ( long "haddock" - <> help "Generate haddock documentation" ) + <> help "Generate Haddock documentation" ) args <- many $ option str ( long "haddock-arg" <> help "Pass argument to 'Setup haddock'" @@ -484,3 +552,11 @@ then return $ PkgName nm else readerError $ "Invalid package name: " <> Text.unpack nm + + optEventLogDir :: Parser ( Maybe ( SymbolicPath Project ( Dir Logs ) ) ) + optEventLogDir = do + option ( fmap ( Just . mkSymbolicPath ) str ) + ( long "eventlogs" + <> help "Directory for GHC event logs" + <> value Nothing + <> metavar "OUTDIR" )
app/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DataKinds #-} + module Main ( main ) where -- base @@ -34,54 +36,59 @@ import BuildEnv.Options import BuildEnv.Parse ( runOptionsParser ) +import BuildEnv.Path -------------------------------------------------------------------------------- main :: IO () main = do - currentDir <- getCurrentDirectory - Opts { compiler, cabal, mode, verbosity, delTemp, workDir } - <- runOptionsParser currentDir + ( GlobalOpts + { compiler, cabal + , verbosity, delTemp, workDir + , indexState = mbIndexState } + , mode ) + <- runOptionsParser hSetBuffering stdout $ BlockBuffering Nothing - withCurrentDirectory workDir $ - case mode of - PlanMode { planModeInputs, planOutput } -> do - CabalPlanBinary planBinary <- - computePlanFromInputs delTemp verbosity workDir compiler cabal planModeInputs - normalMsg verbosity $ - "Writing build plan to '" <> Text.pack planOutput <> "'" - Lazy.ByteString.writeFile planOutput planBinary - FetchMode ( FetchDescription { rawFetchDir, fetchInputPlan } ) newOrUpd -> do - plan <- getPlan delTemp verbosity workDir compiler cabal fetchInputPlan - fetchDir <- canonicalizePath rawFetchDir - doFetch verbosity cabal fetchDir True newOrUpd plan - BuildMode ( Build { buildBuildPlan - , buildStart - , buildStrategy - , buildRawPaths = rawPaths - , mbOnlyDepsOf - , userUnitArgs } ) -> do - plan <- getPlan delTemp verbosity workDir compiler cabal buildBuildPlan - ( pathsForPrep@( Paths { fetchDir }), pathsForBuild ) - <- canonicalizePaths compiler buildStrategy rawPaths - case buildStart of - Fetch newOrUpd -> doFetch verbosity cabal fetchDir False newOrUpd plan - _ -> return () - let mbOnlyDepsOfUnits :: Maybe [UnitId] - mbOnlyDepsOfUnits = - case mbOnlyDepsOf of - Nothing -> Nothing - Just pkgs -> - let wantUnit :: PlanUnit -> Maybe UnitId - wantUnit pu = do - ConfiguredUnit { puPkgName, puId } <- configuredUnitMaybe pu - guard ( puPkgName `Set.member` pkgs ) - return puId - in Just $ mapMaybePlanUnits wantUnit plan + case mode of + PlanMode { planModeInputs, planOutput } -> do + CabalPlanBinary planBinary <- + computePlanFromInputs + delTemp verbosity workDir compiler cabal + mbIndexState planModeInputs + normalMsg verbosity $ + "Writing build plan to" <> Text.pack ( show planOutput ) + Lazy.ByteString.writeFile ( interpretSymbolicPath workDir planOutput ) planBinary + FetchMode ( FetchDescription { fetchDir, fetchInputPlan } ) newOrUpd -> do + plan <- getPlan delTemp verbosity workDir compiler cabal mbIndexState fetchInputPlan + doFetch verbosity cabal workDir fetchDir mbIndexState True newOrUpd plan + BuildMode ( Build { buildBuildPlan + , buildStart + , buildStrategy + , buildRawPaths = rawPaths + , mbOnlyDepsOf + , eventLogDir + , userUnitArgs } ) -> do + plan <- getPlan delTemp verbosity workDir compiler cabal mbIndexState buildBuildPlan + ( pathsForPrep@( Paths { fetchDir }), pathsForBuild ) + <- canonicalizePaths compiler buildStrategy workDir rawPaths + case buildStart of + Fetch newOrUpd -> doFetch verbosity cabal workDir fetchDir mbIndexState False newOrUpd plan + _ -> return () + let mbOnlyDepsOfUnits :: Maybe [UnitId] + mbOnlyDepsOfUnits = + case mbOnlyDepsOf of + Nothing -> Nothing + Just pkgs -> + let wantUnit :: PlanUnit -> Maybe UnitId + wantUnit pu = do + ConfiguredUnit { puPkgName, puId } <- configuredUnitMaybe pu + guard ( puPkgName `Set.member` pkgs ) + return puId + in Just $ mapMaybePlanUnits wantUnit plan - let resumeBuild = case buildStart of { Resume -> True; _ -> False } - buildPlan verbosity workDir pathsForPrep pathsForBuild - buildStrategy resumeBuild mbOnlyDepsOfUnits userUnitArgs plan + let resumeBuild = case buildStart of { Resume -> True; _ -> False } + buildPlan verbosity workDir pathsForPrep pathsForBuild eventLogDir + buildStrategy resumeBuild mbOnlyDepsOfUnits userUnitArgs plan -- | Generate the contents of @pkg.cabal@ and @cabal.project@ files, using -- @@ -89,94 +96,107 @@ -- and allow-newer), -- - a @cabal.config@ freeze file, -- - explicit packages and allow-newer specified as command-line arguments. -parsePlanInputs :: Verbosity -> FilePath -> PlanInputs -> IO CabalFilesContents -parsePlanInputs verbosity workDir (PlanInputs { planPins, planUnits, planAllowNewer }) - = do (pkgs, fileAllowNewer) <- parsePlanUnits verbosity planUnits - let - allAllowNewer = fileAllowNewer <> planAllowNewer - -- NB: allow-newer specified in the command-line overrides - -- the allow-newer included in the seed file. - cabalContents = cabalFileContentsFromPackages pkgs - projectContents <- - case planPins of - Nothing -> return $ cabalProjectContentsFromPackages workDir pkgs Map.empty allAllowNewer - Just (FromFile pinCabalConfig) -> do - normalMsg verbosity $ - "Reading 'cabal.config' file at '" <> Text.pack pinCabalConfig <> "'" - pins <- parseCabalDotConfigPkgs pinCabalConfig - return $ cabalProjectContentsFromPackages workDir pkgs pins allAllowNewer - Just (Explicit pins) -> do - return $ cabalProjectContentsFromPackages workDir pkgs pins allAllowNewer - return $ CabalFilesContents { cabalContents, projectContents } +parsePlanInputs :: Verbosity + -> SymbolicPath CWD ( Dir Project ) + -> Maybe IndexState -> PlanInputs -> IO CabalFilesContents +parsePlanInputs verbosity workDir mbIndexState + ( PlanInputs { planPins, planUnits, planAllowNewer } ) + = do + ( pkgs, fileAllowNewer ) <- parsePlanUnits verbosity workDir planUnits + let + allAllowNewer = fileAllowNewer <> planAllowNewer + -- NB: allow-newer specified in the command-line overrides + -- the allow-newer included in the seed file. + cabalContents = cabalFileContentsFromPackages pkgs + pins <- + case planPins of + Nothing -> return Map.empty + Just ( FromFile pinCabalConfig ) -> do + normalMsg verbosity $ + "Reading 'cabal.config' file at " <> Text.pack ( show pinCabalConfig ) + pins <- parseCabalDotConfigPkgs ( interpretSymbolicPath workDir pinCabalConfig ) + return pins + Just ( Explicit pins ) -> do + return pins + projectContents <- + cabalProjectContentsFromPackages workDir pkgs pins allAllowNewer mbIndexState + return $ CabalFilesContents { cabalContents, projectContents } -- | Retrieve the seed units we want to build, either from a seed file -- or from explicit command line arguments. -parsePlanUnits :: Verbosity -> PackageData UnitSpecs -> IO (UnitSpecs, AllowNewer) -parsePlanUnits _ (Explicit units) = return (units, AllowNewer Set.empty) -parsePlanUnits verbosity (FromFile fp) = - do normalMsg verbosity $ - "Reading seed packages from '" <> Text.pack fp <> "'" - parseSeedFile fp +parsePlanUnits :: Verbosity + -> SymbolicPath CWD ( Dir Project ) + -> PackageData UnitSpecs -> IO ( UnitSpecs, AllowNewer ) +parsePlanUnits _ _ ( Explicit units ) = return (units, AllowNewer Set.empty) +parsePlanUnits verbosity workDir ( FromFile fp ) = do + normalMsg verbosity $ + "Reading seed packages from " <> Text.pack ( show fp ) <> "" + parseSeedFile ( interpretSymbolicPath workDir fp ) -- | Compute a build plan by calling @cabal build --dry-run@ with the generated -- @pkg.cabal@ and @cabal.project@ files. computePlanFromInputs :: TempDirPermanence -> Verbosity - -> FilePath + -> SymbolicPath CWD ( Dir Project ) -> Compiler -> Cabal + -> Maybe IndexState -> PlanInputs -> IO CabalPlanBinary -computePlanFromInputs delTemp verbosity workDir comp cabal inputs - = do cabalFileContents <- parsePlanInputs verbosity workDir inputs - normalMsg verbosity "Computing build plan" - computePlan delTemp verbosity comp cabal cabalFileContents +computePlanFromInputs delTemp verbosity workDir comp cabal mbIndexState inputs = do + cabalFileContents <- parsePlanInputs verbosity workDir mbIndexState inputs + normalMsg verbosity "Computing build plan" + computePlan delTemp verbosity comp cabal workDir cabalFileContents -- | Retrieve a cabal build plan, either by computing it or using -- a pre-existing @plan.json@ file. -getPlan :: TempDirPermanence -> Verbosity -> FilePath -> Compiler -> Cabal -> Plan -> IO CabalPlan -getPlan delTemp verbosity workDir comp cabal planMode = do - planBinary <- - case planMode of - ComputePlan planInputs mbPlanOutputPath -> do - plan@(CabalPlanBinary planData) <- - computePlanFromInputs delTemp verbosity workDir comp cabal planInputs +getPlan :: TempDirPermanence -> Verbosity + -> SymbolicPath CWD ( Dir Project ) + -> Compiler -> Cabal -> Maybe IndexState -> Plan -> IO CabalPlan +getPlan delTemp verbosity workDir comp cabal mbIndexState planMode = do + planBinary <- + case planMode of + ComputePlan planInputs mbPlanOutputPath -> do + plan@( CabalPlanBinary planData ) <- + computePlanFromInputs delTemp verbosity workDir comp cabal mbIndexState planInputs for_ mbPlanOutputPath \ planOutputPath -> - Lazy.ByteString.writeFile planOutputPath planData + Lazy.ByteString.writeFile ( interpretSymbolicPath workDir planOutputPath ) planData return plan - UsePlan { planJSONPath } -> - do - normalMsg verbosity $ - "Reading build plan from '" <> Text.pack planJSONPath <> "'" - CabalPlanBinary <$> Lazy.ByteString.readFile planJSONPath - return $ parsePlanBinary planBinary + UsePlan { planJSONPath } -> do + normalMsg verbosity $ + "Reading build plan from " <> Text.pack ( show planJSONPath ) + CabalPlanBinary <$> Lazy.ByteString.readFile ( interpretSymbolicPath workDir planJSONPath ) + return $ parsePlanBinary planBinary -- | Fetch all packages in a cabal build plan. doFetch :: Verbosity -> Cabal - -> FilePath + -> SymbolicPath CWD ( Dir Project ) + -- ^ working directory + -> SymbolicPath Project ( Dir Fetch ) + -- ^ fetch directory + -> Maybe IndexState -> Bool -- ^ True <=> we are fetching (not building) -- (only relevant for error messages) -> NewOrExisting -> CabalPlan -> IO () -doFetch verbosity cabal fetchDir0 weAreFetching newOrUpd plan = do - fetchDir <- canonicalizePath fetchDir0 - fetchDirExists <- doesDirectoryExist fetchDir +doFetch verbosity cabal workDir fetchDir mbIndexState weAreFetching newOrUpd plan = do + fetchDirExists <- doesDirectoryExist $ interpretSymbolicPath workDir fetchDir case newOrUpd of New | fetchDirExists -> error $ unlines $ "Fetch directory already exists." : existsMsg - ++ [ "Fetch directory: " <> fetchDir ] + ++ [ "Fetch directory: " <> show fetchDir ] Existing | not fetchDirExists -> error $ unlines [ "Fetch directory must already exist when using --update." - , "Fetch directory: " <> fetchDir ] + , "Fetch directory: " <> show fetchDir ] _ -> return () - createDirectoryIfMissing True fetchDir + createDirectoryIfMissing True $ interpretSymbolicPath workDir fetchDir normalMsg verbosity $ - "Fetching sources from build plan into directory '" <> Text.pack fetchDir <> "'" - fetchPlan verbosity cabal fetchDir plan + "Fetching sources from build plan into directory " <> Text.pack ( show fetchDir ) + fetchPlan verbosity cabal workDir mbIndexState fetchDir plan where existsMsg
build-env.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: build-env -version: 1.1.0.0 +version: 1.2.0.0 author: Ben Gamari & Sam Derbyshire maintainer: ben@smart-cactus.org license: BSD-3-Clause @@ -27,17 +27,19 @@ build-depends: base - >= 4.15 && < 4.18 + >= 4.15 && < 5.0 , bytestring >= 0.10 && < 0.12 , containers - ^>= 0.6 + >= 0.6 && < 0.8 , directory ^>= 1.3 , filepath - ^>= 1.4 + >= 1.4 && < 1.6 + , semaphore-compat + ^>= 1.0.0 , text - >= 1.2 && < 2.1 + >= 1.2 && < 2.2 default-language: Haskell2010 @@ -80,21 +82,22 @@ , BuildEnv.Config , BuildEnv.File , BuildEnv.Script + , BuildEnv.Path , BuildEnv.Utils build-depends: async ^>= 2.2 , aeson - >= 1.5 && < 2.2 + >= 1.5 && < 2.3 , process ^>= 1.6 , temporary ^>= 1.3 , time - >= 1.9 && < 1.13 + >= 1.9 && < 1.15 , transformers - ^>= 0.5 + >= 0.5 && < 0.7 executable build-env
changelog.md view
@@ -1,12 +1,25 @@ # Changelog for `build-env` +## Version 1.2.0.0 (2024-08-22) + +- Allow specifying a Hackage index state using the `--index-state` flag (@simonmar). + +- Avoid using process substitution in generated build scripts, allowing the + build scripts to be run in environments in which `/dev/fd` is not available (@simonmar). + +- Add support for the GHC `-jsem` flag (GHC 9.8 and above), for speeding up parallel builds. + +- Add support for relocatable builds using `--configure-arg --enable-relocatable`. + +- Relax upper bounds on various dependencies of `build-env`. + ## Version 1.1.0.0 (2023-03-09) - Change the default directory structure produced by `build-env` to be more predictable. - Ensure that important arguments to Cabal configure override arguments - passed using `--configure-arg=`, as they are essential for `build-env` + passed using `--configure-arg`, as they are essential for `build-env` to function. ## Version 1.0.0.0 (2022-12-26)
readme.md view
@@ -12,6 +12,7 @@ - [Example](#example) - [Commands](#commands) + - [Parallelism](#parallelism) - [What does `build-env` do?](#what-does-build-env-do) - [Hermetic builds](#hermetic-builds) - [Narrowing a build down (for debugging)](#narrowing-a-build-down-for-debugging) @@ -65,11 +66,26 @@ Being able to separate these steps affords us some extra flexibility, as subsequent sections will explain. -Note: it is preferable to pass a previously computed build plan when calling +__Note__: it is preferable to pass a previously computed build plan when calling `build-env build --prefetched`: an invocation of the form `build-env build a b c --prefetched` will compute a new build plan, and this build plan could be different from the plan that was previously fetched, for example if you have run `cabal update` -in the meantime. +in the meantime. +Another option is to pass `--index-state`, which pins down a specific Hackage +index state. + +### Parallelism + +`build-env` supports parallel builds in much the same way as `cabal-install` does: + + - `-jN` controls how many packages are built concurrently. + - `--configure-arg --ghc-option=-jN` controls the parallelism afforded to + GHC invocations when building individual packages. + - `--jsem N` allows `build-env` and GHC to coordinate usage of CPU resources. + This is usually the fastest, but it requires: + - GHC >= 9.8, + - that GHC and `build-env` have been compiled against the same libc implementation + (see [GHC issue #25087](https://gitlab.haskell.org/ghc/ghc/-/issues/25087)). ## What does `build-env` do?
src/BuildEnv/Build.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : BuildEnv.Build @@ -43,6 +44,8 @@ ( for_, toList ) import Data.IORef ( newIORef ) +import Data.Functor + ( (<&>) ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList, isNothing ) import Data.String @@ -76,14 +79,10 @@ -- directory import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , exeExtension, listDirectory, removeDirectoryRecursive - ) - --- filepath -import System.FilePath - ( (</>), (<.>) - , isAbsolute + ( createDirectoryIfMissing + , doesDirectoryExist, doesFileExist + , exeExtension, listDirectory + , removeDirectoryRecursive ) -- process @@ -99,9 +98,11 @@ -- build-env import BuildEnv.BuildOne - ( PkgDbDirs(..) - , getPkgDbDirsForPrep, getPkgDbDirsForBuild, getPkgDir - , setupPackage, buildUnit ) + ( PkgDbDir(..) + , getPkgDbDirForPrep, getPkgDbDirForBuild + , getPkgDir + , setupPackage, buildUnit + ) import BuildEnv.CabalPlan import qualified BuildEnv.CabalPlan as Configured ( ConfiguredUnit(..) ) @@ -110,12 +111,14 @@ ( BuildScript, ScriptOutput(..), ScriptConfig(..) , emptyBuildScript , executeBuildScript, script - , createDir, logMessage + , createDir + , logMessage ) import BuildEnv.Utils ( ProgPath(..), CallProcess(..), callProcessInIO, withTempDir - , AbstractSem(..), noSem, newAbstractSem + , AbstractSem(..), noSem, withNewAbstractSem ) +import BuildEnv.Path -------------------------------------------------------------------------------- -- Planning. @@ -144,69 +147,61 @@ -> Verbosity -> Compiler -> Cabal + -> SymbolicPath CWD ( Dir Project ) -> CabalFilesContents -> IO CabalPlanBinary -computePlan delTemp verbosity comp cabal ( CabalFilesContents { cabalContents, projectContents } ) = - withTempDir delTemp "build" \ dir -> do - verboseMsg verbosity $ "Computing plan in build directory " <> Text.pack dir - Text.writeFile (dir </> "cabal" <.> "project") projectContents - Text.writeFile (dir </> dummyPackageName <.> "cabal") cabalContents +computePlan delTemp verbosity comp cabal _workDir ( CabalFilesContents { cabalContents, projectContents } ) = + withTempDir delTemp "build" \ tmpDir -> do + verboseMsg verbosity $ "Computing plan in build directory " <> Text.pack ( show tmpDir ) + Text.writeFile (getAbsolutePath tmpDir </> "cabal" <.> "project") projectContents + Text.writeFile (getAbsolutePath tmpDir </> dummyPackageName <.> "cabal") cabalContents let cabalBuildArgs = globalCabalArgs cabal ++ [ "build" , "--dry-run" - , "--with-compiler", ghcPath comp + , "--with-compiler", getAbsolutePath ( ghcPath comp ) , cabalVerbosity verbosity ] debugMsg verbosity $ - Text.unlines $ "cabal" : map ( (" " <>) . Text.pack ) cabalBuildArgs - callProcessInIO Nothing $ - CP { cwd = dir + Text.unlines $ "cabal" : map ( ( " " <> ) . Text.pack ) cabalBuildArgs + callProcessInIO @Tmp Nothing $ + CP { cwd = absoluteSymbolicPath tmpDir , prog = AbsPath $ cabalPath cabal , args = cabalBuildArgs , extraPATH = [] , extraEnvVars = [] , logBasePath = Nothing - , sem = noSem } + , sem = noSem + } - let planPath = dir </> "dist-newstyle" </> "cache" </> "plan.json" + let planPath :: FilePath + planPath = getAbsolutePath tmpDir </> "dist-newstyle" </> "cache" </> "plan.json" CabalPlanBinary <$> Lazy.ByteString.readFile planPath -- | The contents of a dummy @cabal.project@ file, specifying -- package constraints, flags and allow-newer. -cabalProjectContentsFromPackages :: FilePath -> UnitSpecs -> PkgSpecs -> AllowNewer -> Text -cabalProjectContentsFromPackages workDir units pins (AllowNewer allowNewer) = - packages - <> allowNewers - <> flagSpecs - <> constraints - where +cabalProjectContentsFromPackages + :: SymbolicPath CWD ( Dir Project ) + -> UnitSpecs + -> PkgSpecs + -> AllowNewer + -> Maybe IndexState + -> IO Text +cabalProjectContentsFromPackages workDir units pins ( AllowNewer allowNewer ) mbIndexState = do + -- Make all the local package paths into absolute paths, as we are + -- putting the cabal.project file off in some temporary directory. + ( localPkgs :: [ AbsolutePath ( Dir Pkg ) ] ) + <- traverse ( makeAbsolute workDir ) $ mapMaybe isLocal ( Map.elems units ) + + let packages | null localPkgs = "packages: .\n\n" | otherwise = Text.intercalate ",\n " - ( "packages: ." : map ( Text.pack . makeAbsolute ) ( Map.elems localPkgs ) ) + ( "packages: ." : map ( Text.pack . getAbsolutePath ) localPkgs ) <> "\n" - makeAbsolute :: FilePath -> FilePath - makeAbsolute fp - | isAbsolute fp - = fp - | otherwise - = workDir </> fp - - isLocal :: (PkgSrc, PkgSpec, Set ComponentName) -> Maybe FilePath - isLocal ( Local src, _, _ ) = Just src - isLocal _ = Nothing - localPkgs = Map.mapMaybe isLocal units - - allPkgs = fmap ( \ ( _, spec, _ ) -> spec ) units - `unionPkgSpecsOverriding` - pins - -- Constraints from the SEED file (units) should override - -- constraints from the cabal.config file (pins). - constraints = Text.unlines [ Text.unwords ["constraints:", unPkgName nm, cts] | (nm, ps) <- Map.assocs allPkgs @@ -233,6 +228,31 @@ , not $ flagSpecIsEmpty flags ] + indexStateDecl = case mbIndexState of + Nothing -> "" + Just ( IndexState date ) -> + Text.unlines [ "index-state: " <> date ] + + return $ + packages + <> allowNewers + <> flagSpecs + <> constraints + <> indexStateDecl + + where + + isLocal :: ( PkgSrc, PkgSpec, Set ComponentName ) -> Maybe ( SymbolicPath Project ( Dir Pkg ) ) + isLocal ( Local src, _, _ ) = Just src + isLocal _ = Nothing + + allPkgs :: PkgSpecs + allPkgs = fmap ( \ ( _, spec, _ ) -> spec ) units + `unionPkgSpecsOverriding` + pins + -- Constraints from the SEED file (units) should override + -- constraints from the cabal.config file (pins). + -- | The contents of a dummy Cabal file with dependencies on -- the specified units (without any constraints). cabalFileContentsFromPackages :: UnitSpecs -> Text @@ -299,17 +319,19 @@ -- subfolder of the specified directory (e.g. @pkg-name-1.2.3@). fetchPlan :: Verbosity -> Cabal - -> FilePath -- ^ Directory in which to put the sources. + -> SymbolicPath CWD ( Dir Project ) + -> Maybe IndexState + -> SymbolicPath Project ( Dir Fetch ) -- ^ Directory in which to put the sources. -> CabalPlan -> IO () -fetchPlan verbosity cabal fetchDir cabalPlan = +fetchPlan verbosity cabal workDir mbIndexState fetchDir cabalPlan = for_ pkgs \ (pkgNm, pkgVer) -> do let nameVersion = pkgNameVersion pkgNm pkgVer nmVerStr = Text.unpack nameVersion - pkgDirExists <- doesDirectoryExist (fetchDir </> nmVerStr) + pkgDirExists <- doesDirectoryExist ( interpretSymbolicPath workDir $ fetchDir </> mkRelativePath nmVerStr ) if pkgDirExists then normalMsg verbosity $ "NOT fetching " <> nameVersion - else cabalFetch verbosity cabal fetchDir nmVerStr + else cabalFetch verbosity cabal workDir mbIndexState fetchDir nmVerStr where pkgs :: Set (PkgName, Version) pkgs = Set.fromList @@ -326,15 +348,22 @@ _ -> Nothing -- | Call @cabal get@ to fetch a single package from Hackage. -cabalFetch :: Verbosity -> Cabal -> FilePath -> String -> IO () -cabalFetch verbosity cabal root pkgNmVer = do +cabalFetch :: Verbosity -> Cabal + -> SymbolicPath CWD ( Dir Project ) + -> Maybe IndexState + -> SymbolicPath Project ( Dir Fetch ) + -> String + -> IO () +cabalFetch verbosity cabal workDir mbIndexState root pkgNmVer = do normalMsg verbosity $ "Fetching " <> Text.pack pkgNmVer let args = globalCabalArgs cabal ++ [ "get" , pkgNmVer , cabalVerbosity verbosity ] - callProcessInIO Nothing $ - CP { cwd = root + ++ [ "--index-state=" <> Text.unpack indexState + | IndexState indexState <- maybeToList mbIndexState ] + callProcessInIO @Fetch Nothing $ + CP { cwd = workDir </> root , prog = AbsPath $ cabalPath cabal , args , extraPATH = [] @@ -349,12 +378,14 @@ -- by running their @Setup@ scripts. Libraries will be registered -- into a local package database at @installDir/package.conf@. buildPlan :: Verbosity - -> FilePath + -> SymbolicPath CWD ( Dir Project ) -- ^ Working directory. -- Used to compute relative paths for local packages, -- and to choose a logging directory. -> Paths ForPrep -> Paths ForBuild + -> Maybe ( SymbolicPath Project ( Dir Logs ) ) + -- ^ event log directory -> BuildStrategy -> Bool -- ^ @True@ <> resume a previously-started build, @@ -374,51 +405,51 @@ buildPlan verbosity workDir pathsForPrep@( Paths { buildPaths = buildPathsForPrep }) pathsForBuild + mbEventLogDir buildStrat resumeBuild mbOnlyBuildDepsOf userUnitArgs cabalPlan = do - let paths@( BuildPaths { compiler, prefix, destDir, installDir } ) - = buildPaths pathsForBuild - -- Create the temporary package database, if it doesn't already exist. - -- We also create the final installation package database, - -- but this happens later, in (*), as part of the build script itself. - -- - -- See Note [Using two package databases] in BuildOne. - let pkgDbDirsForPrep@( PkgDbDirsForPrep { tempPkgDbDir } ) - = getPkgDbDirsForPrep pathsForPrep - tempPkgDbExists <- doesDirectoryExist tempPkgDbDir + let paths@( BuildPaths { compiler, prefix, installDir } ) + = buildPaths pathsForBuild - if - | resumeBuild && not tempPkgDbExists - -> error $ - "Cannot resume build: no package database at " <> tempPkgDbDir - | not resumeBuild - -> do when tempPkgDbExists $ - removeDirectoryRecursive tempPkgDbDir - `catch` \ ( _ :: IOException ) -> return () - createDirectoryIfMissing True tempPkgDbDir - | otherwise - -> return () + pkgDbDirForPrep + = getPkgDbDirForPrep pathsForPrep - pkgDbDirsForBuild@( PkgDbDirsForBuild { finalPkgDbDir } ) - <- getPkgDbDirsForBuild pathsForBuild + pkgDbDirs@( PkgDbDirForBuild { finalPkgDbDir } ) + <- getPkgDbDirForBuild pathsForBuild + -- Check the package database exists when it should, + -- and delete it if we are starting fresh. + finalPkgDbExists <- doesDirectoryExist ( getAbsolutePath finalPkgDbDir ) + if | resumeBuild && not finalPkgDbExists + -> error $ "Cannot resume build: no package database at " <> show finalPkgDbDir + | not resumeBuild && finalPkgDbExists + -> removeDirectoryRecursive ( getAbsolutePath finalPkgDbDir ) + `catch` \ ( _ :: IOException ) -> return () + | otherwise + -> return () + + for_ mbEventLogDir \ eventLogDir -> do + createDirectoryIfMissing True ( interpretSymbolicPath workDir eventLogDir ) + verboseMsg verbosity $ Text.unlines [ "Directory structure:" - , " prefix: " <> Text.pack prefix - , " destDir: " <> Text.pack destDir - , " installDir: " <> Text.pack installDir ] + , " work dir: " <> Text.pack ( show workDir ) + , " prefix: " <> Text.pack ( show prefix ) + , " installDir: " <> Text.pack ( show installDir ) + ] mbAlreadyBuilt <- if resumeBuild then let prepComp = compilerForPrep buildPathsForPrep - in Just <$> getInstalledUnits verbosity prepComp buildPathsForPrep pkgDbDirsForPrep fullDepMap + in Just <$> getInstalledUnits verbosity prepComp buildPathsForPrep pkgDbDirForPrep fullDepMap else return Nothing - let -- Units to build, in dependency order. + let + -- Units to build, in dependency order. unitsToBuild :: [(ConfiguredUnit, Maybe UnitId)] unitsToBuild = tagUnits $ sortPlan mbAlreadyBuilt mbOnlyBuildDepsOf cabalPlan @@ -432,13 +463,12 @@ | ( cu@( ConfiguredUnit { puPkgName, puVersion } ), didSetup ) <- unitsToBuild , isNothing didSetup ] - -- Initial preparation: logging, and creating the final - -- package database. + -- Initial preparation: logging, and creating the package database. preparation :: BuildScript preparation = do logMessage verbosity Verbose $ - "Creating final package database at " <> finalPkgDbDir - createDir finalPkgDbDir -- (*) + "Creating package database at " <> show finalPkgDbDir + createDir finalPkgDbDir logMessage verbosity Debug $ "Packages:\n" <> unlines [ " - " <> Text.unpack (pkgNameVersion nm ver) @@ -456,19 +486,28 @@ -- Setup the package for this unit. unitSetupScript :: ConfiguredUnit -> IO BuildScript unitSetupScript pu = do - let pkgDirForPrep = getPkgDir workDir pathsForPrep pu - pkgDirForBuild = getPkgDir workDir pathsForBuild pu + let pkgDirForPrep = getPkgDir pathsForPrep pu + pkgDirForBuild = getPkgDir pathsForBuild pu setupPackage verbosity compiler - paths pkgDbDirsForBuild pkgDirForPrep pkgDirForBuild + workDir paths pkgDbDirs pkgDirForPrep pkgDirForBuild fullDepMap pu -- Build and install this unit. - unitBuildScript :: ConfiguredUnit -> BuildScript - unitBuildScript pu = - let pkgDirForBuild = getPkgDir workDir pathsForBuild pu - in buildUnit verbosity compiler - paths pkgDbDirsForBuild pkgDirForBuild - (userUnitArgs pu) + unitBuildScript :: Args -> ConfiguredUnit -> BuildScript + unitBuildScript extraConfigureArgs pu@( ConfiguredUnit { puId }) = + let pkgDirForBuild = getPkgDir pathsForBuild pu + mbEventLogArg = mbEventLogDir <&> \ logDir -> + let logPath = getSymbolicPath logDir </> "ghc" <.> Text.unpack ( unUnitId puId ) <.> "eventlog" + in "--ghc-option=\"-with-rtsopts=-l-ol" <> logPath <> "\"" + allConfigureArgs = + mconcat [ extraConfigureArgs + , maybeToList mbEventLogArg + , configureArgs ( userUnitArgs pu ) ] + allUnitArgs = + ( userUnitArgs pu ) { configureArgs = allConfigureArgs } + in buildUnit verbosity compiler workDir + paths pkgDbDirs pkgDirForBuild + allUnitArgs fullDepMap pu -- Close out the build. @@ -487,88 +526,93 @@ Counter { counterRef = unitsBuiltCounterRef , counterMax = nbUnitsToBuild } + execBuildScript = executeBuildScript workDir unitsBuiltCounter + case runStrat of Async sem -> do normalMsg verbosity $ "\nBuilding and installing units asynchronously with " <> semDescription sem - executeBuildScript unitsBuiltCounter preparation + execBuildScript preparation - let unitMap :: Lazy.Map UnitId (ConfiguredUnit, Maybe UnitId) - unitMap = - Lazy.Map.fromList - [ (puId, pu) - | pu@( ConfiguredUnit { puId }, _ ) <- unitsToBuild ] + withNewAbstractSem sem \ ( AbstractSem { withAbstractSem } ) semArgs -> do - AbstractSem { withAbstractSem } <- newAbstractSem sem - (_, unitAsyncs) <- mfix \ ~(pkgAsyncs, unitAsyncs) -> do + let unitMap :: Lazy.Map UnitId (ConfiguredUnit, Maybe UnitId) + unitMap = + Lazy.Map.fromList + [ (puId, pu) + | pu@( ConfiguredUnit { puId }, _ ) <- unitsToBuild ] - let -- Compile the Setup script of the package the unit belongs to. - -- (This should happen only once per package.) - doPkgSetupAsync :: ConfiguredUnit -> IO () - doPkgSetupAsync cu@( ConfiguredUnit { puSetupDepends } ) = do + (_, unitAsyncs) <- mfix \ ~(pkgAsyncs, unitAsyncs) -> do - -- Wait for the @setup-depends@ units. - for_ puSetupDepends \ setupDepId -> - for_ (unitAsyncs Map.!? setupDepId) wait + let -- Compile the Setup script of the package the unit belongs to. + -- (This should happen only once per package.) + doPkgSetupAsync :: ConfiguredUnit -> IO () + doPkgSetupAsync cu@( ConfiguredUnit { puSetupDepends } ) = do - -- Setup the package. - withAbstractSem do - setupScript <- unitSetupScript cu - executeBuildScript unitsBuiltCounter setupScript + -- Wait for the @setup-depends@ units. + for_ puSetupDepends \ setupDepId -> + for_ (unitAsyncs Map.!? setupDepId) wait - -- Configure, build and install the unit. - doUnitAsync :: ( ConfiguredUnit, Maybe UnitId ) -> IO () - doUnitAsync ( pu, _didSetup ) = do + -- Setup the package. + withAbstractSem do + setupScript <- unitSetupScript cu + execBuildScript setupScript - let nm = Configured.puPkgName pu - ver = Configured.puVersion pu + -- Configure, build and install the unit. + doUnitAsync :: ( ConfiguredUnit, Maybe UnitId ) -> IO () + doUnitAsync ( pu, _didSetup ) = do - -- Wait for the package to have been setup. - wait $ pkgAsyncs Map.! (nm, ver) + let nm = Configured.puPkgName pu + ver = Configured.puVersion pu - -- Wait until we have built the units we depend on. - for_ (unitDepends pu) \ depUnitId -> - for_ (unitAsyncs Map.!? depUnitId) wait + -- Wait for the package to have been setup. + wait $ pkgAsyncs Map.! (nm, ver) - -- Build the unit! - withAbstractSem $ - executeBuildScript unitsBuiltCounter $ unitBuildScript pu + -- Wait until we have built the units we depend on. + for_ (unitDepends pu) \ depUnitId -> + for_ (unitAsyncs Map.!? depUnitId) wait - -- Kick off setting up the packages... - finalPkgAsyncs <- for pkgMap (async . doPkgSetupAsync) - -- ... and building the units. - finalUnitAsyncs <- for unitMap (async . doUnitAsync) - return (finalPkgAsyncs, finalUnitAsyncs) - mapM_ wait unitAsyncs - executeBuildScript unitsBuiltCounter finish + -- Build the unit! + withAbstractSem $ + execBuildScript $ unitBuildScript semArgs pu + -- Kick off setting up the packages... + finalPkgAsyncs <- for pkgMap (async . doPkgSetupAsync) + -- ... and building the units. + finalUnitAsyncs <- for unitMap (async . doUnitAsync) + return (finalPkgAsyncs, finalUnitAsyncs) + mapM_ wait unitAsyncs + execBuildScript finish + TopoSort -> do normalMsg verbosity "\nBuilding and installing units sequentially.\n\ \NB: pass -j<N> for increased parallelism." - executeBuildScript unitsBuiltCounter preparation + execBuildScript preparation for_ unitsToBuild \ ( cu, didSetup ) -> do when (isNothing didSetup) $ - unitSetupScript cu >>= executeBuildScript unitsBuiltCounter - executeBuildScript unitsBuiltCounter (unitBuildScript cu) - executeBuildScript unitsBuiltCounter finish + unitSetupScript cu >>= execBuildScript + execBuildScript (unitBuildScript [] cu) + execBuildScript finish Script { scriptPath = fp, useVariables } -> do let scriptConfig :: ScriptConfig scriptConfig = - ScriptConfig { scriptOutput = Shell { useVariables } - , scriptStyle = hostStyle - , scriptTotal = Just nbUnitsToBuild } + ScriptConfig + { scriptOutput = Shell { useVariables } + , scriptStyle = hostStyle + , scriptTotal = Just nbUnitsToBuild + , scriptWorkingDir = workDir } - normalMsg verbosity $ "\nWriting build scripts to " <> Text.pack fp + normalMsg verbosity $ "\nWriting build scripts to " <> Text.pack ( show fp ) buildScripts <- for unitsToBuild \ ( cu, didSetup ) -> do mbSetup <- if isNothing didSetup then unitSetupScript cu else return emptyBuildScript - let build = unitBuildScript cu + let build = unitBuildScript [] cu return $ mbSetup <> build - Text.writeFile fp $ script scriptConfig $ + Text.writeFile ( getSymbolicPath fp ) $ script scriptConfig $ preparation <> mconcat buildScripts <> finish where @@ -664,21 +708,21 @@ getInstalledUnits :: Verbosity -> Compiler -> BuildPaths ForPrep - -> PkgDbDirs ForPrep + -> PkgDbDir ForPrep -> Map UnitId PlanUnit -> IO ( Set UnitId ) getInstalledUnits verbosity ( Compiler { ghcPkgPath } ) ( BuildPathsForPrep { installDir } ) - ( PkgDbDirsForPrep { tempPkgDbDir } ) + ( PkgDbDirForPrep { finalPkgDbDir } ) plan = do pkgVerUnitIds <- words <$> - Process.readProcess ( ghcPkgPath ) + Process.readProcess ( getAbsolutePath ghcPkgPath ) [ "list" , ghcPkgVerbosity verbosity , "--show-unit-ids", "--simple-output" - , "--package-db", tempPkgDbDir ] + , "--package-db", getAbsolutePath finalPkgDbDir ] -- TODO: allow user package databases too? "" let installedLibs = map ( UnitId . Text.pack ) pkgVerUnitIds @@ -697,8 +741,8 @@ mkLine ( UnitId uid ) = " - " <> uid binsDir :: FilePath - binsDir = installDir </> "bin" - binDirMaybe :: FilePath -> IO (Maybe UnitId) + binsDir = getAbsolutePath installDir </> "bin" + binDirMaybe :: FilePath -> IO ( Maybe UnitId ) binDirMaybe binDir = do isDir <- doesDirectoryExist ( binsDir </> binDir ) if not isDir
src/BuildEnv/BuildOne.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -23,8 +24,8 @@ , PkgDir(..) , getPkgDir - , PkgDbDirs(..) - , getPkgDbDirsForPrep, getPkgDbDirsForBuild + , PkgDbDir(..) + , getPkgDbDirForPrep, getPkgDbDirForBuild, ) where -- base @@ -46,12 +47,6 @@ -- directory import System.Directory --- filepath -import System.FilePath - ( (</>), (<.>) - , makeRelative - ) - -- text import Data.Text ( Text ) @@ -62,6 +57,7 @@ import BuildEnv.Config import BuildEnv.CabalPlan import BuildEnv.Script +import BuildEnv.Path import BuildEnv.Utils ( ProgPath(..), CallProcess(..) , abstractQSem, noSem @@ -75,8 +71,9 @@ -- Returns a build script which compiles the @Setup@ script. setupPackage :: Verbosity -> Compiler + -> SymbolicPath CWD ( Dir Project ) -> BuildPaths ForBuild -- ^ Overall build directory structure. - -> PkgDbDirs ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild'). + -> PkgDbDir ForBuild -- ^ Package database directory (see 'getPkgDbDirForBuild'). -> PkgDir ForPrep -- ^ Package directory (to find the @Setup.hs@). -> PkgDir ForBuild -- ^ Package directory (to build the @Setup.hs@). -> Map UnitId PlanUnit -- ^ All dependencies in the build plan. @@ -84,33 +81,42 @@ -> IO BuildScript setupPackage verbosity ( Compiler { ghcPath } ) + workDir paths@( BuildPaths { installDir, logDir } ) - ( PkgDbDirsForBuild { tempPkgDbDir } ) + ( PkgDbDirForBuild { finalPkgDbDir } ) ( PkgDir { pkgNameVer, pkgDir = prepPkgDir } ) ( PkgDir { pkgDir = buildPkgDir } ) plan unit@( ConfiguredUnit { puId, puSetupDepends, puExeDepends } ) - = do let logPath + = do let logPath :: Maybe ( AbsolutePath File ) + logPath | verbosity <= Quiet = Nothing | otherwise - = Just $ logDir </> Text.unpack ( unUnitId puId ) + = Just $ logDir </> mkRelativePath ( Text.unpack ( unUnitId puId ) ) -- Find the appropriate Setup.hs file (creating one if necessary) - setupHs <- findSetupHs prepPkgDir + setupHs <- findSetupHs workDir prepPkgDir return do scriptCfg <- askScriptConfig - let setupArgs = [ quoteArg ExpandVars scriptCfg ( buildPkgDir </> setupHs ) + let isCabalDep uid = case Map.lookup uid plan of + Nothing -> error $ "setupPackage: cannot find setup dependency " ++ show uid + Just pu -> planUnitPkgName pu == PkgName "Cabal" + extraCabalSetupDep = not $ any isCabalDep puSetupDepends + setupArgs = [ quoteArg ExpandVars scriptCfg ( getSymbolicPath $ setupHs ) , "-o" - , quoteArg ExpandVars scriptCfg ( buildPkgDir </> "Setup" ) - , "-package-db=" <> quoteArg ExpandVars scriptCfg tempPkgDbDir + , quoteArg ExpandVars scriptCfg ( getSymbolicPath $ mkRelativePath "Setup" ) + , "-package-db=" <> quoteArg ExpandVars scriptCfg ( getAbsolutePath finalPkgDbDir ) , ghcVerbosity verbosity ] ++ map unitIdArg puSetupDepends + ++ [ "-package Cabal" | extraCabalSetupDep ] + -- Add an implicit dependency on the 'Cabal' library + -- if there isn't an explicit dependency on it. -- Specify location of binaries and data directories. -- -- See the commentary around 'depDataDirs' in 'buildUnit'. - binDirs = [ quoteArg ExpandVars scriptCfg $ installDir </> "bin" </> Text.unpack ( unUnitId exeUnitId ) + binDirs = [ quoteArg ExpandVars scriptCfg $ getAbsolutePath $ installDir </> mkRelativePath ( "bin" </> Text.unpack ( unUnitId exeUnitId ) ) | exeUnitId <- puExeDepends ] setupDepDataDirs = dataDirs scriptCfg paths @@ -121,8 +127,8 @@ ] logMessage verbosity Verbose $ "Compiling Setup.hs for " <> pkgNameVer - callProcess $ - CP { cwd = "." + callProcess @Pkg $ + CP { cwd = workDir </> buildPkgDir , prog = AbsPath ghcPath , args = setupArgs , extraPATH = binDirs @@ -133,17 +139,21 @@ -- | Find the @Setup.hs@/@Setup.lhs@ file to use, -- or create one using @main = defaultMain@ if none exist. -findSetupHs :: FilePath -> IO FilePath -findSetupHs root = trySetupsOrUseDefault [ "Setup.hs", "Setup.lhs" ] +findSetupHs :: SymbolicPath CWD ( Dir Project ) + -> SymbolicPath Project ( Dir Pkg ) + -> IO ( RelativePath Pkg File ) +findSetupHs workDir root = + trySetupsOrUseDefault [ mkRelativePath "Setup.hs", mkRelativePath "Setup.lhs" ] where + useDefaultSetupHs = do - let path = root </> "Setup.hs" - writeFile path defaultSetupHs - return "Setup.hs" + let path = root </> mkRelativePath "Setup.hs" + writeFile ( interpretSymbolicPath workDir path ) defaultSetupHs + return $ mkRelativePath "Setup.hs" try fname = do let path = root </> fname - exists <- doesFileExist path + exists <- doesFileExist ( interpretSymbolicPath workDir path ) return $ if exists then Just fname else Nothing defaultSetupHs = unlines @@ -152,7 +162,7 @@ ] trySetupsOrUseDefault [] = useDefaultSetupHs - trySetupsOrUseDefault (setupPath:setups) = do + trySetupsOrUseDefault ( setupPath : setups ) = do res <- try setupPath case res of Nothing -> trySetupsOrUseDefault setups @@ -171,8 +181,9 @@ -- registered in the package database. buildUnit :: Verbosity -> Compiler + -> SymbolicPath CWD ( Dir Project ) -> BuildPaths ForBuild -- ^ Overall build directory structure. - -> PkgDbDirs ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild'). + -> PkgDbDir ForBuild -- ^ Package database directory (see 'getPkgDbDirForBuild'). -> PkgDir ForBuild -- ^ This package's directory (see 'getPkgDir'). -> UnitArgs -- ^ Extra arguments for this unit. -> Map UnitId PlanUnit -- ^ All dependencies in the build plan. @@ -180,29 +191,31 @@ -> BuildScript buildUnit verbosity ( Compiler { ghcPath, ghcPkgPath } ) - paths@( BuildPaths { installDir, prefix, destDir, logDir } ) - ( PkgDbDirsForBuild - { tempPkgDbDir - , finalPkgDbDir - , tempPkgDbSem + workDir + paths@( BuildPaths { installDir, prefix, logDir } ) + ( PkgDbDirForBuild + { finalPkgDbDir , finalPkgDbSem } ) ( PkgDir { pkgDir, pkgNameVer } ) ( UnitArgs { configureArgs = userConfigureArgs , mbHaddockArgs = mbUserHaddockArgs , registerArgs = userGhcPkgArgs } ) plan unit@( ConfiguredUnit { puId, puDepends, puExeDepends } ) - = let compName = Text.unpack $ cabalComponent ( puComponentName unit ) - thisUnit'sId = Text.unpack ( unUnitId puId ) + = let compName = Text.unpack $ cabalComponent ( puComponentName unit ) + thisUnit'sId = Text.unpack $ unUnitId puId + logPath :: Maybe ( AbsolutePath File ) logPath | verbosity <= Quiet = Nothing | otherwise - = Just $ logDir </> thisUnit'sId + = Just $ logDir </> mkRelativePath thisUnit'sId unitPrintableName | verbosity >= Verbose = pkgNameVer <> ":" <> compName | otherwise = compName + setupDir :: SymbolicPath CWD ( Dir Pkg ) + setupDir = workDir </> pkgDir in do scriptCfg <- askScriptConfig @@ -210,7 +223,7 @@ let -- Specify the data directories for all dependencies, -- including executable dependencies (see (**)). -- This is important so that e.g. 'happy' can find its datadir. - depDataDirs = + setupEnvVars = dataDirs scriptCfg paths [ dep_cu | depUnitId <- unitDepends unit -- (**) depends ++ exeDepends @@ -224,7 +237,7 @@ | flagSpecIsEmpty flags -> [] | otherwise - -> [ "--flags=" <> quoteArg ExpandVars scriptCfg ( Text.unpack (showFlagSpec flags) ) ] + -> [ "--flags=" <> quoteArg ExpandVars scriptCfg ( Text.unpack $ showFlagSpec flags ) ] -- NB: make sure to update the readme after changing -- the arguments that are passed here. @@ -249,10 +262,10 @@ -- Arguments essential to the build; can't be overriden by the user. essentialConfigureArgs = [ "--exact-configuration" - , "--with-compiler", quoteArg ExpandVars scriptCfg ghcPath - , "--prefix" , quoteArg ExpandVars scriptCfg prefix + , "--with-compiler", quoteArg ExpandVars scriptCfg ( getAbsolutePath ghcPath ) + , "--prefix" , quoteArg ExpandVars scriptCfg ( getAbsolutePath prefix ) , "--cid=" <> Text.unpack ( unUnitId puId ) - , "--package-db=" <> quoteArg ExpandVars scriptCfg tempPkgDbDir + , "--package-db=" <> quoteArg ExpandVars scriptCfg ( getAbsolutePath finalPkgDbDir ) , "--datadir=" <> quoteArg EscapeVars scriptCfg ( "$prefix" </> "share" ) -- Keep datadir in sync with the 'dataDirs' function. , "--datasubdir=" <> pkgNameVer @@ -274,21 +287,23 @@ -- dependencies during the build. -- Keep this in sync with --bindir in essentialConfigureArgs. binDirs = [ quoteArg ExpandVars scriptCfg $ - installDir </> "bin" </> Text.unpack ( unUnitId exeUnitId ) + getAbsolutePath $ + installDir </> mkRelativePath ( "bin" </> Text.unpack ( unUnitId exeUnitId ) ) | exeUnitId <- puExeDepends ] + setupExe :: ProgPath Pkg setupExe = RelPath $ runCwdExe scriptCfg "Setup" -- relative to pkgDir logMessage verbosity Verbose $ "Configuring " <> unitPrintableName logMessage verbosity Debug $ - "Configure arguments:\n" <> unlines (map (" " <>) configureArgs) - callProcess $ - CP { cwd = pkgDir + "Configure arguments:\n" <> unlines ( map ( " " <> ) configureArgs ) + callProcess @Pkg $ + CP { cwd = setupDir , prog = setupExe , args = "configure" : configureArgs , extraPATH = binDirs - , extraEnvVars = depDataDirs -- Not sure this is needed for 'Setup configure'. + , extraEnvVars = setupEnvVars , logBasePath = logPath , sem = noSem } @@ -296,14 +311,14 @@ -- Build logMessage verbosity Verbose $ "Building " <> unitPrintableName - callProcess $ - CP { cwd = pkgDir + callProcess @Pkg $ + CP { cwd = setupDir , prog = setupExe , args = [ "build" , "--builddir=" <> buildDir , setupVerbosity verbosity ] , extraPATH = binDirs - , extraEnvVars = depDataDirs + , extraEnvVars = setupEnvVars , logBasePath = logPath , sem = noSem } @@ -312,15 +327,15 @@ for_ mbUserHaddockArgs \ userHaddockArgs -> do logMessage verbosity Verbose $ "Building documentation for " <> unitPrintableName - callProcess $ - CP { cwd = pkgDir + callProcess @Pkg $ + CP { cwd = setupDir , prog = setupExe , args = [ "haddock" , setupVerbosity verbosity ] ++ userHaddockArgs ++ [ "--builddir=" <> buildDir ] , extraPATH = binDirs - , extraEnvVars = depDataDirs + , extraEnvVars = setupEnvVars , logBasePath = logPath , sem = noSem } @@ -328,14 +343,15 @@ -- Copy logMessage verbosity Verbose $ "Copying " <> unitPrintableName - callProcess $ - CP { cwd = pkgDir + callProcess @Pkg $ + CP { cwd = setupDir , prog = setupExe , args = [ "copy", setupVerbosity verbosity , "--builddir=" <> buildDir - , "--destdir", quoteArg ExpandVars scriptCfg destDir ] + , "--target-package-db=" <> quoteArg ExpandVars scriptCfg (getAbsolutePath $ installDir </> mkRelativePath "package.conf") + ] , extraPATH = [] - , extraEnvVars = [] + , extraEnvVars = setupEnvVars , logBasePath = logPath , sem = noSem } @@ -343,53 +359,53 @@ -- Register case cuComponentType unit of Lib -> do - -- Register library (in both the local and final package databases) - -- See Note [Using two package databases]. + -- Register library. let pkgRegsFile = thisUnit'sId <> "-pkg-reg.conf" - dirs = [ ( tempPkgDbDir, tempPkgDbSem, "temporary", ["--inplace"], []) - , (finalPkgDbDir, finalPkgDbSem, "final" , [], "--force" : userGhcPkgArgs) ] - for_ dirs \ (pkgDbDir, pkgDbSem, desc, extraSetupArgs, extraPkgArgs) -> do + logMessage verbosity Verbose $ + mconcat [ "Writing package registration for ", unitPrintableName + , " to:\n" + , pkgRegsFile ] - logMessage verbosity Verbose $ - mconcat [ "Registering ", unitPrintableName, " in " - , desc, " package database at:\n " - , pkgDbDir ] + -- Setup register + callProcess @Pkg $ + CP { cwd = setupDir + , prog = setupExe + , args = [ "register", setupVerbosity verbosity + , "--builddir=" <> buildDir + , "--gen-pkg-config=" <> pkgRegsFile ] + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = logPath + , sem = noSem + } - -- Setup register - callProcess $ - CP { cwd = pkgDir - , prog = setupExe - , args = [ "register", setupVerbosity verbosity ] - ++ extraSetupArgs - ++ [ "--builddir=" <> buildDir - , "--gen-pkg-config=" <> pkgRegsFile ] - , extraPATH = [] - , extraEnvVars = [] - , logBasePath = logPath - , sem = noSem - } + -- NB: we have configured & built a single target, + -- so there should be a single "pkg-reg.conf" file, + -- and not a directory of registration files. - -- NB: we have configured & built a single target, - -- so there should be a single "pkg-reg.conf" file, - -- and not a directory of registration files. + logMessage verbosity Verbose $ + mconcat [ "Registering ", unitPrintableName + , " in package database at:\n" + , show finalPkgDbDir ] - -- ghc-pkg register - callProcess $ - CP { cwd = pkgDir - , prog = AbsPath ghcPkgPath - , args = [ "register" - , ghcPkgVerbosity verbosity ] - ++ extraPkgArgs - ++ [ "--package-db", quoteArg ExpandVars scriptCfg pkgDbDir - , pkgRegsFile ] - , extraPATH = [] - , extraEnvVars = [] - , logBasePath = logPath - , sem = abstractQSem pkgDbSem - -- Take a lock to avoid contention on the package database - -- when building units concurrently. - } + -- ghc-pkg register + callProcess @Pkg $ + CP { cwd = setupDir + , prog = AbsPath ghcPkgPath + , args = [ "register" + , ghcPkgVerbosity verbosity + , "--force" ] + ++ userGhcPkgArgs + ++ [ "--package-db", quoteArg ExpandVars scriptCfg ( getAbsolutePath finalPkgDbDir ) + , pkgRegsFile ] + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = logPath + , sem = abstractQSem finalPkgDbSem + -- Take a lock to avoid contention on the package database + -- when building units concurrently. + } _notALib -> return () @@ -443,71 +459,40 @@ -------------------------------------------------------------------------------- -- Directory structure computation helpers -{- $twoDBs -__Note [Using two package databases]__ - -We need __two__ distinct package databases: we might want to perform the build -in a temporary location, before everything gets placed into its final -destination. The final package database might use a specific, baked-in -installation prefix (in the sense of @Setup configure --prefix pfx@). As a -result, this package database won't be immediately usable, as we won't have -copied over the build products yet. - -In order to be able to build packages in a temporary directory, we create a -temporary package database that is used for the build, making use of it -with @Setup register --inplace@. -We also register the packages into the final package database using -@ghc-pkg --force@: otherwise, @ghc-pkg@ would error because the relevant files -haven't been copied over yet. --} - --- | The package database directories. --- --- See Note [Using two package databases]. -type PkgDbDirs :: PathUsability -> Type -data family PkgDbDirs use +-- | The package database directory. +type PkgDbDir :: PathUsability -> Type +data family PkgDbDir use -data instance PkgDbDirs ForPrep - = PkgDbDirsForPrep - { tempPkgDbDir :: !FilePath - -- ^ Local package database directory. +data instance PkgDbDir ForPrep + = PkgDbDirForPrep + { finalPkgDbDir :: !( AbsolutePath ( Dir PkgDb ) ) + -- ^ Installation package database directory. } -data instance PkgDbDirs ForBuild - = PkgDbDirsForBuild - { tempPkgDbDir :: !FilePath - -- ^ Local package database directory. - , tempPkgDbSem :: !QSem - -- ^ Semaphore controlling access to the temporary - -- package database. - , finalPkgDbDir :: !FilePath +data instance PkgDbDir ForBuild + = PkgDbDirForBuild + { finalPkgDbDir :: !( AbsolutePath ( Dir PkgDb ) ) -- ^ Installation package database directory. , finalPkgDbSem :: !QSem -- ^ Semaphore controlling access to the installation -- package database. } --- | Compute the paths of the package database directories we are going +-- | Compute the paths of the package database directory we are going -- to use. --- --- See Note [Using two package databases]. -getPkgDbDirsForPrep :: Paths ForPrep -> PkgDbDirs ForPrep -getPkgDbDirsForPrep ( Paths { fetchDir } ) = - PkgDbDirsForPrep { tempPkgDbDir = fetchDir </> "package.conf" } +getPkgDbDirForPrep :: Paths ForPrep -> PkgDbDir ForPrep +getPkgDbDirForPrep ( Paths { buildPaths = BuildPathsForPrep { installDir } } ) = + PkgDbDirForPrep { finalPkgDbDir = installDir </> mkRelativePath "package.conf" } --- | Compute the paths of the package database directories we are going --- to use, and create some semaphores to control access to them +-- | Compute the paths of the package database directory we are going +-- to use, and create some semaphores to control access to it -- in order to avoid contention. --- --- See Note [Using two package databases]. -getPkgDbDirsForBuild :: Paths ForBuild -> IO (PkgDbDirs ForBuild) -getPkgDbDirsForBuild ( Paths { fetchDir, buildPaths = BuildPaths { installDir } } ) = do - tempPkgDbSem <- newQSem 1 +getPkgDbDirForBuild :: Paths ForBuild -> IO (PkgDbDir ForBuild) +getPkgDbDirForBuild ( Paths { buildPaths = BuildPaths { installDir } } ) = do finalPkgDbSem <- newQSem 1 return $ - PkgDbDirsForBuild { tempPkgDbDir, finalPkgDbDir, tempPkgDbSem, finalPkgDbSem } + PkgDbDirForBuild { finalPkgDbDir, finalPkgDbSem } where - tempPkgDbDir = fetchDir </> "package.conf" - finalPkgDbDir = installDir </> "package.conf" + finalPkgDbDir = installDir </> mkRelativePath "package.conf" -- | The package @name-version@ string and its directory. type PkgDir :: PathUsability -> Type @@ -515,7 +500,7 @@ = PkgDir { pkgNameVer :: !String -- ^ Package @name-version@ string. - , pkgDir :: !FilePath + , pkgDir :: !( SymbolicPath Project ( Dir Pkg ) ) -- ^ Package directory. } type role PkgDir representational @@ -523,31 +508,26 @@ -- a @PkgDir ForBuild@. -- | Compute the package directory location. -getPkgDir :: FilePath - -- ^ Working directory - -- (used only to relativise paths to local packages). - -> Paths use +getPkgDir :: Paths use -- ^ Overall directory structure to base the computation off. -> ConfiguredUnit -- ^ Any unit from the package in question. -> PkgDir use -getPkgDir workDir ( Paths { fetchDir } ) +getPkgDir ( Paths { fetchDir } ) ( ConfiguredUnit { puPkgName, puVersion, puPkgSrc } ) = PkgDir { pkgNameVer, pkgDir } where pkgNameVer = Text.unpack $ pkgNameVersion puPkgName puVersion pkgDir | Local dir <- puPkgSrc - = makeRelative workDir dir - -- Give local packages paths relative to the working directory, - -- to enable relocatable build scripts. + = dir | otherwise - = fetchDir </> pkgNameVer + = fetchDir </> mkRelativePath pkgNameVer -- | Command to run an executable located the current working directory. -runCwdExe :: ScriptConfig -> FilePath -> FilePath +runCwdExe :: ScriptConfig -> String -> SymbolicPath from File runCwdExe ( ScriptConfig { scriptOutput, scriptStyle } ) - = pre . ext + = mkSymbolicPath . pre . ext where pre | Run <- scriptOutput @@ -568,6 +548,6 @@ dataDirs scriptCfg ( BuildPaths { installDir } ) units = [ ( mangledPkgName puPkgName <> "_datadir" , quoteArg ExpandVars scriptCfg $ - installDir </> "share" </> Text.unpack (pkgNameVersion puPkgName puVersion) ) + getAbsolutePath $ installDir </> mkRelativePath ( "share" </> Text.unpack ( pkgNameVersion puPkgName puVersion ) ) ) -- Keep this in sync with --datadir in essentialConfigureArgs. | ConfiguredUnit { puPkgName, puVersion } <- units ]
src/BuildEnv/CabalPlan.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} @@ -72,7 +73,7 @@ -- base import Data.Char - ( isAlphaNum ) + ( isAlpha, isAlphaNum ) import Data.Maybe ( fromMaybe, mapMaybe ) import Data.Version @@ -97,6 +98,9 @@ ( Text ) import qualified Data.Text as Text +-- build-env +import BuildEnv.Path + ------------------------------------------------------------------------------- -- Build plans @@ -139,7 +143,11 @@ -- | Is the string a valid @cabal@ package name? That is, does it consist -- only of alphanumeric identifiers and hyphens? validPackageName :: Text -> Bool -validPackageName = Text.all ( \ x -> isAlphaNum x || x == '-' ) +validPackageName txt = + Text.all ( \ x -> isAlphaNum x || x == '-' ) txt + && case Text.uncons txt of + Nothing -> False + Just (c,_) -> isAlpha c -- | A Cabal mangled package name, in which @-@ has been replaced with @_@. mangledPkgName :: PkgName -> String @@ -240,7 +248,7 @@ -- - @Just fp@: specified by the @cabal@ file at the given path. data PkgSrc = Remote - | Local !FilePath + | Local !( SymbolicPath Project ( Dir Pkg ) ) deriving stock Show instance Semigroup PkgSrc where @@ -254,7 +262,7 @@ parseJSON = withObject "package source" \ o -> do ty <- o .: "type" case ty :: Text of - "local" -> Local <$> o .: "path" + "local" -> Local . mkSymbolicPath <$> o .: "path" "repo-tar" -> return Remote -- <$> o .: "repo" _ -> @@ -387,7 +395,7 @@ -- | A mapping from a package name to its flags, constraints, -- and components we want to build from it. -type UnitSpecs = Strict.Map PkgName (PkgSrc, PkgSpec, Set ComponentName) +type UnitSpecs = Strict.Map PkgName ( PkgSrc, PkgSpec, Set ComponentName ) -- | The name of a cabal component, e.g. @lib:comp@. data ComponentName =
src/BuildEnv/Config.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -22,6 +23,9 @@ -- * @ghc@ and @cabal-install@ executables , Compiler(..), Cabal(..) + -- * Hackage index state + , IndexState(..) + -- * Directory structure , Paths(..), BuildPaths(..) , PathUsability(..) @@ -56,13 +60,9 @@ import System.IO ( hFlush, stdout ) --- directory -import System.Directory - ( canonicalizePath ) - -- filepath import System.FilePath - ( (</>), dropDrive ) + ( dropDrive ) -- text import Data.Text @@ -78,6 +78,9 @@ import Data.Time.Format ( defaultTimeLocale, formatTime ) +-- build-env +import BuildEnv.Path + -------------------------------------------------------------------------------- -- Build strategy @@ -87,7 +90,7 @@ = Execute RunStrategy -- | Output a build script that can be run later. | Script - { scriptPath :: !FilePath + { scriptPath :: !( SymbolicPath CWD File ) -- ^ Output path at which to write the build script. , useVariables :: !Bool -- ^ Should the output shell script use variables, or baked in paths? @@ -103,6 +106,7 @@ -- | Topologically sort the cabal build plan, and build the -- packages in sequence. = TopoSort + -- | Asynchronously build all the packages, with each package -- waiting on its dependencies. | Async @@ -111,22 +115,24 @@ deriving stock Show -- | What kind of semaphore to use in 'BuildEnv.Build.buildPlan'? --- --- NB: this datatype depends on whether the @jsem@ flag --- was enabled when building the @build-env@ package. data AsyncSem - -- | Don't use any semaphore (not recommended). - = NoSem -- | Create a new 'Control.Concurrent.QSem.QSem' semaphore -- with the given number of tokens. - | NewQSem !Word16 + = NewQSem !Word16 + -- | Create a new system semaphore with the given number of tokens, + -- passing it to @ghc@ invocations. + | NewJSem !Word16 + -- | Use an existing system semaphore, passing it to @ghc@ invocations. + | ExistingJSem !String deriving stock Show -- | A description of the kind of semaphore we are using to control concurrency. semDescription :: AsyncSem -> Text semDescription = \case - NoSem -> "no semaphore" NewQSem i -> "-j" <> Text.pack (show i) + NewJSem i -> "--jsem " <> Text.pack (show i) + ExistingJSem jsemName -> + "--jsem " <> Text.pack jsemName -------------------------------------------------------------------------------- -- Arguments @@ -150,7 +156,7 @@ -- GHC & cabal-install -- | Path to the @cabal-install@ executable. -data Cabal = Cabal { cabalPath :: !FilePath +data Cabal = Cabal { cabalPath :: !( AbsolutePath File ) , globalCabalArgs :: !Args -- ^ Arguments to pass to all @cabal@ invocations, -- before any @cabal@ command. @@ -159,12 +165,19 @@ -- | Paths to the @ghc@ and @ghc-pkg@ executables. data Compiler = - Compiler { ghcPath :: !FilePath - , ghcPkgPath :: !FilePath + Compiler { ghcPath :: !( AbsolutePath File ) + , ghcPkgPath :: !( AbsolutePath File ) } deriving stock Show -------------------------------------------------------------------------------- +-- Cabal Hackage index state + +-- | Hackage index-state specification, e.g. 2022-12-25T00:00:00Z. +newtype IndexState = IndexState Text + deriving newtype ( Show, Eq ) + +-------------------------------------------------------------------------------- -- Directory structure -- | The directory structure relevant to preparing and carrying out @@ -172,7 +185,7 @@ type Paths :: PathUsability -> Type data Paths use = Paths - { fetchDir :: !FilePath + { fetchDir :: !( SymbolicPath Project ( Dir Fetch ) ) -- ^ Input fetched sources directory. , buildPaths :: BuildPaths use -- ^ Output build directory structure. @@ -181,36 +194,39 @@ -- a shell script that uses variables. } +deriving stock instance Show ( BuildPaths use ) => Show ( Paths use ) + -- | The directory structure relevant to executing a build plan. type BuildPaths :: PathUsability -> Type data family BuildPaths use data instance BuildPaths Raw = RawBuildPaths - { rawDestDir :: !FilePath + { rawDestDir :: !( SymbolicPath Project ( Dir Install ) ) -- ^ Raw output build @destdir@ (might be relative). - , rawPrefix :: !FilePath + , rawPrefix :: !( SymbolicPath Project ( Dir Prefix ) ) -- ^ Raw output build @prefix@ (might be relative). } + deriving stock Show data instance BuildPaths ForPrep = BuildPathsForPrep { compilerForPrep :: !Compiler -- ^ Which @ghc@ and @ghc-pkg@ to use. - , installDir :: !FilePath + , installDir :: !( AbsolutePath ( Dir Install ) ) -- ^ Output installation directory @destdir/prefix@ (absolute). } + deriving stock Show data instance BuildPaths ForBuild = BuildPaths { compiler :: !Compiler -- ^ Which @ghc@ and @ghc-pkg@ to use. - , destDir :: !FilePath - -- ^ Output build @destdir@ (absolute). - , prefix :: !FilePath + , prefix :: !( AbsolutePath ( Dir Prefix ) ) -- ^ Output build @prefix@ (absolute). - , installDir :: !FilePath + , installDir :: !( AbsolutePath ( Dir Install ) ) -- ^ Output installation directory @destdir/prefix@ (absolute). - , logDir :: !FilePath + , logDir :: !( AbsolutePath ( Dir Logs ) ) -- ^ Directory in which to put logs. } + deriving stock Show -- | The appropriate stage at which to use a filepath. data PathUsability @@ -229,54 +245,59 @@ -- for preparing and executing a build, respectively. canonicalizePaths :: Compiler -> BuildStrategy + -> SymbolicPath CWD ( Dir Project) -> Paths Raw -> IO ( Paths ForPrep, Paths ForBuild ) -canonicalizePaths compiler buildStrat +canonicalizePaths compiler buildStrat workDir ( Paths - { fetchDir = fetchDir0 + { fetchDir = fetchDir , buildPaths = RawBuildPaths { rawPrefix, rawDestDir } } ) = do - fetchDir <- canonicalizePath fetchDir0 - prefix <- canonicalizePath rawPrefix - destDir <- canonicalizePath rawDestDir - installDir <- canonicalizePath ( rawDestDir </> dropDrive prefix ) - -- We must use dropDrive here. Quoting from the documentation of (</>): - -- - -- If the second path starts with a path separator or a drive letter, - -- then (</>) returns the second path. - -- - -- We don't want that, as we *do* want to concatenate both paths. + prefix <- makeAbsolute workDir rawPrefix + installDir <- makeAbsolute workDir ( mkInstallDir rawDestDir prefix ) + logDir <- case buildStrat of - Script {} -> return "${LOGDIR}" -- LOGDIR is defined by the script. + Script {} -> return $ mkAbsolutePath "${LOGDIR}" -- LOGDIR is defined by the script. Execute {} -> do -- Pick the logging directory based on the current time. time <- getCurrentTime - let logDir = "logs" </> formatTime defaultTimeLocale "%0Y-%m-%d_%H-%M-%S" time - canonicalizePath logDir + makeAbsolute workDir + ( mkSymbolicPath $ "logs" </> formatTime defaultTimeLocale "%0Y-%m-%d_%H-%M-%S" time ) let forBuild = case buildStrat of Script { useVariables } | useVariables - -> Paths { fetchDir = "${SOURCES}" + -> Paths { fetchDir = mkSymbolicPath "${SOURCES}" , buildPaths = BuildPaths - { prefix = "${PREFIX}" - , destDir = "${DESTDIR}" - , installDir = "${DESTDIR}" </> "${PREFIX}" + { prefix = mkAbsolutePath "${PREFIX}" + , installDir = mkAbsolutePath $ "${DESTDIR}" </> "${PREFIX}" , logDir , compiler = - Compiler { ghcPath = "${GHC}" - , ghcPkgPath = "${GHCPKG}" } } } + Compiler { ghcPath = mkAbsolutePath "${GHC}" + , ghcPkgPath = mkAbsolutePath "${GHCPKG}" } } } _don'tUseVars -> Paths { fetchDir , buildPaths = - BuildPaths { compiler, destDir, prefix, installDir, logDir } } + BuildPaths { compiler, prefix, installDir, logDir } } return $ ( Paths { fetchDir , buildPaths = BuildPathsForPrep { compilerForPrep = compiler, installDir } } , forBuild ) + +mkInstallDir :: SymbolicPath Project ( Dir Install ) + -> AbsolutePath ( Dir Prefix ) + -> SymbolicPath Project ( Dir Install ) +mkInstallDir destDir prefix = + destDir </> mkRelativePath ( dropDrive $ getAbsolutePath prefix ) + -- We must use dropDrive here. Quoting from the documentation of (</>): + -- + -- If the second path starts with a path separator or a drive letter, + -- then (</>) returns the second path. + -- + -- We don't want that, as we *do* want to concatenate both paths. -- | How to handle deletion of temporary directories. data TempDirPermanence
src/BuildEnv/File.hs view
@@ -54,7 +54,7 @@ outsideStanza pkgs [] = pkgs outsideStanza pkgs (l:ls) - | Just rest <- Text.stripPrefix "constraints:" l + | Just rest <- Text.strip <$> Text.stripPrefix "constraints:" l = inConstraintsStanza (pkgs `addPkgFromLine` rest) ls | otherwise = outsideStanza pkgs ls @@ -86,8 +86,7 @@ , validPackageName pkg = ( PkgName pkg, parsePkgSpec rest ) | otherwise - = error $ "Invalid package in cabal.config file : " <> Text.unpack txt - where + = error $ "Invalid package in cabal.config file: " <> Text.unpack txt -- NB: update the readme after changing the documentation below.
+ src/BuildEnv/Path.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE UndecidableInstances #-} + +module BuildEnv.Path + ( SymbolicPath, RelativePath, AbsolutePath + , FileOrDir(..) + , CWD, Pkg, PkgDb, Project + , Tmp, Logs, Fetch, Prefix, Install + + , sameDirectory + , mkSymbolicPath + , mkRelativePath + , mkAbsolutePath + + , interpretSymbolicPath + , getSymbolicPath + , getAbsolutePath + , absoluteSymbolicPath + , makeAbsolute + + , (<.>), (</>) + ) + where + +-- base +import Data.Kind + ( Type ) + +-- directory +import qualified System.Directory as Directory + +-- filepath +import qualified System.FilePath as FilePath + +-------------------------------------------------------------------------------- + +-- | A type-level symbolic name, to an abstract file or directory +-- (e.g. the Cabal package directory). +data FileOrDir + = -- | A file (with no further information). + File + | -- | The abstract name of a directory or category of directories, + -- e.g. the package directory or a source directory. + Dir Type + +-- | Is this symbolic path allowed to be absolute, or must it be relative? +data AllowAbsolute + = -- | The path may be absolute, or it may be relative. + AllowAbsolute + | -- | The path must be relative. + OnlyRelative + +-- | A symbolic path, possibly relative to an abstract location specified +-- by the @from@ type parameter. +-- +-- They are *symbolic*, which means we cannot perform any 'IO' +-- until we interpret them (using e.g. 'interpretSymbolicPath'). +type SymbolicPathX :: AllowAbsolute -> Type -> FileOrDir -> Type +newtype SymbolicPathX allowAbsolute from to = SymbolicPath FilePath + deriving newtype Show +type role SymbolicPathX nominal nominal nominal + +-- | A symbolic relative path, relative to an abstract location specified +-- by the @from@ type parameter. +-- +-- They are *symbolic*, which means we cannot perform any 'IO' +-- until we interpret them (using e.g. 'interpretSymbolicPath'). +type RelativePath = SymbolicPathX 'OnlyRelative + +-- | A path which is either absolute or relative to the given abstract* +-- location specified by the @from@ type parameter. +-- +-- They are *symbolic*, which means we cannot perform any 'IO' +-- until we interpret them (using e.g. 'interpretSymbolicPath'). +type SymbolicPath = SymbolicPathX 'AllowAbsolute + +-- | An absolute path, or a reference to a path from the PATH environment variable. +type AbsolutePath :: FileOrDir -> Type +newtype AbsolutePath to = AbsolutePath ( forall from. SymbolicPath from to ) +instance Show ( AbsolutePath to ) where + show ( AbsolutePath fp ) = show fp + +-------------------------------------------------------------------------------- + +-- | Abstract directory: current working directory. +data CWD + +-- | Abstract directory: project root for 'build-env' commands. +data Project + +-- | Abstract directory: package directory (e.g. a directory containing the @.cabal@ file). +data Pkg + +-- | Abstract directory: package database directory (e.g. a directory containing a @package.conf@ file). +data PkgDb + +-- | Abstract temporary directory. +data Tmp + +-- | Abstract directory for logs. +data Logs + +-- | Abstract directory: fetched sources directory. +data Fetch + +-- | Abstract directory: prefix. +data Prefix + +-- | Abstract directory: installation directory. +data Install + +-------------------------------------------------------------------------------- + +mkSymbolicPath :: FilePath -> SymbolicPath from to +mkSymbolicPath = SymbolicPath + +mkRelativePath :: FilePath -> RelativePath from to +mkRelativePath = SymbolicPath + +mkAbsolutePath :: FilePath -> AbsolutePath to +mkAbsolutePath fp = AbsolutePath ( mkSymbolicPath fp ) + +sameDirectory :: SymbolicPathX allowAbsolute from to +sameDirectory = SymbolicPath "." + +getSymbolicPath :: SymbolicPathX allowAbsolute from to -> FilePath +getSymbolicPath ( SymbolicPath p ) = p + +getAbsolutePath :: AbsolutePath to -> FilePath +getAbsolutePath ( AbsolutePath p ) = getSymbolicPath p + +absoluteSymbolicPath :: AbsolutePath to -> SymbolicPath from to +absoluteSymbolicPath ( AbsolutePath p ) = p + +-- | Interpret a symbolic path with respect to the given directory. +-- +-- Use this function before directly interacting with the file system in order +-- to take into account a working directory argument. +interpretSymbolicPath :: SymbolicPath CWD ( Dir dir ) -> SymbolicPathX allowAbsolute dir to -> FilePath +interpretSymbolicPath ( SymbolicPath workDir ) ( SymbolicPath p ) = + if workDir == "." + then p -- NB: this just avoids creating paths of the form "./././blah". + else workDir </> p + -- Note that this properly handles an absolute symbolic path, + -- because if @q@ is absolute, then @p </> q = q@. + +-- | Make the given 'SymbolicPath' absolute. +makeAbsolute :: SymbolicPath CWD ( Dir dir ) -> SymbolicPath dir to -> IO ( AbsolutePath to ) +makeAbsolute workDir path = + mkAbsolutePath <$> Directory.makeAbsolute ( interpretSymbolicPath workDir path ) + +------------------------------------------------------------------------------- + +-- * Composition + +------------------------------------------------------------------------------- + +infixr 7 <.> + +-- | Types that support 'System.FilePath.<.>'. +class FileLike p where + -- | Like 'System.FilePath.<.>', but also supporting symbolic paths. + (<.>) :: p -> String -> p + +instance FileLike FilePath where + (<.>) = (FilePath.<.>) + +instance p ~ File => FileLike ( SymbolicPathX allowAbsolute dir p ) where + SymbolicPath p <.> ext = SymbolicPath ( p <.> ext ) + +instance p ~ File => FileLike ( AbsolutePath p ) where + p <.> ext = mkAbsolutePath ( getAbsolutePath p <.> ext ) + +infixr 5 </> + +-- | Types that support 'System.FilePath.</>'. +class PathLike p q r | q r -> p, p q -> r where + -- | Like 'System.FilePath.</>', but also supporting symbolic paths. + (</>) :: p -> q -> r + +instance ( q ~ FilePath ) => PathLike FilePath q FilePath where + (</>) = (FilePath.</>) + +-- | This instance ensures we don't accidentally discard a symbolic path +-- in a 'System.FilePath.</>' operation due to the second path being absolute. +-- +-- (Recall that @a </> b = b@ whenever @b@ is absolute.) +instance + (b1 ~ 'Dir b2, a3 ~ a1, c2 ~ c3) + => PathLike + ( SymbolicPathX allowAbsolute a1 b1 ) + ( SymbolicPathX midAbsolute b2 c2 ) + ( SymbolicPathX allowAbsolute a3 c3 ) + where + SymbolicPath p1 </> SymbolicPath p2 = + if p1 == "." + then SymbolicPath p2 -- NB: this just avoids creating paths of the form "./././blah". + else SymbolicPath (p1 </> p2) + +instance + ( b1 ~ 'Dir b2, c2 ~ c3, midAbsolute ~ OnlyRelative ) + => PathLike + ( AbsolutePath b1 ) + ( SymbolicPathX midAbsolute b2 c2 ) + ( AbsolutePath c3 ) + where + AbsolutePath (SymbolicPath p1) </> SymbolicPath p2 = + mkAbsolutePath (p1 </> p2)
src/BuildEnv/Script.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : BuildEnv.Script @@ -30,7 +34,8 @@ -- ** Individual build steps , BuildStep(..), BuildSteps , step - , callProcess, createDir, logMessage, reportProgress + , callProcess, createDir + , logMessage, reportProgress -- ** Configuring build scripts , ScriptOutput(..), ScriptConfig(..), hostRunCfg @@ -58,10 +63,6 @@ import System.Directory ( createDirectoryIfMissing ) --- filepath -import System.FilePath - ( (<.>) ) - -- text import Data.Text ( Text ) @@ -78,6 +79,7 @@ ( Verbosity(..), Counter(..), Style(..) , hostStyle ) +import BuildEnv.Path import BuildEnv.Utils ( ProgPath(..), CallProcess(..), callProcessInIO ) @@ -120,9 +122,9 @@ -- | A build step. data BuildStep -- | Call a processs with the given arguments. - = CallProcess CallProcess + = forall dir. CallProcess ( CallProcess dir ) -- | Create the given directory. - | CreateDir FilePath + | forall dir. CreateDir ( AbsolutePath ( Dir dir ) ) -- | Log a message to @stdout@. | LogMessage String -- | Report one unit of progress. @@ -136,11 +138,11 @@ step s = BuildScript $ ReaderT \ _ -> tell [s] -- | Call a process with given arguments. -callProcess :: CallProcess -> BuildScript +callProcess :: CallProcess dir -> BuildScript callProcess = step . CallProcess -- | Create the given directory. -createDir :: FilePath -> BuildScript +createDir :: AbsolutePath ( Dir dir ) -> BuildScript createDir = step . CreateDir -- | Log a message. @@ -185,22 +187,29 @@ -- -- - add quotes around command-line arguments? -- - add @./@ to run an executable in the current working directory? + + , scriptWorkingDir :: !( SymbolicPath CWD ( Dir Project ) ) + -- ^ Working directory for the script. + , scriptStyle :: !Style -- ^ Whether to use Posix or Windows style conventions. See 'Style'. - , scriptTotal :: !(Maybe Word) + , scriptTotal :: !( Maybe Word ) -- ^ Optional: the total number of units we are building; -- used to report progress. } -- | Configure a script to run on the host (in @IO@). -hostRunCfg :: Maybe Word -- ^ Optional: total to report progress against. +hostRunCfg :: SymbolicPath CWD ( Dir Project ) + -> Maybe Word -- ^ Optional: total to report progress against. -> ScriptConfig -hostRunCfg mbTotal = +hostRunCfg workDir mbTotal = ScriptConfig - { scriptOutput = Run - , scriptStyle = hostStyle - , scriptTotal = mbTotal } + { scriptOutput = Run + , scriptStyle = hostStyle + , scriptTotal = mbTotal + , scriptWorkingDir = workDir + } -- | Whether to expand or escape variables in a shell script. data EscapeVars @@ -212,7 +221,7 @@ -- | Quote a string, to avoid spaces causing the string -- to be interpreted as multiple arguments. -q :: ( IsString r, Monoid r ) => EscapeVars-> String -> r +q :: ( IsString r, Monoid r ) => EscapeVars -> String -> r q escapeVars t = "\"" <> fromString ( escapeArg t ) <> "\"" where escapeArg :: String -> String @@ -252,12 +261,13 @@ -- IO -- | Execute a 'BuildScript' in the 'IO' monad. -executeBuildScript :: Maybe Counter -- ^ Optional counter to use to report progress. +executeBuildScript :: SymbolicPath CWD ( Dir Project ) -- ^ Working directory. + -> Maybe Counter -- ^ Optional counter to use to report progress. -> BuildScript -- ^ The build script to execute. -> IO () -executeBuildScript counter +executeBuildScript workDir counter = traverse_ ( executeBuildStep counter ) - . buildSteps ( hostRunCfg $ fmap counterMax counter ) + . buildSteps ( hostRunCfg workDir $ fmap counterMax counter ) -- | Execute a single 'BuildStep' in the 'IO' monad. executeBuildStep :: Maybe Counter @@ -266,7 +276,7 @@ -> IO () executeBuildStep mbCounter = \case CallProcess cp -> callProcessInIO mbCounter cp - CreateDir dir -> createDirectoryIfMissing True dir + CreateDir dir -> createDirectoryIfMissing True ( getAbsolutePath dir ) LogMessage msg -> do { putStrLn msg ; hFlush System.stdout } ReportProgress { outputProgress } -> for_ mbCounter \ counter -> do @@ -293,7 +303,8 @@ Text.unlines ( header ++ concatMap ( stepScript scriptCfg ) ( buildSteps scriptCfg buildScript ) ) where header, varsHelper, progressVars :: [ Text ] - header = [ "#!/bin/bash" , "" ] ++ varsHelper ++ logDir ++ progressVars + header = [ "#!/bin/bash" , "", "set -ueo pipefail" ] ++ + varsHelper ++ logDir ++ progressVars varsHelper | Shell { useVariables } <- scriptOutput scriptCfg , useVariables @@ -305,14 +316,14 @@ Nothing -> [] Just {} -> [ "buildEnvProgress=0" ] - logDir = [ "LOGDIR=\"$PWD/logs/$(date --utc +%Y-%m-%d_%H-%M-%S)\"" + logDir = [ "LOGDIR=\"$PWD/logs/$(date -u +%Y-%m-%d_%H-%M-%S)\"" , "mkdir -p \"${LOGDIR}\"" ] -- | The underlying script of a build step. stepScript :: ScriptConfig -> BuildStep -> [ Text ] stepScript scriptCfg = \case CreateDir dir -> - [ "mkdir -p " <> q ExpandVars dir ] + [ "mkdir -p " <> q ExpandVars ( getAbsolutePath dir ) ] LogMessage str -> [ "echo " <> q ExpandVars str ] ReportProgress { outputProgress } -> @@ -337,7 +348,7 @@ -- NB: we ignore the semaphore, as the build scripts we produce -- are inherently sequential. logCommand ++ - [ "( cd " <> q ExpandVars cwd <> " ; \\" ] + [ "( cd " <> q ExpandVars ( getSymbolicPath cwd ) <> " ; \\" ] ++ mbUpdatePath ++ map mkEnvVar extraEnvVars ++ @@ -349,7 +360,7 @@ , " echo -e " <> "\"callProcess failed with non-zero exit code. Command:\\n" <> " > " <> unquote cmd <> "\\n" <> - " CWD = " <> unquote (q ExpandVars cwd) <> "\"" + " CWD = " <> unquote ( q ExpandVars ( getSymbolicPath cwd ) ) <> "\"" <> logErr ] ++ progressReport @@ -358,9 +369,13 @@ [ " exit \"${" <> resVar <> "}\"" , "fi" ] where + progPath :: FilePath + progPath = case prog of + AbsPath p -> getAbsolutePath p + RelPath p -> getSymbolicPath p cmd :: Text - cmd = q ExpandVars ( progPath prog ) <> " " <> Text.unwords (map Text.pack args) - -- (1) (2) + cmd = q ExpandVars progPath <> " " <> Text.unwords (map Text.pack args) + -- (1) (2) -- -- (1) -- In shell scripts, we always change directory before running the @@ -385,7 +400,7 @@ = [] | otherwise = [ " export PATH=$PATH:" - <> Text.intercalate ":" (map Text.pack extraPATH) -- (already quoted) + <> Text.intercalate ":" ( map Text.pack extraPATH ) -- (already quoted) <> " ; \\" ] mkEnvVar :: (String, String) -> Text @@ -401,14 +416,14 @@ Nothing -> ( [], "", " >&2", [] ) Just logPath -> let stdoutFile, stderrFile :: Text - stdoutFile = q ExpandVars ( logPath <.> "stdout" ) - stderrFile = q ExpandVars ( logPath <.> "stderr" ) + stdoutFile = q ExpandVars ( getAbsolutePath logPath <.> "stdout" ) + stderrFile = q ExpandVars ( getAbsolutePath logPath <.> "stderr" ) in ( [ "echo \"> " <> unquote cmd <> "\" >> " <> stdoutFile ] - , " > " <> stdoutFile <> " 2> >( tee -a " <> stderrFile <> " >&2 )" + , " 2>&1 >" <> stdoutFile <> " | tee -a " <> stderrFile -- Write stdout to the stdout log file. -- Write stderr both to the terminal and to the stderr log file. , " | tee -a " <> stderrFile <> " >&2" - , [ " echo \"Logs are available at: " <> unquote ( q ExpandVars ( logPath <> ".{stdout,stderr}" ) ) <> "\"" ] ) + , [ " echo \"Logs are available at: " <> unquote ( q ExpandVars ( getAbsolutePath logPath <> ".{stdout,stderr}" ) ) <> "\"" ] ) progressReport :: [Text] progressReport =
src/BuildEnv/Utils.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -18,11 +20,12 @@ ProgPath(..), CallProcess(..), callProcessInIO -- * Create temporary directories - , TempDirPermanence(..), withTempDir + , TempDirPermanence(..) + , withTempDir -- * Abstract semaphores , AbstractSem(..) - , newAbstractSem, noSem, abstractQSem + , withNewAbstractSem, noSem, abstractQSem -- * Other utilities , splitOn @@ -33,11 +36,13 @@ import Control.Concurrent.QSem ( QSem, newQSem, signalQSem, waitQSem ) import Control.Exception - ( bracket_ ) + ( bracket, bracket_ ) +import Data.Kind + ( Type ) import Data.List ( intercalate ) import Data.Maybe - ( fromMaybe ) + ( maybeToList ) import Data.IORef ( readIORef ) import System.Environment @@ -61,15 +66,23 @@ -- directory import System.Directory - ( createDirectoryIfMissing, makeAbsolute ) + ( createDirectoryIfMissing ) -- filepath import System.FilePath - ( (</>), (<.>), takeDirectory ) + ( takeDirectory ) -- process import qualified System.Process as Proc +-- semaphore-compat +import qualified System.Semaphore as System + ( Semaphore(..), SemaphoreName(..) + , freshSemaphore, openSemaphore + , destroySemaphore + , waitOnSemaphore, releaseSemaphore + ) + -- temporary import System.IO.Temp ( createTempDirectory @@ -79,35 +92,39 @@ -- build-env import BuildEnv.Config - ( AsyncSem(..), Args, TempDirPermanence(..), Counter(..) + ( Args, AsyncSem(..) + , Counter(..) + , TempDirPermanence(..) , pATHSeparator, hostStyle ) +import BuildEnv.Path -------------------------------------------------------------------------------- -- | The path of a program to run. -data ProgPath +type ProgPath :: Type -> Type +data ProgPath from -- | An absolute path, or an executable in @PATH@. - = AbsPath { progPath :: !FilePath } - -- | A relative path. What it is relative to depends on context. - | RelPath { progPath :: !FilePath } + = AbsPath { absProgPath :: !( AbsolutePath File ) } + -- | A relative path, relative to the @from@ abstract location. + | RelPath { relProgPath :: !( SymbolicPath from File ) } -- | Arguments to 'callProcess'. -data CallProcess +data CallProcess dir = CP - { cwd :: !FilePath + { cwd :: !( SymbolicPath CWD ( Dir dir ) ) -- ^ Working directory. - , extraPATH :: ![FilePath] + , extraPATH :: ![ FilePath ] -- ^ Absolute filepaths to add to PATH. - , extraEnvVars :: ![(String, String)] - -- ^ Extra envi!ronment variables to add before running the command. - , prog :: !ProgPath + , extraEnvVars :: ![ ( String, String ) ] + -- ^ Extra environment variables to add before running the command. + , prog :: !( ProgPath dir ) -- ^ The program to run. -- -- If it's a relative path, it should be relative to the @cwd@ field. , args :: !Args -- ^ Arguments to the program. - , logBasePath :: !( Maybe FilePath ) + , logBasePath :: !( Maybe ( AbsolutePath File ) ) -- ^ Log @stdout@ to @basePath.stdout@ and @stderr@ to @basePath.stderr@. , sem :: !AbstractSem -- ^ Lock to take when calling the process @@ -124,13 +141,13 @@ => Maybe Counter -- ^ Optional counter. Used when the command fails, -- to report the progress that has been made so far. - -> CallProcess + -> CallProcess dir -> IO () callProcessInIO mbCounter ( CP { cwd, extraPATH, extraEnvVars, prog, args, logBasePath, sem } ) = do absProg <- case prog of AbsPath p -> return p - RelPath p -> makeAbsolute $ cwd </> p + RelPath p -> makeAbsolute cwd p -- Needs to be an absolute path, as per the @process@ documentation: -- -- If cwd is provided, it is implementation-dependent whether @@ -144,8 +161,8 @@ | null args = "" | otherwise = " " ++ unwords args command = - [ " > " ++ absProg ++ argsStr - , " CWD = " ++ cwd ] + [ " > " ++ show absProg ++ argsStr + , " CWD = " ++ show cwd ] env <- if null extraPATH && null extraEnvVars then return Nothing @@ -159,17 +176,17 @@ Just logPath -> do let stdoutFile = logPath <.> "stdout" stderrFile = logPath <.> "stderr" - createDirectoryIfMissing True $ takeDirectory logPath - withFile stdoutFile AppendMode \ stdoutFileHandle -> - withFile stderrFile AppendMode \ stderrFileHandle -> do + createDirectoryIfMissing True $ takeDirectory $ getAbsolutePath logPath + withFile ( getAbsolutePath stdoutFile ) AppendMode \ stdoutFileHandle -> + withFile ( getAbsolutePath stderrFile ) AppendMode \ stderrFileHandle -> do hDuplicateTo System.Handle.stderr stderrFileHandle -- Write stderr to the log file and to the terminal. hPutStrLn stdoutFileHandle ( unlines command ) action ( Proc.UseHandle stdoutFileHandle, Proc.UseHandle stderrFileHandle ) withHandles \ ( stdoutStream, stderrStream ) -> do let processArgs = - ( Proc.proc absProg args ) - { Proc.cwd = if cwd == "." then Nothing else Just cwd + ( Proc.proc ( getAbsolutePath absProg ) args ) + { Proc.cwd = if getSymbolicPath cwd == "." then Nothing else Just ( getSymbolicPath cwd ) , Proc.env = env , Proc.std_out = stdoutStream , Proc.std_err = stderrStream } @@ -191,7 +208,7 @@ case stderrStream of Proc.UseHandle errHandle -> hPutStrLn errHandle - ( unlines $ msg ++ [ "Logs are available at: " <> fromMaybe "" logBasePath <> ".{stdout, stderr}" ] ) + ( unlines $ msg ++ [ "Logs are available at: " <> getAbsolutePath logs <> ".{stdout, stderr}" | logs <- maybeToList logBasePath ] ) _ -> putStrLn (unlines msg) exitWith res @@ -208,15 +225,15 @@ withTempDir :: TempDirPermanence -- ^ whether to delete the temporary directory -- after the action completes -> String -- ^ directory name template - -> (FilePath -> IO a) -- ^ action to perform + -> ( AbsolutePath ( Dir Tmp ) -> IO a ) -- ^ action to perform -> IO a withTempDir del name k = case del of DeleteTempDirs - -> withSystemTempDirectory name k + -> withSystemTempDirectory name ( k . mkAbsolutePath ) Don'tDeleteTempDirs -> do root <- getCanonicalTemporaryDirectory - createTempDirectory root name >>= k + createTempDirectory root name >>= ( k . mkAbsolutePath ) -- | Utility list 'splitOn' function. splitOn :: Char -> String -> [String] @@ -235,19 +252,49 @@ AbstractSem { withAbstractSem :: forall r. IO r -> IO r } -- | Create a semaphore-based acquire/release mechanism. -newAbstractSem :: AsyncSem -> IO AbstractSem -newAbstractSem whatSem = +withNewAbstractSem :: AsyncSem + -> ( AbstractSem -> Args -> IO r ) + -- ^ the abstract semaphore to use, and extra + -- arguments to pass to @Setup configure@ for @ghc@ + -> IO r +withNewAbstractSem whatSem f = case whatSem of - NoSem -> return noSem NewQSem n -> do qsem <- newQSem ( fromIntegral n ) - return $ abstractQSem qsem + f ( abstractQSem qsem ) [] + NewJSem n -> + bracket + ( System.freshSemaphore "buildEnvSemaphore" ( fromIntegral n ) ) + System.destroySemaphore + $ \ jsem -> do + let jsemName = System.semaphoreName jsem + f ( abstractJSem jsem ) [ jsemGhcArg jsemName ] + ExistingJSem jsemName -> do + let jsemNm = System.SemaphoreName jsemName + jsem <- System.openSemaphore jsemNm + f ( abstractJSem jsem ) [ jsemGhcArg jsemNm ] + where + jsemGhcArg :: System.SemaphoreName -> String + jsemGhcArg ( System.SemaphoreName jsemName ) = + "--ghc-option=-jsem=" <> jsemName +-- | No acquire/release mechanism required. +noSem :: AbstractSem +noSem = AbstractSem { withAbstractSem = id } + -- | Abstract acquire/release mechanism controlled by the given 'QSem'. abstractQSem :: QSem -> AbstractSem abstractQSem sem = - AbstractSem $ bracket_ (waitQSem sem) (signalQSem sem) + AbstractSem $ + bracket_ + ( waitQSem sem ) + ( signalQSem sem ) --- | No acquire/release mechanism required. -noSem :: AbstractSem -noSem = AbstractSem { withAbstractSem = id } +-- | Abstract acquire/release mechanism controlled by the given +-- system semaphore. +abstractJSem :: System.Semaphore -> AbstractSem +abstractJSem sem = + AbstractSem $ + bracket_ + ( System.waitOnSemaphore sem ) + ( System.releaseSemaphore sem 1 )