module Stack.Types.Config
(
HasPlatform(..)
,HasStackRoot(..)
,PlatformVariant(..)
,Config(..)
,HasConfig(..)
,askConfig
,askLatestSnapshotUrl
,explicitSetupDeps
,getMinimalEnvOverride
,BuildConfig(..)
,bcRoot
,bcWorkDir
,bcWantedCompiler
,HasBuildConfig(..)
,GHCVariant(..)
,ghcVariantName
,ghcVariantSuffix
,parseGHCVariant
,HasGHCVariant(..)
,snapshotsDir
,StackMiniM
,EnvConfig(..)
,HasEnvConfig(..)
,getWhichCompiler
,getCompilerPath
,ApplyGhcOptions(..)
,ConfigException(..)
,WhichSolverCmd(..)
,ConfigMonoid(..)
,configMonoidInstallGHCName
,configMonoidSystemGHCName
,DumpLogs(..)
,EnvSettings(..)
,minimalEnvSettings
,GlobalOpts(..)
,GlobalOptsMonoid(..)
,defaultLogLevel
,LoadConfig(..)
,PackageEntry(..)
,TreatLikeExtraDep
,PackageLocation(..)
,RemotePackageType(..)
,PackageIndex(..)
,IndexName(..)
,indexNameText
,IndexLocation(..)
,configPackageIndex
,configPackageIndexCache
,configPackageIndexGz
,configPackageIndexRoot
,configPackageIndexRepo
,configPackageTarball
,Project(..)
,ProjectAndConfigMonoid(..)
,PvpBounds(..)
,parsePvpBounds
,ColorWhen(..)
,readColorWhen
,SCM(..)
,CustomSnapshot(..)
,GhcOptions(..)
,ghcOptionsFor
,PackageFlags(..)
,bindirSuffix
,configInstalledCache
,configMiniBuildPlanCache
,getProjectWorkDir
,docDirSuffix
,flagCacheLocal
,extraBinDirs
,hpcReportDir
,installationRootDeps
,installationRootLocal
,hoogleRoot
,hoogleDatabasePath
,packageDatabaseDeps
,packageDatabaseExtra
,packageDatabaseLocal
,platformOnlyRelDir
,platformGhcRelDir
,useShaPathOnWindows
,getWorkDir
,EvalOpts(..)
,ExecOpts(..)
,SpecialExecCmd(..)
,ExecOptsExtra(..)
,DownloadInfo(..)
,VersionedDownloadInfo(..)
,GHCDownloadInfo(..)
,SetupInfo(..)
,SetupInfoLocation(..)
,DockerEntrypoint(..)
,DockerUser(..)
,module X
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception
import Control.Monad (liftM, mzero, join)
import Control.Monad.Catch (MonadThrow, MonadMask)
import Control.Monad.Logger (LogLevel(..), MonadLoggerIO)
import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
import Control.Monad.Trans.Control
import Data.Aeson.Extended
(ToJSON, toJSON, FromJSON, parseJSON, withText, object,
(.=), (..:), (..:?), (..!=), Value(Bool, String),
withObjectWarnings, WarningParser, Object, jsonSubWarnings,
jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings)
import Data.Attoparsec.Args
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Either (partitionEithers)
import Data.IORef (IORef)
import Data.List (stripPrefix)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable
import Data.Yaml (ParseException)
import qualified Data.Yaml as Yaml
import Distribution.System (Platform)
import qualified Distribution.Text
import Distribution.Version (anyVersion)
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Network.HTTP.Client (parseRequest)
import Options.Applicative (ReadM)
import qualified Options.Applicative as OA
import qualified Options.Applicative.Types as OA
import Path
import qualified Paths_stack as Meta
import Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName)
import Stack.Types.Compiler
import Stack.Types.CompilerBuild
import Stack.Types.Docker
import Stack.Types.FlagName
import Stack.Types.Image
import Stack.Types.Nix
import Stack.Types.PackageIdentifier
import Stack.Types.PackageIndex
import Stack.Types.PackageName
import Stack.Types.Resolver
import Stack.Types.TemplateName
import Stack.Types.Urls
import Stack.Types.Version
import System.FilePath (takeBaseName)
import System.PosixCompat.Types (UserID, GroupID, FileMode)
import System.Process.Read (EnvOverride, findExecutable)
import Stack.Types.Config.Build as X
#ifdef mingw32_HOST_OS
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as B16
#endif
data Config =
Config {configStackRoot :: !(Path Abs Dir)
,configWorkDir :: !(Path Rel Dir)
,configUserConfigPath :: !(Path Abs File)
,configBuild :: !BuildOpts
,configDocker :: !DockerOpts
,configNix :: !NixOpts
,configEnvOverride :: !(EnvSettings -> IO EnvOverride)
,configLocalProgramsBase :: !(Path Abs Dir)
,configLocalPrograms :: !(Path Abs Dir)
,configConnectionCount :: !Int
,configHideTHLoading :: !Bool
,configPlatform :: !Platform
,configPlatformVariant :: !PlatformVariant
,configGHCVariant0 :: !(Maybe GHCVariant)
,configGHCBuild :: !(Maybe CompilerBuild)
,configUrls :: !Urls
,configPackageIndices :: ![PackageIndex]
,configSystemGHC :: !Bool
,configInstallGHC :: !Bool
,configSkipGHCCheck :: !Bool
,configSkipMsys :: !Bool
,configCompilerCheck :: !VersionCheck
,configLocalBin :: !(Path Abs Dir)
,configRequireStackVersion :: !VersionRange
,configJobs :: !Int
,configOverrideGccPath :: !(Maybe (Path Abs File))
,configExtraIncludeDirs :: !(Set (Path Abs Dir))
,configExtraLibDirs :: !(Set (Path Abs Dir))
,configConcurrentTests :: !Bool
,configImage :: !ImageOpts
,configTemplateParams :: !(Map Text Text)
,configScmInit :: !(Maybe SCM)
,configGhcOptions :: !GhcOptions
,configSetupInfoLocations :: ![SetupInfoLocation]
,configPvpBounds :: !PvpBounds
,configModifyCodePage :: !Bool
,configExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configRebuildGhcOptions :: !Bool
,configApplyGhcOptions :: !ApplyGhcOptions
,configAllowNewer :: !Bool
,configDefaultTemplate :: !(Maybe TemplateName)
,configAllowDifferentUser :: !Bool
,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache))))
,configDumpLogs :: !DumpLogs
,configMaybeProject :: !(Maybe (Project, Path Abs File))
}
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
}
deriving (Show, Eq, Ord)
data ExecOpts = ExecOpts
{ eoCmd :: !SpecialExecCmd
, eoArgs :: ![String]
, eoExtra :: !ExecOptsExtra
} deriving (Show)
data SpecialExecCmd
= ExecCmd String
| ExecGhc
| ExecRunGhc
deriving (Show, Eq)
data ExecOptsExtra
= ExecOptsPlain
| ExecOptsEmbellished
{ eoEnvSettings :: !EnvSettings
, eoPackages :: ![String]
}
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 CompilerVersion)
, globalTerminal :: !Bool
, globalColorWhen :: !ColorWhen
, globalStackYaml :: !(Maybe FilePath)
} deriving (Show)
data GlobalOptsMonoid = GlobalOptsMonoid
{ globalMonoidReExecVersion :: !(First String)
, globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)
, globalMonoidLogLevel :: !(First LogLevel)
, globalMonoidTimeInLog :: !(First Bool)
, globalMonoidConfigMonoid :: !ConfigMonoid
, globalMonoidResolver :: !(First AbstractResolver)
, globalMonoidCompiler :: !(First CompilerVersion)
, globalMonoidTerminal :: !(First Bool)
, globalMonoidColorWhen :: !(First ColorWhen)
, globalMonoidStackYaml :: !(First FilePath)
} deriving (Show, Generic)
instance Monoid GlobalOptsMonoid where
mempty = memptydefault
mappend = mappenddefault
defaultLogLevel :: LogLevel
defaultLogLevel = LevelInfo
data ColorWhen = ColorNever | ColorAlways | ColorAuto
deriving (Show, Generic)
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'."
data BuildConfig = BuildConfig
{ bcConfig :: !Config
, bcResolver :: !LoadedResolver
, bcWantedMiniBuildPlan :: !MiniBuildPlan
, bcPackageEntries :: ![PackageEntry]
, bcExtraDeps :: !(Map PackageName Version)
, bcExtraPackageDBs :: ![Path Abs Dir]
, bcStackYaml :: !(Path Abs File)
, bcFlags :: !PackageFlags
, bcImplicitGlobal :: !Bool
, bcGHCVariant :: !GHCVariant
}
bcRoot :: BuildConfig -> Path Abs Dir
bcRoot = parent . bcStackYaml
bcWorkDir :: (MonadReader env m, HasConfig env) => BuildConfig -> m (Path Abs Dir)
bcWorkDir bconfig = do
workDir <- getWorkDir
return (bcRoot bconfig </> workDir)
bcWantedCompiler :: BuildConfig -> CompilerVersion
bcWantedCompiler = mbpCompilerVersion . bcWantedMiniBuildPlan
data EnvConfig = EnvConfig
{envConfigBuildConfig :: !BuildConfig
,envConfigCabalVersion :: !Version
,envConfigCompilerVersion :: !CompilerVersion
,envConfigCompilerBuild :: !CompilerBuild
,envConfigPackagesRef :: !(IORef (Maybe (Map (Path Abs Dir) TreatLikeExtraDep)))
}
instance HasBuildConfig EnvConfig where
getBuildConfig = envConfigBuildConfig
instance HasConfig EnvConfig
instance HasPlatform EnvConfig
instance HasGHCVariant EnvConfig
instance HasStackRoot EnvConfig
class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where
getEnvConfig :: r -> EnvConfig
instance HasEnvConfig EnvConfig where
getEnvConfig = id
data LoadConfig m = LoadConfig
{ lcConfig :: !Config
, lcLoadBuildConfig :: !(Maybe CompilerVersion -> m BuildConfig)
, lcProjectRoot :: !(Maybe (Path Abs Dir))
}
data PackageEntry = PackageEntry
{ peExtraDepMaybe :: !(Maybe TreatLikeExtraDep)
, peLocation :: !PackageLocation
, peSubdirs :: ![FilePath]
}
deriving Show
peExtraDepDef :: PackageEntry -> TreatLikeExtraDep
peExtraDepDef = fromMaybe False . peExtraDepMaybe
type TreatLikeExtraDep = Bool
instance ToJSON PackageEntry where
toJSON pe | not (peExtraDepDef pe) && null (peSubdirs pe) =
toJSON $ peLocation pe
toJSON pe = object $
maybe id (\e -> (("extra-dep" .= e):)) (peExtraDepMaybe pe)
[ "location" .= peLocation pe
, "subdirs" .= peSubdirs pe
]
instance FromJSON (WithJSONWarnings PackageEntry) where
parseJSON (String t) = do
WithJSONWarnings loc _ <- parseJSON $ String t
return $ noJSONWarnings
PackageEntry
{ peExtraDepMaybe = Nothing
, peLocation = loc
, peSubdirs = []
}
parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
<$> o ..:? "extra-dep"
<*> jsonSubWarnings (o ..: "location")
<*> o ..:? "subdirs" ..!= []) v
data PackageLocation
= PLFilePath FilePath
| PLRemote Text RemotePackageType
deriving Show
data RemotePackageType
= RPTHttp
| RPTGit Text
| RPTHg Text
deriving Show
instance ToJSON PackageLocation where
toJSON (PLFilePath fp) = toJSON fp
toJSON (PLRemote t RPTHttp) = toJSON t
toJSON (PLRemote x (RPTGit y)) = object [("git", toJSON x), ("commit", toJSON y)]
toJSON (PLRemote x (RPTHg y)) = object [( "hg", toJSON x), ("commit", toJSON y)]
instance FromJSON (WithJSONWarnings PackageLocation) where
parseJSON v
= (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)
<|> git v
<|> hg v
where
file t = pure $ PLFilePath $ T.unpack t
http t =
case parseRequest $ T.unpack t of
Left _ -> mzero
Right _ -> return $ PLRemote t RPTHttp
git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote
<$> o ..: "git"
<*> (RPTGit <$> o ..: "commit")
hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote
<$> o ..: "hg"
<*> (RPTHg <$> o ..: "commit")
data Project = Project
{ projectUserMsg :: !(Maybe String)
, projectPackages :: ![PackageEntry]
, projectExtraDeps :: !(Map PackageName Version)
, projectFlags :: !PackageFlags
, projectResolver :: !Resolver
, projectCompiler :: !(Maybe CompilerVersion)
, projectExtraPackageDBs :: ![FilePath]
}
deriving Show
instance ToJSON Project where
toJSON p = object $
maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p) $
maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p)
[ "packages" .= projectPackages p
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
, "flags" .= projectFlags p
, "resolver" .= projectResolver p
, "extra-package-dbs" .= projectExtraPackageDBs p
]
class HasStackRoot env where
getStackRoot :: env -> Path Abs Dir
default getStackRoot :: HasConfig env => env -> Path Abs Dir
getStackRoot = configStackRoot . getConfig
class HasPlatform env where
getPlatform :: env -> Platform
default getPlatform :: HasConfig env => env -> Platform
getPlatform = configPlatform . getConfig
getPlatformVariant :: env -> PlatformVariant
default getPlatformVariant :: HasConfig env => env -> PlatformVariant
getPlatformVariant = configPlatformVariant . getConfig
instance HasPlatform (Platform,PlatformVariant) where
getPlatform (p,_) = p
getPlatformVariant (_,v) = v
class HasGHCVariant env where
getGHCVariant :: env -> GHCVariant
default getGHCVariant :: HasBuildConfig env => env -> GHCVariant
getGHCVariant = bcGHCVariant . getBuildConfig
instance HasGHCVariant GHCVariant where
getGHCVariant = id
class (HasStackRoot env, HasPlatform env) => HasConfig env where
getConfig :: env -> Config
default getConfig :: HasBuildConfig env => env -> Config
getConfig = bcConfig . getBuildConfig
instance HasStackRoot Config
instance HasPlatform Config
instance HasConfig Config where
getConfig = id
class HasConfig env => HasBuildConfig env where
getBuildConfig :: env -> BuildConfig
instance HasStackRoot BuildConfig
instance HasPlatform BuildConfig
instance HasGHCVariant BuildConfig
instance HasConfig BuildConfig
instance HasBuildConfig BuildConfig where
getBuildConfig = id
type StackMiniM r m =
( MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m
)
data ConfigMonoid =
ConfigMonoid
{ configMonoidStackRoot :: !(First (Path Abs Dir))
, configMonoidWorkDir :: !(First (Path Rel Dir))
, configMonoidBuildOpts :: !BuildOptsMonoid
, configMonoidDockerOpts :: !DockerOptsMonoid
, configMonoidNixOpts :: !NixOptsMonoid
, configMonoidConnectionCount :: !(First Int)
, configMonoidHideTHLoading :: !(First Bool)
, configMonoidLatestSnapshotUrl :: !(First Text)
, configMonoidUrls :: !UrlsMonoid
, configMonoidPackageIndices :: !(First [PackageIndex])
, configMonoidSystemGHC :: !(First Bool)
,configMonoidInstallGHC :: !(First Bool)
,configMonoidSkipGHCCheck :: !(First Bool)
,configMonoidSkipMsys :: !(First Bool)
,configMonoidCompilerCheck :: !(First VersionCheck)
,configMonoidRequireStackVersion :: !IntersectingVersionRange
,configMonoidArch :: !(First String)
,configMonoidGHCVariant :: !(First GHCVariant)
,configMonoidGHCBuild :: !(First CompilerBuild)
,configMonoidJobs :: !(First Int)
,configMonoidExtraIncludeDirs :: !(Set (Path Abs Dir))
,configMonoidExtraLibDirs :: !(Set (Path Abs Dir))
, configMonoidOverrideGccPath :: !(First (Path Abs File))
,configMonoidConcurrentTests :: !(First Bool)
,configMonoidLocalBinPath :: !(First FilePath)
,configMonoidImageOpts :: !ImageOptsMonoid
,configMonoidTemplateParameters :: !(Map Text Text)
,configMonoidScmInit :: !(First SCM)
,configMonoidGhcOptions :: !GhcOptions
,configMonoidExtraPath :: ![Path Abs Dir]
,configMonoidSetupInfoLocations :: ![SetupInfoLocation]
,configMonoidLocalProgramsBase :: !(First (Path Abs Dir))
,configMonoidPvpBounds :: !(First PvpBounds)
,configMonoidModifyCodePage :: !(First Bool)
,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configMonoidRebuildGhcOptions :: !(First Bool)
,configMonoidApplyGhcOptions :: !(First ApplyGhcOptions)
,configMonoidAllowNewer :: !(First Bool)
,configMonoidDefaultTemplate :: !(First TemplateName)
, configMonoidAllowDifferentUser :: !(First Bool)
, configMonoidDumpLogs :: !(First DumpLogs)
}
deriving (Show, Generic)
instance Monoid ConfigMonoid where
mempty = memptydefault
mappend = mappenddefault
instance FromJSON (WithJSONWarnings ConfigMonoid) where
parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON
parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
parseConfigMonoidJSON 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 <- First <$> obj ..:? configMonoidHideTHLoadingName
configMonoidLatestSnapshotUrl <- First <$> obj ..:? configMonoidLatestSnapshotUrlName
configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty)
configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)
configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName
configMonoidInstallGHC <- First <$> obj ..:? configMonoidInstallGHCName
configMonoidSkipGHCCheck <- First <$> obj ..:? configMonoidSkipGHCCheckName
configMonoidSkipMsys <- First <$> 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 <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty
configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty
configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName
configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName
configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName
configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty)
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
configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty
configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
configMonoidSetupInfoLocations <-
maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)
configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName
configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName
configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName
configMonoidExplicitSetupDeps <-
(obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)
>>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList
configMonoidRebuildGhcOptions <- First <$> obj ..:? configMonoidRebuildGhcOptionsName
configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName
configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName
configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName
configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName
configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName
return ConfigMonoid {..}
where
handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)
handleExplicitSetupDep (name', b) = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right 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"
configMonoidLatestSnapshotUrlName :: Text
configMonoidLatestSnapshotUrlName = "latest-snapshot-url"
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"
configMonoidConcurrentTestsName :: Text
configMonoidConcurrentTestsName = "concurrent-tests"
configMonoidLocalBinPathName :: Text
configMonoidLocalBinPathName = "local-bin-path"
configMonoidImageOptsName :: Text
configMonoidImageOptsName = "image"
configMonoidScmInitName :: Text
configMonoidScmInitName = "scm-init"
configMonoidTemplateParametersName :: Text
configMonoidTemplateParametersName = "params"
configMonoidCompilerCheckName :: Text
configMonoidCompilerCheckName = "compiler-check"
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"
data ConfigException
= ParseConfigFileException (Path Abs File) ParseException
| ParseCustomSnapshotException Text ParseException
| ParseResolverException Text
| NoProjectConfigFound (Path Abs Dir) (Maybe Text)
| UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
| UnableToExtractArchive Text (Path Abs File)
| BadStackVersionException VersionRange
| NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName)
| forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String
| ResolverPartial WhichSolverCmd Resolver String
| NoSuchDirectory FilePath
| ParseGHCVariantException String
| BadStackRoot (Path Abs Dir)
| Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir)
| UserDoesn'tOwnDirectory (Path Abs Dir)
| FailedToCloneRepo String
| ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
| NixRequiresSystemGhc
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
]
show (ParseResolverException t) = concat
[ "Invalid resolver value: "
, T.unpack t
, ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. "
, "See https://www.stackage.org/snapshots for a complete list."
]
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. We support tarballs and zip, 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 (fromCabalVersion Meta.version)
, ") is outside the required\n"
,"version range specified in stack.yaml ("
, T.unpack (versionRangeText requiredRange)
, ")." ]
show (NoMatchingSnapshot whichCmd 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)
, showOptions whichCmd Don'tSuggestSolver
]
show (ResolverMismatch whichCmd resolver errDesc) = concat
[ "Resolver '"
, T.unpack (resolverName resolver)
, "' does not have a matching compiler to build some or all of your "
, "package(s).\n"
, errDesc
, showOptions whichCmd Don'tSuggestSolver
]
show (ResolverPartial whichCmd resolver errDesc) = concat
[ "Resolver '"
, T.unpack (resolverName resolver)
, "' does not have all the packages to match your requirements.\n"
, unlines $ fmap (" " <>) (lines errDesc)
, showOptions whichCmd
(case whichCmd of
IsSolverCmd -> Don'tSuggestSolver
_ -> SuggestSolver)
]
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 (FailedToCloneRepo commandName) = concat
[ "Failed to use "
, commandName
, " to clone the repo. Please ensure that "
, commandName
, " is installed and available to stack on your PATH environment variable."
]
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."
]
instance Exception ConfigException
showOptions :: WhichSolverCmd -> SuggestSolver -> String
showOptions whichCmd suggestSolver = unlines $ "\nThis may be resolved by:" : options
where
options =
(case suggestSolver of
SuggestSolver -> [useSolver]
Don'tSuggestSolver -> []) ++
(case whichCmd of
IsSolverCmd -> [useResolver]
IsInitCmd -> both
IsNewCmd -> both)
both = [omitPackages, useResolver]
useSolver = " - Using '--solver' to ask cabal-install to generate extra-deps, atop the chosen snapshot."
omitPackages = " - Using '--omit-packages to exclude mismatching package(s)."
useResolver = " - Using '--resolver' to specify a matching snapshot/resolver"
data WhichSolverCmd = IsInitCmd | IsSolverCmd | IsNewCmd
data SuggestSolver = SuggestSolver | Don'tSuggestSolver
askConfig :: (MonadReader env m, HasConfig env) => m Config
askConfig = liftM getConfig ask
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
askLatestSnapshotUrl = asks (urlsLatestSnapshot . configUrls . getConfig)
configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir)
configPackageIndexRoot (IndexName name) = do
config <- asks getConfig
dir <- parseRelDir $ S8.unpack name
return (configStackRoot config </> $(mkRelDir "indices") </> dir)
configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir))
configPackageIndexRepo name = do
indices <- asks $ configPackageIndices . getConfig
case filter (\p -> indexName p == name) indices of
[index] -> do
let murl =
case indexLocation index of
ILGit x -> Just x
ILHttp _ -> Nothing
ILGitHttp x _ -> Just x
case murl of
Nothing -> return Nothing
Just url -> do
sDir <- configPackageIndexRoot name
repoName <- parseRelDir $ takeBaseName $ T.unpack url
let suDir =
sDir </>
$(mkRelDir "git-update")
return $ Just $ suDir </> repoName
_ -> assert False $ return Nothing
configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot
configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndex = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot
configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexGz = liftM (</> $(mkRelFile "00-index.tar.gz")) . configPackageIndexRoot
configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File)
configPackageTarball iname ident = do
root <- configPackageIndexRoot iname
name <- parseRelDir $ packageNameString $ packageIdentifierName ident
ver <- parseRelDir $ versionString $ packageIdentifierVersion ident
base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz"
return (root </> $(mkRelDir "packages") </> name </> ver </> base)
getWorkDir :: (MonadReader env m, HasConfig env) => m (Path Rel Dir)
getWorkDir = configWorkDir `liftM` asks getConfig
getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)
getProjectWorkDir = do
bc <- asks getBuildConfig
workDir <- getWorkDir
return (bcRoot bc </> workDir)
configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)
configInstalledCache = liftM (</> $(mkRelFile "installed-cache.bin")) getProjectWorkDir
platformOnlyRelDir
:: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m (Path Rel Dir)
platformOnlyRelDir = do
platform <- asks getPlatform
platformVariant <- asks getPlatformVariant
parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir)
snapshotsDir = do
config <- asks getConfig
platform <- platformGhcRelDir
return $ configStackRoot config </> $(mkRelDir "snapshots") </> platform
installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootDeps = do
config <- asks getConfig
psc <- platformSnapAndCompilerRel
return $ configStackRoot config </> $(mkRelDir "snapshots") </> psc
installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootLocal = do
bc <- asks getBuildConfig
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ getProjectWorkDir bc </> $(mkRelDir "install") </> psc
hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
hoogleRoot = do
bc <- asks getBuildConfig
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ getProjectWorkDir bc </> $(mkRelDir "hoogle") </> psc
hoogleDatabasePath :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs File)
hoogleDatabasePath = do
dir <- hoogleRoot
return (dir </> $(mkRelFile "database.hoo"))
platformSnapAndCompilerRel
:: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformSnapAndCompilerRel = do
bc <- asks getBuildConfig
platform <- platformGhcRelDir
name <- parseRelDir $ T.unpack $ resolverDirName $ bcResolver bc
ghc <- compilerVersionDir
useShaPathOnWindows (platform </> name </> ghc)
platformGhcRelDir
:: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformGhcRelDir = do
envConfig <- asks getEnvConfig
verOnly <- platformGhcVerOnlyRelDirStr
parseRelDir (mconcat [ verOnly
, compilerBuildSuffix (envConfigCompilerBuild envConfig)])
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 <- asks getPlatform
platformVariant <- asks getPlatformVariant
ghcVariant <- asks getGHCVariant
return $ mconcat [ Distribution.Text.display platform
, platformVariantSuffix platformVariant
, ghcVariantSuffix ghcVariant ]
useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows =
#ifdef mingw32_HOST_OS
parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath
#else
return
#endif
compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
compilerVersionDir = do
compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
parseRelDir $ case compilerVersion of
GhcVersion version -> versionString version
GhcjsVersion {} -> compilerVersionString compilerVersion
packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseDeps = do
root <- installationRootDeps
return $ root </> $(mkRelDir "pkgdb")
packageDatabaseLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseLocal = do
root <- installationRootLocal
return $ root </> $(mkRelDir "pkgdb")
packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
packageDatabaseExtra = do
bc <- asks getBuildConfig
return $ bcExtraPackageDBs bc
flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
flagCacheLocal = do
root <- installationRootLocal
return $ root </> $(mkRelDir "flag-cache")
configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env)
=> SnapName
-> m (Path Abs File)
configMiniBuildPlanCache name = do
root <- asks getStackRoot
platform <- platformGhcVerOnlyRelDir
file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"
return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)
bindirSuffix :: Path Rel Dir
bindirSuffix = $(mkRelDir "bin")
docDirSuffix :: Path Rel Dir
docDirSuffix = $(mkRelDir "doc")
hpcReportDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Path Abs Dir)
hpcReportDir = do
root <- installationRootLocal
return $ root </> $(mkRelDir "hpc")
extraBinDirs :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Bool -> [Path Abs Dir])
extraBinDirs = do
deps <- installationRootDeps
local <- installationRootLocal
return $ \locals -> if locals
then [local </> bindirSuffix, deps </> bindirSuffix]
else [deps </> bindirSuffix]
getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride
getMinimalEnvOverride = do
config <- asks getConfig
liftIO $ configEnvOverride config minimalEnvSettings
minimalEnvSettings :: EnvSettings
minimalEnvSettings =
EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
}
getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler
getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig)
getCompilerPath
:: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)
=> WhichCompiler
-> m (Path Abs File)
getCompilerPath wc = do
config <- asks getConfig
eoWithoutLocals <- liftIO $
configEnvOverride config minimalEnvSettings { esLocaleUtf8 = True }
join (findExecutable eoWithoutLocals (compilerExeName wc))
data ProjectAndConfigMonoid
= ProjectAndConfigMonoid !Project !ConfigMonoid
instance FromJSON (WithJSONWarnings ProjectAndConfigMonoid) where
parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir]
extraDeps' <- o ..:? "extra-deps" ..!= []
extraDeps <-
case partitionEithers $ goDeps extraDeps' of
([], x) -> return $ Map.fromList x
(errs, _) -> fail $ unlines errs
flags <- o ..:? "flags" ..!= mempty
resolver <- jsonSubWarnings (o ..: "resolver")
compiler <- o ..:? "compiler"
msg <- o ..:? "user-message"
config <- parseConfigMonoidJSON o
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
let project = Project
{ projectUserMsg = msg
, projectPackages = dirs
, projectExtraDeps = extraDeps
, projectFlags = flags
, projectResolver = resolver
, projectCompiler = compiler
, projectExtraPackageDBs = extraPackageDBs
}
return $ ProjectAndConfigMonoid project config
where
goDeps =
map toSingle . Map.toList . Map.unionsWith Set.union . map toMap
where
toMap i = Map.singleton
(packageIdentifierName i)
(Set.singleton (packageIdentifierVersion i))
toSingle (k, s) =
case Set.toList s of
[x] -> Right (k, x)
xs -> Left $ concat
[ "Multiple versions for package "
, packageNameString k
, ": "
, unwords $ map versionString xs
]
packageEntryCurrDir :: PackageEntry
packageEntryCurrDir = PackageEntry
{ peExtraDepMaybe = Nothing
, peLocation = PLFilePath "."
, peSubdirs = []
}
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
} 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"
return
DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
, downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
}
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
deriving Show
instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where
parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do
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 CompilerVersion 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)
siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)
siStack <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
return SetupInfo {..}
instance Monoid SetupInfo where
mempty =
SetupInfo
{ siSevenzExe = Nothing
, siSevenzDll = Nothing
, siMsys2 = Map.empty
, siGHCs = Map.empty
, siGHCJSs = Map.empty
, siStack = Map.empty
}
mappend 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) }
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 PvpBounds
= PvpBoundsNone
| PvpBoundsUpper
| PvpBoundsLower
| PvpBoundsBoth
deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
pvpBoundsText :: PvpBounds -> Text
pvpBoundsText PvpBoundsNone = "none"
pvpBoundsText PvpBoundsUpper = "upper"
pvpBoundsText PvpBoundsLower = "lower"
pvpBoundsText PvpBoundsBoth = "both"
parsePvpBounds :: Text -> Either String PvpBounds
parsePvpBounds t =
case Map.lookup t m of
Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t
Just x -> Right x
where
m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
instance ToJSON PvpBounds where
toJSON = toJSON . pvpBoundsText
instance FromJSON PvpBounds where
parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool
explicitSetupDeps name = do
m <- asks $ configExplicitSetupDeps . getConfig
return $
case Map.lookup (Just name) m of
Just b -> b
Nothing ->
case Map.lookup Nothing m of
Just b -> b
Nothing -> False
data DockerEntrypoint = DockerEntrypoint
{ deUser :: !(Maybe DockerUser)
} deriving (Read,Show)
data DockerUser = DockerUser
{ duUid :: UserID
, duGid :: GroupID
, duGroups :: [GroupID]
, duUmask :: FileMode
} deriving (Read,Show)
data CustomSnapshot = CustomSnapshot
{ csCompilerVersion :: !(Maybe CompilerVersion)
, csPackages :: !(Set PackageIdentifier)
, csDropPackages :: !(Set PackageName)
, csFlags :: !PackageFlags
, csGhcOptions :: !GhcOptions
}
instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where
parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,)
<$> (CustomSnapshot
<$> o ..:? "compiler"
<*> o ..:? "packages" ..!= mempty
<*> o ..:? "drop-packages" ..!= mempty
<*> o ..:? "flags" ..!= mempty
<*> o ..:? configMonoidGhcOptionsName ..!= mempty)
<*> jsonSubWarningsT (o ..:? "resolver")
newtype GhcOptions = GhcOptions
{ unGhcOptions :: Map (Maybe PackageName) [Text] }
deriving Show
instance FromJSON GhcOptions where
parseJSON val = do
ghcOptions <- parseJSON val
fmap (GhcOptions . Map.fromList) $ mapM handleGhcOptions $ Map.toList ghcOptions
where
handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])
handleGhcOptions (name', vals') = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right x -> return $ Just x
case parseArgs Escaping vals' of
Left e -> fail e
Right vals -> return (name, map T.pack vals)
instance Monoid GhcOptions where
mempty = GhcOptions mempty
mappend (GhcOptions l) (GhcOptions r) =
GhcOptions (Map.unionWith (++) l r)
ghcOptionsFor :: PackageName -> GhcOptions -> [Text]
ghcOptionsFor name (GhcOptions mp) =
M.findWithDefault [] Nothing mp ++
M.findWithDefault [] (Just name) mp
newtype PackageFlags = PackageFlags
{ unPackageFlags :: Map PackageName (Map FlagName Bool) }
deriving Show
instance FromJSON PackageFlags where
parseJSON val = PackageFlags <$> parseJSON val
instance ToJSON PackageFlags where
toJSON = toJSON . unPackageFlags
instance Monoid PackageFlags where
mempty = PackageFlags mempty
mappend (PackageFlags l) (PackageFlags r) =
PackageFlags (Map.unionWith Map.union l r)