{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Types.Config
(
HasPlatform(..)
,PlatformVariant(..)
,HasRunner(..)
,Runner(..)
,ColorWhen(..)
,terminalL
,reExecL
,Config(..)
,HasConfig(..)
,askLatestSnapshotUrl
,explicitSetupDeps
,configProjectRoot
,BuildConfig(..)
,ProjectPackage(..)
,DepPackage(..)
,ppRoot
,ppVersion
,ppComponents
,ppGPD
,stackYamlL
,projectRootL
,HasBuildConfig(..)
,UserStorage(..)
,ProjectStorage(..)
,GHCVariant(..)
,ghcVariantName
,ghcVariantSuffix
,parseGHCVariant
,HasGHCVariant(..)
,snapshotsDir
,EnvConfig(..)
,HasSourceMap(..)
,HasEnvConfig(..)
,getCompilerPath
,ApplyGhcOptions(..)
,CabalConfigKey(..)
,HpackExecutable(..)
,ConfigException(..)
,ConfigMonoid(..)
,configMonoidInstallGHCName
,configMonoidSystemGHCName
,parseConfigMonoid
,DumpLogs(..)
,EnvSettings(..)
,minimalEnvSettings
,defaultEnvSettings
,plainEnvSettings
,GlobalOpts(..)
,GlobalOptsMonoid(..)
,StackYamlLoc(..)
,stackYamlLocL
,LockFileBehavior(..)
,readLockFileBehavior
,lockFileBehaviorL
,defaultLogLevel
,Project(..)
,ProjectConfig(..)
,Curator(..)
,ProjectAndConfigMonoid(..)
,parseProjectAndConfigMonoid
,PvpBounds(..)
,PvpBoundsType(..)
,parsePvpBounds
,readColorWhen
,readStyles
,SCM(..)
,bindirSuffix
,GlobalInfoSource(..)
,getProjectWorkDir
,docDirSuffix
,extraBinDirs
,hpcReportDir
,installationRootDeps
,installationRootLocal
,bindirCompilerTools
,hoogleRoot
,hoogleDatabasePath
,packageDatabaseDeps
,packageDatabaseExtra
,packageDatabaseLocal
,platformOnlyRelDir
,platformGhcRelDir
,platformGhcVerOnlyRelDir
,useShaPathOnWindows
,shaPath
,shaPathForBytes
,workDirL
,EvalOpts(..)
,ExecOpts(..)
,SpecialExecCmd(..)
,ExecOptsExtra(..)
,DownloadInfo(..)
,VersionedDownloadInfo(..)
,GHCDownloadInfo(..)
,SetupInfo(..)
,SetupInfoLocation(..)
,DockerEntrypoint(..)
,DockerUser(..)
,module X
,wantedCompilerVersionL
,actualCompilerVersionL
,HasCompiler(..)
,DumpPackage(..)
,CompilerPaths(..)
,GhcPkgExe(..)
,getGhcPkgExe
,cpWhich
,ExtraDirs(..)
,buildOptsL
,globalOptsL
,buildOptsInstallExesL
,buildOptsMonoidHaddockL
,buildOptsMonoidTestsL
,buildOptsMonoidBenchmarksL
,buildOptsMonoidInstallExesL
,buildOptsHaddockL
,globalOptsBuildOptsMonoidL
,stackRootL
,cabalVersionL
,whichCompilerL
,envOverrideSettingsL
,shouldForceGhcColorFlag
,appropriateGhcColorFlag
,view
,to
) where
import Control.Monad.Writer (tell)
import Crypto.Hash (hashWith, SHA1(..))
import Stack.Prelude
import Pantry.Internal.AesonExtended
(ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
(.=), (..:), (...:), (..:?), (..!=), Value(Bool),
withObjectWarnings, WarningParser, Object, jsonSubWarnings,
jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,
FromJSONKeyFunction (FromJSONKeyTextParser))
import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
import qualified Data.ByteString.Char8 as S8
import Data.Coerce (coerce)
import Data.List (stripPrefix)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import qualified Data.Monoid as Monoid
import Data.Monoid.Map (MonoidMap(..))
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml (ParseException)
import qualified Data.Yaml as Yaml
import qualified Distribution.License as C
import Distribution.ModuleName (ModuleName)
import Distribution.PackageDescription (GenericPackageDescription)
import qualified Distribution.PackageDescription as C
import Distribution.System (Platform, Arch)
import qualified Distribution.Text
import qualified Distribution.Types.UnqualComponentName as C
import Distribution.Version (anyVersion, mkVersion', mkVersion)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Lens.Micro (Lens', lens, _1, _2, to)
import Options.Applicative (ReadM)
import qualified Options.Applicative as OA
import qualified Options.Applicative.Types as OA
import Pantry.Internal (Storage)
import Path
import qualified Paths_stack as Meta
import qualified RIO.List as List
import RIO.PrettyPrint (HasTerm (..))
import RIO.PrettyPrint.StylesUpdate (StylesUpdate,
parseStylesUpdateFromString, HasStylesUpdate (..))
import Stack.Constants
import Stack.Types.Compiler
import Stack.Types.CompilerBuild
import Stack.Types.Docker
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Nix
import Stack.Types.Resolver
import Stack.Types.SourceMap
import Stack.Types.TemplateName
import Stack.Types.Version
import qualified System.FilePath as FilePath
import System.PosixCompat.Types (UserID, GroupID, FileMode)
import RIO.Process (ProcessContext, HasProcessContext (..))
import Stack.Types.Config.Build as X
data Runner = Runner
{ runnerGlobalOpts :: !GlobalOpts
, runnerUseColor :: !Bool
, runnerLogFunc :: !LogFunc
, runnerTermWidth :: !Int
, runnerProcessContext :: !ProcessContext
}
data ColorWhen = ColorNever | ColorAlways | ColorAuto
deriving (Eq, Show, Generic)
instance FromJSON ColorWhen where
parseJSON v = do
s <- parseJSON v
case s of
"never" -> return ColorNever
"always" -> return ColorAlways
"auto" -> return ColorAuto
_ -> fail ("Unknown color use: " <> s <> ". Expected values of " <>
"option are 'never', 'always', or 'auto'.")
data Config =
Config {configWorkDir :: !(Path Rel Dir)
,configUserConfigPath :: !(Path Abs File)
,configBuild :: !BuildOpts
,configDocker :: !DockerOpts
,configNix :: !NixOpts
,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext)
,configLocalProgramsBase :: !(Path Abs Dir)
,configLocalPrograms :: !(Path Abs Dir)
,configHideTHLoading :: !Bool
,configPlatform :: !Platform
,configPlatformVariant :: !PlatformVariant
,configGHCVariant :: !(Maybe GHCVariant)
,configGHCBuild :: !(Maybe CompilerBuild)
,configLatestSnapshot :: !Text
,configSystemGHC :: !Bool
,configInstallGHC :: !Bool
,configSkipGHCCheck :: !Bool
,configSkipMsys :: !Bool
,configCompilerCheck :: !VersionCheck
,configCompilerRepository :: !CompilerRepository
,configLocalBin :: !(Path Abs Dir)
,configRequireStackVersion :: !VersionRange
,configJobs :: !Int
,configOverrideGccPath :: !(Maybe (Path Abs File))
,configExtraIncludeDirs :: ![FilePath]
,configExtraLibDirs :: ![FilePath]
,configConcurrentTests :: !Bool
,configTemplateParams :: !(Map Text Text)
,configScmInit :: !(Maybe SCM)
,configGhcOptionsByName :: !(Map PackageName [Text])
,configGhcOptionsByCat :: !(Map ApplyGhcOptions [Text])
,configCabalConfigOpts :: !(Map CabalConfigKey [Text])
,configSetupInfoLocations :: ![SetupInfoLocation]
,configPvpBounds :: !PvpBounds
,configModifyCodePage :: !Bool
,configExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configRebuildGhcOptions :: !Bool
,configApplyGhcOptions :: !ApplyGhcOptions
,configAllowNewer :: !Bool
,configDefaultTemplate :: !(Maybe TemplateName)
,configAllowDifferentUser :: !Bool
,configDumpLogs :: !DumpLogs
,configProject :: !(ProjectConfig (Project, Path Abs File))
,configAllowLocals :: !Bool
,configSaveHackageCreds :: !Bool
,configHackageBaseUrl :: !Text
,configRunner :: !Runner
,configPantryConfig :: !PantryConfig
,configStackRoot :: !(Path Abs Dir)
,configResolver :: !(Maybe AbstractResolver)
,configUserStorage :: !UserStorage
,configHideSourcePaths :: !Bool
,configRecommendUpgrade :: !Bool
}
newtype UserStorage = UserStorage
{ unUserStorage :: Storage
}
newtype ProjectStorage = ProjectStorage
{ unProjectStorage :: Storage
}
configProjectRoot :: Config -> Maybe (Path Abs Dir)
configProjectRoot c =
case configProject c of
PCProject (_, fp) -> Just $ parent fp
PCGlobalProject -> Nothing
PCNoProject _deps -> Nothing
data CabalConfigKey
= CCKTargets
| CCKLocals
| CCKEverything
| CCKPackage !PackageName
deriving (Show, Read, Eq, Ord)
instance FromJSON CabalConfigKey where
parseJSON = withText "CabalConfigKey" parseCabalConfigKey
instance FromJSONKey CabalConfigKey where
fromJSONKey = FromJSONKeyTextParser parseCabalConfigKey
parseCabalConfigKey :: Monad m => Text -> m CabalConfigKey
parseCabalConfigKey "$targets" = pure CCKTargets
parseCabalConfigKey "$locals" = pure CCKLocals
parseCabalConfigKey "$everything" = pure CCKEverything
parseCabalConfigKey name =
case parsePackageName $ T.unpack name of
Nothing -> fail $ "Invalid CabalConfigKey: " ++ show name
Just x -> pure $ CCKPackage x
data ApplyGhcOptions = AGOTargets
| AGOLocals
| AGOEverything
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON ApplyGhcOptions where
parseJSON = withText "ApplyGhcOptions" $ \t ->
case t of
"targets" -> return AGOTargets
"locals" -> return AGOLocals
"everything" -> return AGOEverything
_ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
data DumpLogs
= DumpNoLogs
| DumpWarningLogs
| DumpAllLogs
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON DumpLogs where
parseJSON (Bool True) = return DumpAllLogs
parseJSON (Bool False) = return DumpNoLogs
parseJSON v =
withText
"DumpLogs"
(\t ->
if | t == "none" -> return DumpNoLogs
| t == "warning" -> return DumpWarningLogs
| t == "all" -> return DumpAllLogs
| otherwise -> fail ("Invalid DumpLogs: " ++ show t))
v
data EnvSettings = EnvSettings
{ esIncludeLocals :: !Bool
, esIncludeGhcPackagePath :: !Bool
, esStackExe :: !Bool
, esLocaleUtf8 :: !Bool
, esKeepGhcRts :: !Bool
}
deriving (Show, Eq, Ord)
data ExecOpts = ExecOpts
{ eoCmd :: !SpecialExecCmd
, eoArgs :: ![String]
, eoExtra :: !ExecOptsExtra
} deriving (Show)
data SpecialExecCmd
= ExecCmd String
| ExecRun
| ExecGhc
| ExecRunGhc
deriving (Show, Eq)
data ExecOptsExtra = ExecOptsExtra
{ eoEnvSettings :: !EnvSettings
, eoPackages :: ![String]
, eoRtsOptions :: ![String]
, eoCwd :: !(Maybe FilePath)
}
deriving (Show)
data EvalOpts = EvalOpts
{ evalArg :: !String
, evalExtra :: !ExecOptsExtra
} deriving (Show)
data GlobalOpts = GlobalOpts
{ globalReExecVersion :: !(Maybe String)
, globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
, globalLogLevel :: !LogLevel
, globalTimeInLog :: !Bool
, globalConfigMonoid :: !ConfigMonoid
, globalResolver :: !(Maybe AbstractResolver)
, globalCompiler :: !(Maybe WantedCompiler)
, globalTerminal :: !Bool
, globalStylesUpdate :: !StylesUpdate
, globalTermWidth :: !(Maybe Int)
, globalStackYaml :: !StackYamlLoc
, globalLockFileBehavior :: !LockFileBehavior
} deriving (Show)
data StackYamlLoc
= SYLDefault
| SYLOverride !(Path Abs File)
| SYLNoProject ![PackageIdentifierRevision]
| SYLGlobalProject
deriving Show
stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc
stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })
data LockFileBehavior
= LFBReadWrite
| LFBReadOnly
| LFBIgnore
| LFBErrorOnWrite
deriving (Show, Enum, Bounded)
lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior
lockFileBehaviorL = globalOptsL.to globalLockFileBehavior
readLockFileBehavior :: ReadM LockFileBehavior
readLockFileBehavior = do
s <- OA.readerAsk
case Map.lookup s m of
Just x -> pure x
Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " ++
List.intercalate ", " (Map.keys m)
where
m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]
render LFBReadWrite = "read-write"
render LFBReadOnly = "read-only"
render LFBIgnore = "ignore"
render LFBErrorOnWrite = "error-on-write"
data ProjectConfig a
= PCProject a
| PCGlobalProject
| PCNoProject ![PackageIdentifierRevision]
data GlobalOptsMonoid = GlobalOptsMonoid
{ globalMonoidReExecVersion :: !(First String)
, globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)
, globalMonoidLogLevel :: !(First LogLevel)
, globalMonoidTimeInLog :: !FirstTrue
, globalMonoidConfigMonoid :: !ConfigMonoid
, globalMonoidResolver :: !(First (Unresolved AbstractResolver))
, globalMonoidResolverRoot :: !(First FilePath)
, globalMonoidCompiler :: !(First WantedCompiler)
, globalMonoidTerminal :: !(First Bool)
, globalMonoidStyles :: !StylesUpdate
, globalMonoidTermWidth :: !(First Int)
, globalMonoidStackYaml :: !(First FilePath)
, globalMonoidLockFileBehavior :: !(First LockFileBehavior)
} deriving Generic
instance Semigroup GlobalOptsMonoid where
(<>) = mappenddefault
instance Monoid GlobalOptsMonoid where
mempty = memptydefault
mappend = (<>)
defaultLogLevel :: LogLevel
defaultLogLevel = LevelInfo
readColorWhen :: ReadM ColorWhen
readColorWhen = do
s <- OA.readerAsk
case s of
"never" -> return ColorNever
"always" -> return ColorAlways
"auto" -> return ColorAuto
_ -> OA.readerError "Expected values of color option are 'never', 'always', or 'auto'."
readStyles :: ReadM StylesUpdate
readStyles = parseStylesUpdateFromString <$> OA.readerAsk
data BuildConfig = BuildConfig
{ bcConfig :: !Config
, bcSMWanted :: !SMWanted
, bcExtraPackageDBs :: ![Path Abs Dir]
, bcStackYaml :: !(Path Abs File)
, bcProjectStorage :: !ProjectStorage
, bcCurator :: !(Maybe Curator)
}
stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y })
projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir)
projectRootL = stackYamlL.to parent
data EnvConfig = EnvConfig
{envConfigBuildConfig :: !BuildConfig
,envConfigBuildOptsCLI :: !BuildOptsCLI
,envConfigSourceMap :: !SourceMap
,envConfigSourceMapHash :: !SourceMapHash
,envConfigCompilerPaths :: !CompilerPaths
}
ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription
ppGPD = liftIO . cpGPD . ppCommon
ppRoot :: ProjectPackage -> Path Abs Dir
ppRoot = parent . ppCabalFP
ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)
ppComponents pp = do
gpd <- ppGPD pp
pure $ Set.fromList $ concat
[ maybe [] (const [CLib]) (C.condLibrary gpd)
, go CExe (fst <$> C.condExecutables gpd)
, go CTest (fst <$> C.condTestSuites gpd)
, go CBench (fst <$> C.condBenchmarks gpd)
]
where
go :: (T.Text -> NamedComponent)
-> [C.UnqualComponentName]
-> [NamedComponent]
go wrapper = map (wrapper . T.pack . C.unUnqualComponentName)
ppVersion :: MonadIO m => ProjectPackage -> m Version
ppVersion = fmap gpdVersion . ppGPD
data Project = Project
{ projectUserMsg :: !(Maybe String)
, projectPackages :: ![RelFilePath]
, projectDependencies :: ![RawPackageLocation]
, projectFlags :: !(Map PackageName (Map FlagName Bool))
, projectResolver :: !RawSnapshotLocation
, projectCompiler :: !(Maybe WantedCompiler)
, projectExtraPackageDBs :: ![FilePath]
, projectCurator :: !(Maybe Curator)
, projectDropPackages :: !(Set PackageName)
}
deriving Show
instance ToJSON Project where
toJSON (Project userMsg packages extraDeps flags resolver mcompiler extraPackageDBs mcurator drops) = object $ concat
[ maybe [] (\cv -> ["compiler" .= cv]) mcompiler
, maybe [] (\msg -> ["user-message" .= msg]) userMsg
, if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs]
, if null extraDeps then [] else ["extra-deps" .= extraDeps]
, if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)]
, ["packages" .= packages]
, ["resolver" .= resolver]
, maybe [] (\c -> ["curator" .= c]) mcurator
, if Set.null drops then [] else ["drop-packages" .= Set.map CabalString drops]
]
data Curator = Curator
{ curatorSkipTest :: !(Set PackageName)
, curatorExpectTestFailure :: !(Set PackageName)
, curatorSkipBenchmark :: !(Set PackageName)
, curatorExpectBenchmarkFailure :: !(Set PackageName)
, curatorSkipHaddock :: !(Set PackageName)
, curatorExpectHaddockFailure :: !(Set PackageName)
}
deriving Show
instance ToJSON Curator where
toJSON c = object
[ "skip-test" .= Set.map CabalString (curatorSkipTest c)
, "expect-test-failure" .= Set.map CabalString (curatorExpectTestFailure c)
, "skip-bench" .= Set.map CabalString (curatorSkipBenchmark c)
, "expect-benchmark-failure" .= Set.map CabalString (curatorExpectTestFailure c)
, "skip-haddock" .= Set.map CabalString (curatorSkipHaddock c)
, "expect-test-failure" .= Set.map CabalString (curatorExpectHaddockFailure c)
]
instance FromJSON (WithJSONWarnings Curator) where
parseJSON = withObjectWarnings "Curator" $ \o -> Curator
<$> fmap (Set.map unCabalString) (o ..:? "skip-test" ..!= mempty)
<*> fmap (Set.map unCabalString) (o ..:? "expect-test-failure" ..!= mempty)
<*> fmap (Set.map unCabalString) (o ..:? "skip-bench" ..!= mempty)
<*> fmap (Set.map unCabalString) (o ..:? "expect-benchmark-failure" ..!= mempty)
<*> fmap (Set.map unCabalString) (o ..:? "skip-haddock" ..!= mempty)
<*> fmap (Set.map unCabalString) (o ..:? "expect-haddock-failure" ..!= mempty)
data ConfigMonoid =
ConfigMonoid
{ configMonoidStackRoot :: !(First (Path Abs Dir))
, configMonoidWorkDir :: !(First (Path Rel Dir))
, configMonoidBuildOpts :: !BuildOptsMonoid
, configMonoidDockerOpts :: !DockerOptsMonoid
, configMonoidNixOpts :: !NixOptsMonoid
, configMonoidConnectionCount :: !(First Int)
, configMonoidHideTHLoading :: !FirstTrue
, configMonoidLatestSnapshot :: !(First Text)
, configMonoidPackageIndices :: !(First [HackageSecurityConfig])
, configMonoidSystemGHC :: !(First Bool)
,configMonoidInstallGHC :: !FirstTrue
,configMonoidSkipGHCCheck :: !FirstFalse
,configMonoidSkipMsys :: !FirstFalse
,configMonoidCompilerCheck :: !(First VersionCheck)
,configMonoidCompilerRepository :: !(First CompilerRepository)
,configMonoidRequireStackVersion :: !IntersectingVersionRange
,configMonoidArch :: !(First String)
,configMonoidGHCVariant :: !(First GHCVariant)
,configMonoidGHCBuild :: !(First CompilerBuild)
,configMonoidJobs :: !(First Int)
,configMonoidExtraIncludeDirs :: ![FilePath]
,configMonoidExtraLibDirs :: ![FilePath]
, configMonoidOverrideGccPath :: !(First (Path Abs File))
,configMonoidOverrideHpack :: !(First FilePath)
,configMonoidConcurrentTests :: !(First Bool)
,configMonoidLocalBinPath :: !(First FilePath)
,configMonoidTemplateParameters :: !(Map Text Text)
,configMonoidScmInit :: !(First SCM)
,configMonoidGhcOptionsByName :: !(MonoidMap PackageName (Monoid.Dual [Text]))
,configMonoidGhcOptionsByCat :: !(MonoidMap ApplyGhcOptions (Monoid.Dual [Text]))
,configMonoidCabalConfigOpts :: !(MonoidMap CabalConfigKey (Monoid.Dual [Text]))
,configMonoidExtraPath :: ![Path Abs Dir]
,configMonoidSetupInfoLocations :: ![SetupInfoLocation]
,configMonoidLocalProgramsBase :: !(First (Path Abs Dir))
,configMonoidPvpBounds :: !(First PvpBounds)
,configMonoidModifyCodePage :: !FirstTrue
,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configMonoidRebuildGhcOptions :: !FirstFalse
,configMonoidApplyGhcOptions :: !(First ApplyGhcOptions)
,configMonoidAllowNewer :: !(First Bool)
,configMonoidDefaultTemplate :: !(First TemplateName)
, configMonoidAllowDifferentUser :: !(First Bool)
, configMonoidDumpLogs :: !(First DumpLogs)
, configMonoidSaveHackageCreds :: !(First Bool)
, configMonoidHackageBaseUrl :: !(First Text)
, configMonoidColorWhen :: !(First ColorWhen)
, configMonoidStyles :: !StylesUpdate
, configMonoidHideSourcePaths :: !FirstTrue
, configMonoidRecommendUpgrade :: !FirstTrue
}
deriving (Show, Generic)
instance Semigroup ConfigMonoid where
(<>) = mappenddefault
instance Monoid ConfigMonoid where
mempty = memptydefault
mappend = (<>)
parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid)
parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject
parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid
parseConfigMonoidObject rootDir obj = do
let configMonoidStackRoot = First Nothing
configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName
configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)
configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)
configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)
configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName
configMonoidHideTHLoading <- FirstTrue <$> obj ..:? configMonoidHideTHLoadingName
murls :: Maybe Value <- obj ..:? configMonoidUrlsName
configMonoidLatestSnapshot <-
case murls of
Nothing -> pure $ First Nothing
Just urls -> jsonSubWarnings $ lift $ withObjectWarnings
"urls"
(\o -> First <$> o ..:? "latest-snapshot" :: WarningParser (First Text))
urls
configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)
configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName
configMonoidInstallGHC <- FirstTrue <$> obj ..:? configMonoidInstallGHCName
configMonoidSkipGHCCheck <- FirstFalse <$> obj ..:? configMonoidSkipGHCCheckName
configMonoidSkipMsys <- FirstFalse <$> obj ..:? configMonoidSkipMsysName
configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (
obj ..:? configMonoidRequireStackVersionName
..!= VersionRangeJSON anyVersion)
configMonoidArch <- First <$> obj ..:? configMonoidArchName
configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName
configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName
configMonoidJobs <- First <$> obj ..:? configMonoidJobsName
configMonoidExtraIncludeDirs <- map (toFilePath rootDir FilePath.</>) <$>
obj ..:? configMonoidExtraIncludeDirsName ..!= []
configMonoidExtraLibDirs <- map (toFilePath rootDir FilePath.</>) <$>
obj ..:? configMonoidExtraLibDirsName ..!= []
configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName
configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName
configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName
configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName
templates <- obj ..:? "templates"
(configMonoidScmInit,configMonoidTemplateParameters) <-
case templates of
Nothing -> return (First Nothing,M.empty)
Just tobj -> do
scmInit <- tobj ..:? configMonoidScmInitName
params <- tobj ..:? configMonoidTemplateParametersName
return (First scmInit,fromMaybe M.empty params)
configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
configMonoidCompilerRepository <- First <$> (obj ..:? configMonoidCompilerRepositoryName)
options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty
optionsEverything <-
case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of
(Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"
(Nothing, Just x) -> return x
(Just x, Nothing) -> do
tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"
return x
(Nothing, Nothing) -> return []
let configMonoidGhcOptionsByCat = coerce $ Map.fromList
[ (AGOEverything, optionsEverything)
, (AGOLocals, Map.findWithDefault [] GOKLocals options)
, (AGOTargets, Map.findWithDefault [] GOKTargets options)
]
configMonoidGhcOptionsByName = coerce $ Map.fromList
[(name, opts) | (GOKPackage name, opts) <- Map.toList options]
configMonoidCabalConfigOpts' <- obj ..:? "configure-options" ..!= mempty
let configMonoidCabalConfigOpts = coerce (configMonoidCabalConfigOpts' :: Map CabalConfigKey [Text])
configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
configMonoidSetupInfoLocations <-
maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)
configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName
configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName
configMonoidModifyCodePage <- FirstTrue <$> obj ..:? configMonoidModifyCodePageName
configMonoidExplicitSetupDeps <-
(obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)
>>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList
configMonoidRebuildGhcOptions <- FirstFalse <$> obj ..:? configMonoidRebuildGhcOptionsName
configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName
configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName
configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName
configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName
configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName
configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName
configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName
configMonoidColorWhenUS <- obj ..:? configMonoidColorWhenUSName
configMonoidColorWhenGB <- obj ..:? configMonoidColorWhenGBName
let configMonoidColorWhen = First $ configMonoidColorWhenUS
<|> configMonoidColorWhenGB
configMonoidStylesUS <- obj ..:? configMonoidStylesUSName
configMonoidStylesGB <- obj ..:? configMonoidStylesGBName
let configMonoidStyles = fromMaybe mempty $ configMonoidStylesUS
<|> configMonoidStylesGB
configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName
configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName
return ConfigMonoid {..}
where
handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)
handleExplicitSetupDep (name', b) = do
name <-
if name' == "*"
then return Nothing
else case parsePackageName $ T.unpack name' of
Nothing -> fail $ "Invalid package name: " ++ show name'
Just x -> return $ Just x
return (name, b)
configMonoidWorkDirName :: Text
configMonoidWorkDirName = "work-dir"
configMonoidBuildOptsName :: Text
configMonoidBuildOptsName = "build"
configMonoidDockerOptsName :: Text
configMonoidDockerOptsName = "docker"
configMonoidNixOptsName :: Text
configMonoidNixOptsName = "nix"
configMonoidConnectionCountName :: Text
configMonoidConnectionCountName = "connection-count"
configMonoidHideTHLoadingName :: Text
configMonoidHideTHLoadingName = "hide-th-loading"
configMonoidUrlsName :: Text
configMonoidUrlsName = "urls"
configMonoidPackageIndicesName :: Text
configMonoidPackageIndicesName = "package-indices"
configMonoidSystemGHCName :: Text
configMonoidSystemGHCName = "system-ghc"
configMonoidInstallGHCName :: Text
configMonoidInstallGHCName = "install-ghc"
configMonoidSkipGHCCheckName :: Text
configMonoidSkipGHCCheckName = "skip-ghc-check"
configMonoidSkipMsysName :: Text
configMonoidSkipMsysName = "skip-msys"
configMonoidRequireStackVersionName :: Text
configMonoidRequireStackVersionName = "require-stack-version"
configMonoidArchName :: Text
configMonoidArchName = "arch"
configMonoidGHCVariantName :: Text
configMonoidGHCVariantName = "ghc-variant"
configMonoidGHCBuildName :: Text
configMonoidGHCBuildName = "ghc-build"
configMonoidJobsName :: Text
configMonoidJobsName = "jobs"
configMonoidExtraIncludeDirsName :: Text
configMonoidExtraIncludeDirsName = "extra-include-dirs"
configMonoidExtraLibDirsName :: Text
configMonoidExtraLibDirsName = "extra-lib-dirs"
configMonoidOverrideGccPathName :: Text
configMonoidOverrideGccPathName = "with-gcc"
configMonoidOverrideHpackName :: Text
configMonoidOverrideHpackName = "with-hpack"
configMonoidConcurrentTestsName :: Text
configMonoidConcurrentTestsName = "concurrent-tests"
configMonoidLocalBinPathName :: Text
configMonoidLocalBinPathName = "local-bin-path"
configMonoidScmInitName :: Text
configMonoidScmInitName = "scm-init"
configMonoidTemplateParametersName :: Text
configMonoidTemplateParametersName = "params"
configMonoidCompilerCheckName :: Text
configMonoidCompilerCheckName = "compiler-check"
configMonoidCompilerRepositoryName :: Text
configMonoidCompilerRepositoryName = "compiler-repository"
configMonoidGhcOptionsName :: Text
configMonoidGhcOptionsName = "ghc-options"
configMonoidExtraPathName :: Text
configMonoidExtraPathName = "extra-path"
configMonoidSetupInfoLocationsName :: Text
configMonoidSetupInfoLocationsName = "setup-info"
configMonoidLocalProgramsBaseName :: Text
configMonoidLocalProgramsBaseName = "local-programs-path"
configMonoidPvpBoundsName :: Text
configMonoidPvpBoundsName = "pvp-bounds"
configMonoidModifyCodePageName :: Text
configMonoidModifyCodePageName = "modify-code-page"
configMonoidExplicitSetupDepsName :: Text
configMonoidExplicitSetupDepsName = "explicit-setup-deps"
configMonoidRebuildGhcOptionsName :: Text
configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"
configMonoidApplyGhcOptionsName :: Text
configMonoidApplyGhcOptionsName = "apply-ghc-options"
configMonoidAllowNewerName :: Text
configMonoidAllowNewerName = "allow-newer"
configMonoidDefaultTemplateName :: Text
configMonoidDefaultTemplateName = "default-template"
configMonoidAllowDifferentUserName :: Text
configMonoidAllowDifferentUserName = "allow-different-user"
configMonoidDumpLogsName :: Text
configMonoidDumpLogsName = "dump-logs"
configMonoidSaveHackageCredsName :: Text
configMonoidSaveHackageCredsName = "save-hackage-creds"
configMonoidHackageBaseUrlName :: Text
configMonoidHackageBaseUrlName = "hackage-base-url"
configMonoidColorWhenUSName :: Text
configMonoidColorWhenUSName = "color"
configMonoidColorWhenGBName :: Text
configMonoidColorWhenGBName = "colour"
configMonoidStylesUSName :: Text
configMonoidStylesUSName = "stack-colors"
configMonoidStylesGBName :: Text
configMonoidStylesGBName = "stack-colours"
configMonoidHideSourcePathsName :: Text
configMonoidHideSourcePathsName = "hide-source-paths"
configMonoidRecommendUpgradeName :: Text
configMonoidRecommendUpgradeName = "recommend-stack-upgrade"
data ConfigException
= ParseConfigFileException (Path Abs File) ParseException
| ParseCustomSnapshotException Text ParseException
| NoProjectConfigFound (Path Abs Dir) (Maybe Text)
| UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
| UnableToExtractArchive Text (Path Abs File)
| BadStackVersionException VersionRange
| NoMatchingSnapshot (NonEmpty SnapName)
| ResolverMismatch !RawSnapshotLocation String
| ResolverPartial !RawSnapshotLocation String
| NoSuchDirectory FilePath
| ParseGHCVariantException String
| BadStackRoot (Path Abs Dir)
| Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir)
| UserDoesn'tOwnDirectory (Path Abs Dir)
| ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
| NixRequiresSystemGhc
| NoResolverWhenUsingNoProject
| DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
deriving Typeable
instance Show ConfigException where
show (ParseConfigFileException configFile exception) = concat
[ "Could not parse '"
, toFilePath configFile
, "':\n"
, Yaml.prettyPrintParseException exception
, "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"
]
show (ParseCustomSnapshotException url exception) = concat
[ "Could not parse '"
, T.unpack url
, "':\n"
, Yaml.prettyPrintParseException exception
, "\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"
]
show (NoProjectConfigFound dir mcmd) = concat
[ "Unable to find a stack.yaml file in the current directory ("
, toFilePath dir
, ") or its ancestors"
, case mcmd of
Nothing -> ""
Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
]
show (UnexpectedArchiveContents dirs files) = concat
[ "When unpacking an archive specified in your stack.yaml file, "
, "did not find expected contents. Expected: a single directory. Found: "
, show ( map (toFilePath . dirname) dirs
, map (toFilePath . filename) files
)
]
show (UnableToExtractArchive url file) = concat
[ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, "
, T.unpack url, " downloaded to the file ", toFilePath $ filename file
]
show (BadStackVersionException requiredRange) = concat
[ "The version of stack you are using ("
, show (mkVersion' Meta.version)
, ") is outside the required\n"
,"version range specified in stack.yaml ("
, T.unpack (versionRangeText requiredRange)
, ")." ]
show (NoMatchingSnapshot names) = concat
[ "None of the following snapshots provides a compiler matching "
, "your package(s):\n"
, unlines $ map (\name -> " - " <> T.unpack (renderSnapName name))
(NonEmpty.toList names)
, resolveOptions
]
show (ResolverMismatch resolver errDesc) = concat
[ "Resolver '"
, T.unpack $ utf8BuilderToText $ display resolver
, "' does not have a matching compiler to build some or all of your "
, "package(s).\n"
, errDesc
, resolveOptions
]
show (ResolverPartial resolver errDesc) = concat
[ "Resolver '"
, T.unpack $ utf8BuilderToText $ display resolver
, "' does not have all the packages to match your requirements.\n"
, unlines $ fmap (" " <>) (lines errDesc)
, resolveOptions
]
show (NoSuchDirectory dir) =
"No directory could be located matching the supplied path: " ++ dir
show (ParseGHCVariantException v) =
"Invalid ghc-variant value: " ++ v
show (BadStackRoot stackRoot) = concat
[ "Invalid stack root: '"
, toFilePath stackRoot
, "'. Please provide a valid absolute path."
]
show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
[ "Preventing creation of stack root '"
, toFilePath envStackRoot
, "'. Parent directory '"
, toFilePath parentDir
, "' is owned by someone else."
]
show (UserDoesn'tOwnDirectory dir) = concat
[ "You are not the owner of '"
, toFilePath dir
, "'. Aborting to protect file permissions."
, "\nRetry with '--"
, T.unpack configMonoidAllowDifferentUserName
, "' to disable this precaution."
]
show ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat
[ "stack can only control the "
, configMonoidGHCVariantName
, " of its own GHC installations. Please use '--no-"
, configMonoidSystemGHCName
, "'."
]
show NixRequiresSystemGhc = T.unpack $ T.concat
[ "stack's Nix integration is incompatible with '--no-system-ghc'. "
, "Please use '--"
, configMonoidSystemGHCName
, "' or disable the Nix integration."
]
show NoResolverWhenUsingNoProject = "When using the script command, you must provide a resolver argument"
show (DuplicateLocalPackageNames pairs) = concat
$ "The same package name is used in multiple local packages\n"
: map go pairs
where
go (name, dirs) = unlines
$ ""
: (packageNameString name ++ " used in:")
: map goLoc dirs
goLoc loc = "- " ++ show loc
instance Exception ConfigException
resolveOptions :: String
resolveOptions =
unlines [ "\nThis may be resolved by:"
, " - Using '--omit-packages' to exclude mismatching package(s)."
, " - Using '--resolver' to specify a matching snapshot/resolver"
]
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
askLatestSnapshotUrl = view $ configL.to configLatestSnapshot
workDirL :: HasConfig env => Lens' env (Path Rel Dir)
workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y })
getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)
getProjectWorkDir = do
root <- view projectRootL
workDir <- view workDirL
return (root </> workDir)
platformOnlyRelDir
:: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m (Path Rel Dir)
platformOnlyRelDir = do
platform <- view platformL
platformVariant <- view platformVariantL
parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir)
snapshotsDir = do
root <- view stackRootL
platform <- platformGhcRelDir
return $ root </> relDirSnapshots </> platform
installationRootDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
installationRootDeps = do
root <- view stackRootL
psc <- platformSnapAndCompilerRel
return $ root </> relDirSnapshots </> psc
installationRootLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
installationRootLocal = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ workDir </> relDirInstall </> psc
bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
bindirCompilerTools = do
config <- view configL
platform <- platformGhcRelDir
compilerVersion <- view actualCompilerVersionL
compiler <- parseRelDir $ compilerVersionString compilerVersion
return $
view stackRootL config </>
relDirCompilerTools </>
platform </>
compiler </>
bindirSuffix
hoogleRoot :: (HasEnvConfig env) => RIO env (Path Abs Dir)
hoogleRoot = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ workDir </> relDirHoogle </> psc
hoogleDatabasePath :: (HasEnvConfig env) => RIO env (Path Abs File)
hoogleDatabasePath = do
dir <- hoogleRoot
return (dir </> relFileDatabaseHoo)
platformSnapAndCompilerRel
:: (HasEnvConfig env)
=> RIO env (Path Rel Dir)
platformSnapAndCompilerRel = do
platform <- platformGhcRelDir
smh <- view $ envConfigL.to envConfigSourceMapHash
name <- smRelDir smh
ghc <- compilerVersionDir
useShaPathOnWindows (platform </> name </> ghc)
platformGhcRelDir
:: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformGhcRelDir = do
cp <- view compilerPathsL
let cbSuffix = compilerBuildSuffix $ cpBuild cp
verOnly <- platformGhcVerOnlyRelDirStr
parseRelDir (mconcat [ verOnly, cbSuffix ])
platformGhcVerOnlyRelDir
:: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
=> m (Path Rel Dir)
platformGhcVerOnlyRelDir =
parseRelDir =<< platformGhcVerOnlyRelDirStr
platformGhcVerOnlyRelDirStr
:: (MonadReader env m, HasPlatform env, HasGHCVariant env)
=> m FilePath
platformGhcVerOnlyRelDirStr = do
platform <- view platformL
platformVariant <- view platformVariantL
ghcVariant <- view ghcVariantL
return $ mconcat [ Distribution.Text.display platform
, platformVariantSuffix platformVariant
, ghcVariantSuffix ghcVariant ]
useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows
| osIsWindows = shaPath
| otherwise = pure
shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)
shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath
shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t)
shaPathForBytes
= parsePath . S8.unpack . S8.take 8
. Mem.convertToBase Mem.Base16 . hashWith SHA1
class IsPath b t where
parsePath :: MonadThrow m => FilePath -> m (Path b t)
instance IsPath Abs Dir where parsePath = parseAbsDir
instance IsPath Rel Dir where parsePath = parseRelDir
instance IsPath Abs File where parsePath = parseAbsFile
instance IsPath Rel File where parsePath = parseRelFile
compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
compilerVersionDir = do
compilerVersion <- view actualCompilerVersionL
parseRelDir $ case compilerVersion of
ACGhc version -> versionString version
ACGhcjs {} -> compilerVersionString compilerVersion
ACGhcGit {} -> compilerVersionString compilerVersion
packageDatabaseDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
packageDatabaseDeps = do
root <- installationRootDeps
return $ root </> relDirPkgdb
packageDatabaseLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
packageDatabaseLocal = do
root <- installationRootLocal
return $ root </> relDirPkgdb
packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs
data GlobalInfoSource
= GISSnapshotHints
| GISCompiler ActualCompiler
hpcReportDir :: (HasEnvConfig env)
=> RIO env (Path Abs Dir)
hpcReportDir = do
root <- installationRootLocal
return $ root </> relDirHpc
extraBinDirs :: (HasEnvConfig env)
=> RIO env (Bool -> [Path Abs Dir])
extraBinDirs = do
deps <- installationRootDeps
local' <- installationRootLocal
tools <- bindirCompilerTools
return $ \locals -> if locals
then [local' </> bindirSuffix, deps </> bindirSuffix, tools]
else [deps </> bindirSuffix, tools]
minimalEnvSettings :: EnvSettings
minimalEnvSettings =
EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
, esKeepGhcRts = False
}
defaultEnvSettings :: EnvSettings
defaultEnvSettings = EnvSettings
{ esIncludeLocals = True
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
, esKeepGhcRts = True
}
plainEnvSettings :: EnvSettings
plainEnvSettings = EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
, esKeepGhcRts = True
}
getCompilerPath :: HasCompiler env => RIO env (Path Abs File)
getCompilerPath = view $ compilerPathsL.to cpCompiler
data ProjectAndConfigMonoid
= ProjectAndConfigMonoid !Project !ConfigMonoid
parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid rootDir =
withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
packages <- o ..:? "packages" ..!= [RelFilePath "."]
deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= []
flags' <- o ..:? "flags" ..!= mempty
let flags = unCabalStringMap <$> unCabalStringMap
(flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool))
resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"]
mcompiler <- o ..:? "compiler"
msg <- o ..:? "user-message"
config <- parseConfigMonoidObject rootDir o
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
mcurator <- jsonSubWarningsT (o ..:? "curator")
drops <- o ..:? "drop-packages" ..!= mempty
return $ do
deps' <- mapM (resolvePaths (Just rootDir)) deps
resolver' <- resolvePaths (Just rootDir) resolver
let project = Project
{ projectUserMsg = msg
, projectResolver = resolver'
, projectCompiler = mcompiler
, projectExtraPackageDBs = extraPackageDBs
, projectPackages = packages
, projectDependencies = concatMap toList (deps' :: [NonEmpty RawPackageLocation])
, projectFlags = flags
, projectCurator = mcurator
, projectDropPackages = Set.map unCabalString drops
}
pure $ ProjectAndConfigMonoid project config
data SCM = Git
deriving (Show)
instance FromJSON SCM where
parseJSON v = do
s <- parseJSON v
case s of
"git" -> return Git
_ -> fail ("Unknown or unsupported SCM: " <> s)
instance ToJSON SCM where
toJSON Git = toJSON ("git" :: Text)
data PlatformVariant = PlatformVariantNone
| PlatformVariant String
platformVariantSuffix :: PlatformVariant -> String
platformVariantSuffix PlatformVariantNone = ""
platformVariantSuffix (PlatformVariant v) = "-" ++ v
data GHCVariant
= GHCStandard
| GHCIntegerSimple
| GHCCustom String
deriving (Show)
instance FromJSON GHCVariant where
parseJSON =
withText
"GHCVariant"
(either (fail . show) return . parseGHCVariant . T.unpack)
ghcVariantName :: GHCVariant -> String
ghcVariantName GHCStandard = "standard"
ghcVariantName GHCIntegerSimple = "integersimple"
ghcVariantName (GHCCustom name) = "custom-" ++ name
ghcVariantSuffix :: GHCVariant -> String
ghcVariantSuffix GHCStandard = ""
ghcVariantSuffix v = "-" ++ ghcVariantName v
parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant
parseGHCVariant s =
case stripPrefix "custom-" s of
Just name -> return (GHCCustom name)
Nothing
| s == "" -> return GHCStandard
| s == "standard" -> return GHCStandard
| s == "integersimple" -> return GHCIntegerSimple
| otherwise -> return (GHCCustom s)
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
, downloadInfoContentLength :: Maybe Int
, downloadInfoSha1 :: Maybe ByteString
, downloadInfoSha256 :: Maybe ByteString
} deriving (Show)
instance FromJSON (WithJSONWarnings DownloadInfo) where
parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject
parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo
parseDownloadInfoFromObject o = do
url <- o ..: "url"
contentLength <- o ..:? "content-length"
sha1TextMay <- o ..:? "sha1"
sha256TextMay <- o ..:? "sha256"
return
DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
, downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
, downloadInfoSha256 = fmap encodeUtf8 sha256TextMay
}
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
deriving Show
instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where
parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do
CabalString version <- o ..: "version"
downloadInfo <- parseDownloadInfoFromObject o
return VersionedDownloadInfo
{ vdiVersion = version
, vdiDownloadInfo = downloadInfo
}
data GHCDownloadInfo = GHCDownloadInfo
{ gdiConfigureOpts :: [Text]
, gdiConfigureEnv :: Map Text Text
, gdiDownloadInfo :: DownloadInfo
}
deriving Show
instance FromJSON (WithJSONWarnings GHCDownloadInfo) where
parseJSON = withObjectWarnings "GHCDownloadInfo" $ \o -> do
configureOpts <- o ..:? "configure-opts" ..!= mempty
configureEnv <- o ..:? "configure-env" ..!= mempty
downloadInfo <- parseDownloadInfoFromObject o
return GHCDownloadInfo
{ gdiConfigureOpts = configureOpts
, gdiConfigureEnv = configureEnv
, gdiDownloadInfo = downloadInfo
}
data SetupInfo = SetupInfo
{ siSevenzExe :: Maybe DownloadInfo
, siSevenzDll :: Maybe DownloadInfo
, siMsys2 :: Map Text VersionedDownloadInfo
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
, siGHCJSs :: Map Text (Map ActualCompiler DownloadInfo)
, siStack :: Map Text (Map Version DownloadInfo)
}
deriving Show
instance FromJSON (WithJSONWarnings SetupInfo) where
parseJSON = withObjectWarnings "SetupInfo" $ \o -> do
siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")
siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")
siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)
(fmap unCabalStringMap -> siGHCs) <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)
(fmap unCabalStringMap -> siStack) <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
return SetupInfo {..}
instance Semigroup SetupInfo where
l <> r =
SetupInfo
{ siSevenzExe = siSevenzExe r <|> siSevenzExe l
, siSevenzDll = siSevenzDll r <|> siSevenzDll l
, siMsys2 = siMsys2 r <> siMsys2 l
, siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l)
, siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l)
, siStack = Map.unionWith (<>) (siStack l) (siStack r) }
instance Monoid SetupInfo where
mempty =
SetupInfo
{ siSevenzExe = Nothing
, siSevenzDll = Nothing
, siMsys2 = Map.empty
, siGHCs = Map.empty
, siGHCJSs = Map.empty
, siStack = Map.empty
}
mappend = (<>)
data SetupInfoLocation
= SetupInfoFileOrURL String
| SetupInfoInline SetupInfo
deriving (Show)
instance FromJSON (WithJSONWarnings SetupInfoLocation) where
parseJSON v =
(noJSONWarnings <$>
withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>
inline
where
inline = do
WithJSONWarnings si w <- parseJSON v
return $ WithJSONWarnings (SetupInfoInline si) w
data PvpBoundsType
= PvpBoundsNone
| PvpBoundsUpper
| PvpBoundsLower
| PvpBoundsBoth
deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
data PvpBounds = PvpBounds
{ pbType :: !PvpBoundsType
, pbAsRevision :: !Bool
}
deriving (Show, Read, Eq, Typeable, Ord)
pvpBoundsText :: PvpBoundsType -> Text
pvpBoundsText PvpBoundsNone = "none"
pvpBoundsText PvpBoundsUpper = "upper"
pvpBoundsText PvpBoundsLower = "lower"
pvpBoundsText PvpBoundsBoth = "both"
parsePvpBounds :: Text -> Either String PvpBounds
parsePvpBounds t = maybe err Right $ do
(t', asRevision) <-
case T.break (== '-') t of
(x, "") -> Just (x, False)
(x, "-revision") -> Just (x, True)
_ -> Nothing
x <- Map.lookup t' m
Just PvpBounds
{ pbType = x
, pbAsRevision = asRevision
}
where
m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
err = Left $ "Invalid PVP bounds: " ++ T.unpack t
instance ToJSON PvpBounds where
toJSON (PvpBounds typ asRevision) =
toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))
instance FromJSON PvpBounds where
parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool
explicitSetupDeps name = do
m <- view $ configL.to configExplicitSetupDeps
return $
Map.findWithDefault
(Map.findWithDefault False Nothing m)
(Just name)
m
newtype DockerEntrypoint = DockerEntrypoint
{ deUser :: Maybe DockerUser
} deriving (Read,Show)
data DockerUser = DockerUser
{ duUid :: UserID
, duGid :: GroupID
, duGroups :: [GroupID]
, duUmask :: FileMode
} deriving (Read,Show)
data GhcOptionKey
= GOKOldEverything
| GOKEverything
| GOKLocals
| GOKTargets
| GOKPackage !PackageName
deriving (Eq, Ord)
instance FromJSONKey GhcOptionKey where
fromJSONKey = FromJSONKeyTextParser $ \t ->
case t of
"*" -> return GOKOldEverything
"$everything" -> return GOKEverything
"$locals" -> return GOKLocals
"$targets" -> return GOKTargets
_ ->
case parsePackageName $ T.unpack t of
Nothing -> fail $ "Invalid package name: " ++ show t
Just x -> return $ GOKPackage x
fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"
newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] }
instance FromJSON GhcOptions where
parseJSON = withText "GhcOptions" $ \t ->
case parseArgs Escaping t of
Left e -> fail e
Right opts -> return $ GhcOptions $ map T.pack opts
class HasPlatform env where
platformL :: Lens' env Platform
default platformL :: HasConfig env => Lens' env Platform
platformL = configL.platformL
{-# INLINE platformL #-}
platformVariantL :: Lens' env PlatformVariant
default platformVariantL :: HasConfig env => Lens' env PlatformVariant
platformVariantL = configL.platformVariantL
{-# INLINE platformVariantL #-}
class HasGHCVariant env where
ghcVariantL :: SimpleGetter env GHCVariant
default ghcVariantL :: HasConfig env => SimpleGetter env GHCVariant
ghcVariantL = configL.ghcVariantL
{-# INLINE ghcVariantL #-}
class (HasProcessContext env, HasLogFunc env) => HasRunner env where
runnerL :: Lens' env Runner
instance HasLogFunc Runner where
logFuncL = lens runnerLogFunc (\x y -> x { runnerLogFunc = y })
instance HasProcessContext Runner where
processContextL = lens runnerProcessContext (\x y -> x { runnerProcessContext = y })
instance HasRunner Runner where
runnerL = id
instance HasStylesUpdate Runner where
stylesUpdateL = globalOptsL.
lens globalStylesUpdate (\x y -> x { globalStylesUpdate = y })
instance HasTerm Runner where
useColorL = lens runnerUseColor (\x y -> x { runnerUseColor = y })
termWidthL = lens runnerTermWidth (\x y -> x { runnerTermWidth = y })
globalOptsL :: HasRunner env => Lens' env GlobalOpts
globalOptsL = runnerL.lens runnerGlobalOpts (\x y -> x { runnerGlobalOpts = y })
class (HasPlatform env, HasGHCVariant env, HasProcessContext env, HasPantryConfig env, HasTerm env, HasRunner env) => HasConfig env where
configL :: Lens' env Config
default configL :: HasBuildConfig env => Lens' env Config
configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })
{-# INLINE configL #-}
class HasConfig env => HasBuildConfig env where
buildConfigL :: Lens' env BuildConfig
default buildConfigL :: HasEnvConfig env => Lens' env BuildConfig
buildConfigL = envConfigL.lens
envConfigBuildConfig
(\x y -> x { envConfigBuildConfig = y })
class (HasBuildConfig env, HasSourceMap env, HasCompiler env) => HasEnvConfig env where
envConfigL :: Lens' env EnvConfig
instance HasPlatform (Platform,PlatformVariant) where
platformL = _1
platformVariantL = _2
instance HasPlatform Config where
platformL = lens configPlatform (\x y -> x { configPlatform = y })
platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y })
instance HasPlatform BuildConfig
instance HasPlatform EnvConfig
instance HasGHCVariant GHCVariant where
ghcVariantL = id
{-# INLINE ghcVariantL #-}
instance HasGHCVariant Config where
ghcVariantL = to $ fromMaybe GHCStandard . configGHCVariant
instance HasGHCVariant BuildConfig
instance HasGHCVariant EnvConfig
instance HasProcessContext Config where
processContextL = runnerL.processContextL
instance HasProcessContext BuildConfig where
processContextL = configL.processContextL
instance HasProcessContext EnvConfig where
processContextL = configL.processContextL
instance HasPantryConfig Config where
pantryConfigL = lens configPantryConfig (\x y -> x { configPantryConfig = y })
instance HasPantryConfig BuildConfig where
pantryConfigL = configL.pantryConfigL
instance HasPantryConfig EnvConfig where
pantryConfigL = configL.pantryConfigL
instance HasConfig Config where
configL = id
{-# INLINE configL #-}
instance HasConfig BuildConfig where
configL = lens bcConfig (\x y -> x { bcConfig = y })
instance HasConfig EnvConfig
instance HasBuildConfig BuildConfig where
buildConfigL = id
{-# INLINE buildConfigL #-}
instance HasBuildConfig EnvConfig
instance HasCompiler EnvConfig where
compilerPathsL = to envConfigCompilerPaths
instance HasEnvConfig EnvConfig where
envConfigL = id
{-# INLINE envConfigL #-}
instance HasRunner Config where
runnerL = lens configRunner (\x y -> x { configRunner = y })
instance HasRunner BuildConfig where
runnerL = configL.runnerL
instance HasRunner EnvConfig where
runnerL = configL.runnerL
instance HasLogFunc Config where
logFuncL = runnerL.logFuncL
instance HasLogFunc BuildConfig where
logFuncL = runnerL.logFuncL
instance HasLogFunc EnvConfig where
logFuncL = runnerL.logFuncL
instance HasStylesUpdate Config where
stylesUpdateL = runnerL.stylesUpdateL
instance HasStylesUpdate BuildConfig where
stylesUpdateL = runnerL.stylesUpdateL
instance HasStylesUpdate EnvConfig where
stylesUpdateL = runnerL.stylesUpdateL
instance HasTerm Config where
useColorL = runnerL.useColorL
termWidthL = runnerL.termWidthL
instance HasTerm BuildConfig where
useColorL = runnerL.useColorL
termWidthL = runnerL.termWidthL
instance HasTerm EnvConfig where
useColorL = runnerL.useColorL
termWidthL = runnerL.termWidthL
stackRootL :: HasConfig s => Lens' s (Path Abs Dir)
stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y })
wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted)
newtype GhcPkgExe = GhcPkgExe (Path Abs File)
deriving Show
getGhcPkgExe :: HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe = view $ compilerPathsL.to cpPkg
data DumpPackage = DumpPackage
{ dpGhcPkgId :: !GhcPkgId
, dpPackageIdent :: !PackageIdentifier
, dpParentLibIdent :: !(Maybe PackageIdentifier)
, dpLicense :: !(Maybe C.License)
, dpLibDirs :: ![FilePath]
, dpLibraries :: ![Text]
, dpHasExposedModules :: !Bool
, dpExposedModules :: !(Set ModuleName)
, dpDepends :: ![GhcPkgId]
, dpHaddockInterfaces :: ![FilePath]
, dpHaddockHtml :: !(Maybe FilePath)
, dpIsExposed :: !Bool
}
deriving (Show, Read, Eq)
data CompilerPaths = CompilerPaths
{ cpCompilerVersion :: !ActualCompiler
, cpArch :: !Arch
, cpBuild :: !CompilerBuild
, cpCompiler :: !(Path Abs File)
, cpPkg :: !GhcPkgExe
, cpInterpreter :: !(Path Abs File)
, cpHaddock :: !(Path Abs File)
, cpSandboxed :: !Bool
, cpCabalVersion :: !Version
, cpGlobalDB :: !(Path Abs Dir)
, cpGhcInfo :: !ByteString
, cpGlobalDump :: !(Map PackageName DumpPackage)
}
deriving Show
cpWhich :: (MonadReader env m, HasCompiler env) => m WhichCompiler
cpWhich = view $ compilerPathsL.to (whichCompiler.cpCompilerVersion)
data ExtraDirs = ExtraDirs
{ edBins :: ![Path Abs Dir]
, edInclude :: ![Path Abs Dir]
, edLib :: ![Path Abs Dir]
} deriving (Show, Generic)
instance Semigroup ExtraDirs where
(<>) = mappenddefault
instance Monoid ExtraDirs where
mempty = memptydefault
mappend = (<>)
class HasCompiler env where
compilerPathsL :: SimpleGetter env CompilerPaths
instance HasCompiler CompilerPaths where
compilerPathsL = id
class HasSourceMap env where
sourceMapL :: Lens' env SourceMap
instance HasSourceMap EnvConfig where
sourceMapL = lens envConfigSourceMap (\x y -> x { envConfigSourceMap = y })
actualCompilerVersionL :: HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL = sourceMapL.to smCompiler
buildOptsL :: HasConfig s => Lens' s BuildOpts
buildOptsL = configL.lens
configBuild
(\x y -> x { configBuild = y })
buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidHaddockL = lens (getFirstFalse . buildMonoidHaddock)
(\buildMonoid t -> buildMonoid {buildMonoidHaddock = FirstFalse t})
buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL = lens (getFirstFalse . buildMonoidTests)
(\buildMonoid t -> buildMonoid {buildMonoidTests = FirstFalse t})
buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL = lens (getFirstFalse . buildMonoidBenchmarks)
(\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = FirstFalse t})
buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidInstallExesL =
lens (getFirstFalse . buildMonoidInstallExes)
(\buildMonoid t -> buildMonoid {buildMonoidInstallExes = FirstFalse t})
buildOptsInstallExesL :: Lens' BuildOpts Bool
buildOptsInstallExesL =
lens boptsInstallExes
(\bopts t -> bopts {boptsInstallExes = t})
buildOptsHaddockL :: Lens' BuildOpts Bool
buildOptsHaddockL =
lens boptsHaddock
(\bopts t -> bopts {boptsHaddock = t})
globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL =
lens
globalConfigMonoid
(\x y -> x { globalConfigMonoid = y })
.
lens
configMonoidBuildOpts
(\x y -> x { configMonoidBuildOpts = y })
cabalVersionL :: HasCompiler env => SimpleGetter env Version
cabalVersionL = compilerPathsL.to cpCabalVersion
whichCompilerL :: Getting r ActualCompiler WhichCompiler
whichCompilerL = to whichCompiler
envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext)
envOverrideSettingsL = configL.lens
configProcessContextSettings
(\x y -> x { configProcessContextSettings = y })
shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env)
=> RIO env Bool
shouldForceGhcColorFlag = do
canDoColor <- (>= mkVersion [8, 2, 1]) . getGhcVersion
<$> view actualCompilerVersionL
shouldDoColor <- view useColorL
return $ canDoColor && shouldDoColor
appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env)
=> RIO env (Maybe String)
appropriateGhcColorFlag = f <$> shouldForceGhcColorFlag
where f True = Just ghcColorForceFlag
f False = Nothing
terminalL :: HasRunner env => Lens' env Bool
terminalL = globalOptsL.lens globalTerminal (\x y -> x { globalTerminal = y })
reExecL :: HasRunner env => SimpleGetter env Bool
reExecL = globalOptsL.to (isJust . globalReExecVersion)