module Stack.Types.Config
(
HasPlatform(..)
,PlatformVariant(..)
,Config(..)
,HasConfig(..)
,askLatestSnapshotUrl
,explicitSetupDeps
,getMinimalEnvOverride
,BuildConfig(..)
,stackYamlL
,projectRootL
,HasBuildConfig(..)
,GHCVariant(..)
,ghcVariantName
,ghcVariantSuffix
,parseGHCVariant
,HasGHCVariant(..)
,snapshotsDir
,StackMiniM
,EnvConfig(..)
,HasEnvConfig(..)
,getCompilerPath
,ApplyGhcOptions(..)
,ConfigException(..)
,WhichSolverCmd(..)
,ConfigMonoid(..)
,configMonoidInstallGHCName
,configMonoidSystemGHCName
,DumpLogs(..)
,EnvSettings(..)
,minimalEnvSettings
,GlobalOpts(..)
,GlobalOptsMonoid(..)
,StackYamlLoc(..)
,defaultLogLevel
,LoadConfig(..)
,PackageEntry(..)
,TreatLikeExtraDep
,PackageLocation(..)
,RemotePackageType(..)
,PackageIndex(..)
,IndexName(..)
,indexNameText
,IndexLocation(..)
,configPackageIndex
,configPackageIndexOld
,configPackageIndexCache
,configPackageIndexCacheOld
,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
,platformGhcVerOnlyRelDir
,useShaPathOnWindows
,workDirL
,EvalOpts(..)
,ExecOpts(..)
,SpecialExecCmd(..)
,ExecOptsExtra(..)
,DownloadInfo(..)
,VersionedDownloadInfo(..)
,GHCDownloadInfo(..)
,SetupInfo(..)
,SetupInfoLocation(..)
,DockerEntrypoint(..)
,DockerUser(..)
,module X
,wantedCompilerVersionL
,actualCompilerVersionL
,buildOptsL
,globalOptsL
,buildOptsInstallExesL
,buildOptsMonoidHaddockL
,buildOptsMonoidTestsL
,buildOptsMonoidBenchmarksL
,buildOptsMonoidInstallExesL
,buildOptsHaddockL
,globalOptsBuildOptsMonoidL
,packageIndicesL
,packageCachesL
,stackRootL
,configUrlsL
,cabalVersionL
,whichCompilerL
,view
,to
) 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, 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.HashMap.Strict (HashMap)
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 Lens.Micro (Lens', lens, _1, _2, to, Getting)
import Lens.Micro.Mtl (view)
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 (GitSHA1, 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 Crypto.Hash (hashWith, SHA1(..))
import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
#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),
HashMap GitSHA1 (PackageIndex, OffsetSize))))
,configDumpLogs :: !DumpLogs
,configMaybeProject :: !(Maybe (Project, Path Abs File))
,configAllowLocals :: !Bool
}
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]
, eoRtsOptions :: ![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 :: !(StackYamlLoc FilePath)
} deriving (Show)
data StackYamlLoc filepath
= SYLDefault
| SYLOverride !filepath
| SYLNoConfig
deriving (Show,Functor,Foldable,Traversable)
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
, bcGHCVariant :: !GHCVariant
, bcPackageEntries :: ![PackageEntry]
, bcExtraDeps :: !(Map PackageName Version)
, bcExtraPackageDBs :: ![Path Abs Dir]
, bcStackYaml :: !(Path Abs File)
, bcFlags :: !PackageFlags
, bcImplicitGlobal :: !Bool
}
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
,envConfigCabalVersion :: !Version
,envConfigCompilerVersion :: !CompilerVersion
,envConfigCompilerBuild :: !CompilerBuild
,envConfigPackagesRef :: !(IORef (Maybe (Map (Path Abs Dir) TreatLikeExtraDep)))
}
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
]
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
| NoResolverWhenUsingNoLocalConfig
| InvalidResolverForNoLocalConfig String
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."
]
show NoResolverWhenUsingNoLocalConfig = "When using the script command, you must provide a resolver argument"
show (InvalidResolverForNoLocalConfig ar) = "The script command requires a specific resolver, you provided " ++ ar
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
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
askLatestSnapshotUrl = view $ configL.to configUrls.to urlsLatestSnapshot
configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir)
configPackageIndexRoot (IndexName name) = do
root <- view stackRootL
dir <- parseRelDir $ S8.unpack name
return (root </> $(mkRelDir "indices") </> dir)
configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir))
configPackageIndexRepo name = do
indices <- view packageIndicesL
case filter (\p -> indexName p == name) indices of
[index] -> do
let murl =
case simplifyIndexLocation $ indexLocation index of
SILGit x -> Just x
SILHttp _ _ -> Nothing
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 "01-index.cache")) . configPackageIndexRoot
configPackageIndexCacheOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexCacheOld = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot
configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndex = liftM (</> $(mkRelFile "01-index.tar")) . configPackageIndexRoot
configPackageIndexOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexOld = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot
configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexGz = liftM (</> $(mkRelFile "01-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)
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)
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 <- 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 </> $(mkRelDir "snapshots") </> platform
installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootDeps = do
root <- view stackRootL
psc <- platformSnapAndCompilerRel
return $ root </> $(mkRelDir "snapshots") </> psc
installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootLocal = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ workDir </> $(mkRelDir "install") </> psc
hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
hoogleRoot = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ workDir </> $(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
resolver' <- view loadedResolverL
platform <- platformGhcRelDir
name <- parseRelDir $ T.unpack $ resolverDirName resolver'
ghc <- compilerVersionDir
useShaPathOnWindows (platform </> name </> ghc)
platformGhcRelDir
:: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformGhcRelDir = do
ec <- view envConfigL
verOnly <- platformGhcVerOnlyRelDirStr
parseRelDir (mconcat [ verOnly
, compilerBuildSuffix (envConfigCompilerBuild ec)])
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 =
#ifdef mingw32_HOST_OS
parseRelDir . S8.unpack . S8.take 8 . Mem.convertToBase Mem.Base16 . hashWith SHA1 . encodeUtf8 . T.pack . toFilePath
#else
return
#endif
compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
compilerVersionDir = do
compilerVersion <- view actualCompilerVersionL
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 :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs
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 <- view stackRootL
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' <- view configL
liftIO $ configEnvOverride config' minimalEnvSettings
minimalEnvSettings :: EnvSettings
minimalEnvSettings =
EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
}
getCompilerPath
:: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)
=> WhichCompiler
-> m (Path Abs File)
getCompilerPath wc = do
config' <- view configL
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 <- view $ configL.to configExplicitSetupDeps
return $
case Map.lookup (Just name) m of
Just b -> b
Nothing ->
case Map.lookup Nothing m of
Just b -> b
Nothing -> False
newtype 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)
class HasPlatform env where
platformL :: Lens' env Platform
default platformL :: HasConfig env => Lens' env Platform
platformL = configL.platformL
platformVariantL :: Lens' env PlatformVariant
default platformVariantL :: HasConfig env => Lens' env PlatformVariant
platformVariantL = configL.platformVariantL
class HasGHCVariant env where
ghcVariantL :: Lens' env GHCVariant
default ghcVariantL :: HasBuildConfig env => Lens' env GHCVariant
ghcVariantL = buildConfigL.ghcVariantL
class HasPlatform env => HasConfig env where
configL :: Lens' env Config
default configL :: HasBuildConfig env => Lens' env Config
configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })
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, HasGHCVariant 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
instance HasGHCVariant BuildConfig where
ghcVariantL = lens bcGHCVariant (\x y -> x { bcGHCVariant = y })
instance HasGHCVariant EnvConfig
instance HasConfig Config where
configL = id
instance HasConfig BuildConfig where
configL = lens bcConfig (\x y -> x { bcConfig = y })
instance HasConfig EnvConfig
instance HasBuildConfig BuildConfig where
buildConfigL = id
instance HasBuildConfig EnvConfig
instance HasEnvConfig EnvConfig where
envConfigL = id
stackRootL :: HasConfig s => Lens' s (Path Abs Dir)
stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y })
wantedCompilerVersionL :: HasBuildConfig s => Lens' s CompilerVersion
wantedCompilerVersionL = miniBuildPlanL.lens
mbpCompilerVersion
(\x y -> x { mbpCompilerVersion = y })
actualCompilerVersionL :: HasEnvConfig s => Lens' s CompilerVersion
actualCompilerVersionL = envConfigL.lens
envConfigCompilerVersion
(\x y -> x { envConfigCompilerVersion = y })
loadedResolverL :: HasBuildConfig s => Lens' s LoadedResolver
loadedResolverL = buildConfigL.lens
bcResolver
(\x y -> x { bcResolver = y })
miniBuildPlanL :: HasBuildConfig s => Lens' s MiniBuildPlan
miniBuildPlanL = buildConfigL.lens
bcWantedMiniBuildPlan
(\x y -> x { bcWantedMiniBuildPlan = y })
packageIndicesL :: HasConfig s => Lens' s [PackageIndex]
packageIndicesL = configL.lens
configPackageIndices
(\x y -> x { configPackageIndices = y })
buildOptsL :: HasConfig s => Lens' s BuildOpts
buildOptsL = configL.lens
configBuild
(\x y -> x { configBuild = y })
buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidHaddockL = lens (getFirst . buildMonoidHaddock)
(\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t})
buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL = lens (getFirst . buildMonoidTests)
(\buildMonoid t -> buildMonoid {buildMonoidTests = First t})
buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL = lens (getFirst . buildMonoidBenchmarks)
(\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t})
buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidInstallExesL =
lens (getFirst . buildMonoidInstallExes)
(\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First 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})
globalOptsL :: Lens' GlobalOpts ConfigMonoid
globalOptsL = lens globalConfigMonoid (\x y -> x { globalConfigMonoid = y })
globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL = globalOptsL.lens
configMonoidBuildOpts
(\x y -> x { configMonoidBuildOpts = y })
packageCachesL :: HasConfig env => Lens' env
(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache)
,HashMap GitSHA1 (PackageIndex, OffsetSize))))
packageCachesL = configL.lens configPackageCaches (\x y -> x { configPackageCaches = y })
configUrlsL :: HasConfig env => Lens' env Urls
configUrlsL = configL.lens configUrls (\x y -> x { configUrls = y })
cabalVersionL :: HasEnvConfig env => Lens' env Version
cabalVersionL = envConfigL.lens
envConfigCabalVersion
(\x y -> x { envConfigCabalVersion = y })
whichCompilerL :: Getting r CompilerVersion WhichCompiler
whichCompilerL = to whichCompiler