{-# LANGUAGE NoImplicitPrelude #-}

module Stack.Types.EnvConfig
  ( EnvConfig (..)
  , HasEnvConfig (..)
  , HasSourceMap (..)
  , actualCompilerVersionL
  , appropriateGhcColorFlag
  , bindirCompilerTools
  , compilerVersionDir
  , extraBinDirs
  , hoogleDatabasePath
  , hoogleRoot
  , hpcReportDir
  , installationRootDeps
  , installationRootLocal
  , packageDatabaseDeps
  , packageDatabaseExtra
  , packageDatabaseLocal
  , platformGhcRelDir
  , platformGhcVerOnlyRelDir
  , platformSnapAndCompilerRel
  , shouldForceGhcColorFlag
  , snapshotsDir
  , useShaPathOnWindows
  , shaPathForBytes
  ) where

import           Crypto.Hash ( SHA1 (..), hashWith )
import qualified Data.ByteArray.Encoding as Mem ( Base(Base16), convertToBase )
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
import qualified Distribution.Text ( display )
import           Distribution.Version ( mkVersion )
import           Path
                   ( (</>), parseAbsDir, parseAbsFile, parseRelDir
                   , parseRelFile
                   )
import           RIO.Process ( HasProcessContext (..) )
import           Stack.Constants
                   ( bindirSuffix, ghcColorForceFlag, osIsWindows, relDirCompilerTools
                   , relDirHoogle, relDirHpc, relDirInstall, relDirPkgdb
                   , relDirSnapshots, relFileDatabaseHoo
                   )
import           Stack.Prelude
import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..), getProjectWorkDir )
import           Stack.Types.BuildOpts ( BuildOptsCLI )
import           Stack.Types.Compiler
                   ( ActualCompiler (..), compilerVersionString, getGhcVersion )
import           Stack.Types.CompilerBuild ( compilerBuildSuffix )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..) )
import           Stack.Types.Config ( HasConfig (..), stackRootL )
import           Stack.Types.FileDigestCache ( FileDigestCache )
import           Stack.Types.GHCVariant ( HasGHCVariant (..), ghcVariantSuffix )
import           Stack.Types.Platform
                   ( HasPlatform (..), platformVariantSuffix )
import           Stack.Types.Runner ( HasRunner (..) )
import           Stack.Types.SourceMap
                   ( SourceMap (..), SourceMapHash, smRelDir )

-- | Configuration after the environment has been setup.

data EnvConfig = EnvConfig
  { EnvConfig -> BuildConfig
envConfigBuildConfig :: !BuildConfig
  , EnvConfig -> BuildOptsCLI
envConfigBuildOptsCLI :: !BuildOptsCLI
  , EnvConfig -> FileDigestCache
envConfigFileDigestCache :: !FileDigestCache
  , EnvConfig -> SourceMap
envConfigSourceMap :: !SourceMap
  , EnvConfig -> SourceMapHash
envConfigSourceMapHash :: !SourceMapHash
  , EnvConfig -> CompilerPaths
envConfigCompilerPaths :: !CompilerPaths
  }

instance HasConfig EnvConfig where
  configL :: Lens' EnvConfig Config
configL = (BuildConfig -> f BuildConfig) -> EnvConfig -> f EnvConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' EnvConfig BuildConfig
buildConfigL((BuildConfig -> f BuildConfig) -> EnvConfig -> f EnvConfig)
-> ((Config -> f Config) -> BuildConfig -> f BuildConfig)
-> (Config -> f Config)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Config)
-> (BuildConfig -> Config -> BuildConfig)
-> Lens BuildConfig BuildConfig Config Config
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BuildConfig -> Config
bcConfig (\BuildConfig
x Config
y -> BuildConfig
x { bcConfig :: Config
bcConfig = Config
y })
  {-# INLINE configL #-}

instance HasBuildConfig EnvConfig where
  buildConfigL :: Lens' EnvConfig BuildConfig
buildConfigL = (EnvConfig -> f EnvConfig) -> EnvConfig -> f EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' EnvConfig EnvConfig
envConfigL((EnvConfig -> f EnvConfig) -> EnvConfig -> f EnvConfig)
-> ((BuildConfig -> f BuildConfig) -> EnvConfig -> f EnvConfig)
-> (BuildConfig -> f BuildConfig)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> BuildConfig)
-> (EnvConfig -> BuildConfig -> EnvConfig)
-> Lens' EnvConfig BuildConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    EnvConfig -> BuildConfig
envConfigBuildConfig
    (\EnvConfig
x BuildConfig
y -> EnvConfig
x { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
y })

instance HasPlatform EnvConfig where
  platformL :: Lens' EnvConfig Platform
platformL = (Config -> f Config) -> EnvConfig -> f EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> f Config) -> EnvConfig -> f EnvConfig)
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Platform -> f Platform) -> Config -> f Config
forall env. HasPlatform env => Lens' env Platform
Lens' Config Platform
platformL
  {-# INLINE platformL #-}
  platformVariantL :: Lens' EnvConfig PlatformVariant
platformVariantL = (Config -> f Config) -> EnvConfig -> f EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> f Config) -> EnvConfig -> f EnvConfig)
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PlatformVariant -> f PlatformVariant) -> Config -> f Config
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' Config PlatformVariant
platformVariantL
  {-# INLINE platformVariantL #-}

instance HasGHCVariant EnvConfig where
  ghcVariantL :: SimpleGetter EnvConfig GHCVariant
ghcVariantL = (Config -> Const r Config) -> EnvConfig -> Const r EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> Const r Config) -> EnvConfig -> Const r EnvConfig)
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> EnvConfig
-> Const r EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GHCVariant -> Const r GHCVariant) -> Config -> Const r Config
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter Config GHCVariant
ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasProcessContext EnvConfig where
  processContextL :: Lens' EnvConfig ProcessContext
processContextL = (Config -> f Config) -> EnvConfig -> f EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> f Config) -> EnvConfig -> f EnvConfig)
-> ((ProcessContext -> f ProcessContext) -> Config -> f Config)
-> (ProcessContext -> f ProcessContext)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> Config -> f Config
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' Config ProcessContext
processContextL

instance HasPantryConfig EnvConfig where
  pantryConfigL :: Lens' EnvConfig PantryConfig
pantryConfigL = (Config -> f Config) -> EnvConfig -> f EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> f Config) -> EnvConfig -> f EnvConfig)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> Config -> f Config
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' Config PantryConfig
pantryConfigL

instance HasCompiler EnvConfig where
  compilerPathsL :: SimpleGetter EnvConfig CompilerPaths
compilerPathsL = (EnvConfig -> CompilerPaths)
-> SimpleGetter EnvConfig CompilerPaths
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> CompilerPaths
envConfigCompilerPaths

instance HasRunner EnvConfig where
  runnerL :: Lens' EnvConfig Runner
runnerL = (Config -> f Config) -> EnvConfig -> f EnvConfig
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL((Config -> f Config) -> EnvConfig -> f EnvConfig)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> Config -> f Config
forall env. HasRunner env => Lens' env Runner
Lens' Config Runner
runnerL

instance HasLogFunc EnvConfig where
  logFuncL :: Lens' EnvConfig LogFunc
logFuncL = (Runner -> f Runner) -> EnvConfig -> f EnvConfig
forall env. HasRunner env => Lens' env Runner
Lens' EnvConfig Runner
runnerL((Runner -> f Runner) -> EnvConfig -> f EnvConfig)
-> ((LogFunc -> f LogFunc) -> Runner -> f Runner)
-> (LogFunc -> f LogFunc)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> Runner -> f Runner
forall env. HasLogFunc env => Lens' env LogFunc
Lens' Runner LogFunc
logFuncL

instance HasStylesUpdate EnvConfig where
  stylesUpdateL :: Lens' EnvConfig StylesUpdate
stylesUpdateL = (Runner -> f Runner) -> EnvConfig -> f EnvConfig
forall env. HasRunner env => Lens' env Runner
Lens' EnvConfig Runner
runnerL((Runner -> f Runner) -> EnvConfig -> f EnvConfig)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> Runner -> f Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL

instance HasTerm EnvConfig where
  useColorL :: Lens' EnvConfig Bool
useColorL = (Runner -> f Runner) -> EnvConfig -> f EnvConfig
forall env. HasRunner env => Lens' env Runner
Lens' EnvConfig Runner
runnerL((Runner -> f Runner) -> EnvConfig -> f EnvConfig)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Bool
Lens' Runner Bool
useColorL
  termWidthL :: Lens' EnvConfig Int
termWidthL = (Runner -> f Runner) -> EnvConfig -> f EnvConfig
forall env. HasRunner env => Lens' env Runner
Lens' EnvConfig Runner
runnerL((Runner -> f Runner) -> EnvConfig -> f EnvConfig)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> EnvConfig
-> f EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Int
Lens' Runner Int
termWidthL

class (HasBuildConfig env, HasSourceMap env, HasCompiler env) => HasEnvConfig env where
  envConfigL :: Lens' env EnvConfig

instance HasEnvConfig EnvConfig where
  envConfigL :: Lens' EnvConfig EnvConfig
envConfigL = (EnvConfig -> f EnvConfig) -> EnvConfig -> f EnvConfig
forall a. a -> a
id
  {-# INLINE envConfigL #-}

class HasSourceMap env where
  sourceMapL :: Lens' env SourceMap

instance HasSourceMap EnvConfig where
  sourceMapL :: Lens' EnvConfig SourceMap
sourceMapL = (EnvConfig -> SourceMap)
-> (EnvConfig -> SourceMap -> EnvConfig)
-> Lens' EnvConfig SourceMap
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens EnvConfig -> SourceMap
envConfigSourceMap (\EnvConfig
x SourceMap
y -> EnvConfig
x { envConfigSourceMap :: SourceMap
envConfigSourceMap = SourceMap
y })

shouldForceGhcColorFlag ::
     (HasEnvConfig env, HasRunner env)
  => RIO env Bool
shouldForceGhcColorFlag :: forall env. (HasEnvConfig env, HasRunner env) => RIO env Bool
shouldForceGhcColorFlag = do
  Bool
canDoColor <- (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
2, Int
1]) (Version -> Bool)
-> (ActualCompiler -> Version) -> ActualCompiler -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> Version
getGhcVersion
            (ActualCompiler -> Bool) -> RIO env ActualCompiler -> RIO env Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  Bool
shouldDoColor <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasTerm env => Lens' env Bool
Lens' env Bool
useColorL
  Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Bool
canDoColor Bool -> Bool -> Bool
&& Bool
shouldDoColor

appropriateGhcColorFlag ::
     (HasEnvConfig env, HasRunner env)
  => RIO env (Maybe String)
appropriateGhcColorFlag :: forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe String)
appropriateGhcColorFlag = Bool -> Maybe String
f (Bool -> Maybe String) -> RIO env Bool -> RIO env (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env Bool
forall env. (HasEnvConfig env, HasRunner env) => RIO env Bool
shouldForceGhcColorFlag
 where
  f :: Bool -> Maybe String
f Bool
True = String -> Maybe String
forall a. a -> Maybe a
Just String
ghcColorForceFlag
  f Bool
False = Maybe String
forall a. Maybe a
Nothing

-- | Directory containing snapshots

snapshotsDir ::
     (HasEnvConfig env, MonadReader env m, MonadThrow m)
  => m (Path Abs Dir)
snapshotsDir :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Abs Dir)
snapshotsDir = do
  Path Abs Dir
root <- Getting (Path Abs Dir) env (Path Abs Dir) -> m (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' env (Path Abs Dir)
stackRootL
  Path Rel Dir
platform <- m (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir
  Path Abs Dir -> m (Path Abs Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> m (Path Abs Dir))
-> Path Abs Dir -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirSnapshots Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
platform

-- | Installation root for dependencies

installationRootDeps :: HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps = do
  Path Abs Dir
root <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' env (Path Abs Dir)
stackRootL
  -- TODO: also useShaPathOnWindows here, once #1173 is resolved.

  Path Rel Dir
psc <- RIO env (Path Rel Dir)
forall env. HasEnvConfig env => RIO env (Path Rel Dir)
platformSnapAndCompilerRel
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirSnapshots Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
psc

-- | Installation root for locals

installationRootLocal :: HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal = do
  Path Abs Dir
workDir <- RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasBuildConfig env, MonadReader env m) =>
m (Path Abs Dir)
getProjectWorkDir
  Path Rel Dir
psc <- Path Rel Dir -> RIO env (Path Rel Dir)
forall (m :: * -> *).
MonadThrow m =>
Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows (Path Rel Dir -> RIO env (Path Rel Dir))
-> RIO env (Path Rel Dir) -> RIO env (Path Rel Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RIO env (Path Rel Dir)
forall env. HasEnvConfig env => RIO env (Path Rel Dir)
platformSnapAndCompilerRel
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
workDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInstall Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
psc

-- | Get the hoogle database path.

hoogleDatabasePath :: HasEnvConfig env => RIO env (Path Abs File)
hoogleDatabasePath :: forall env. HasEnvConfig env => RIO env (Path Abs File)
hoogleDatabasePath = do
  Path Abs Dir
dir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hoogleRoot
  Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileDatabaseHoo)

-- | Path for platform followed by snapshot name followed by compiler

-- name.

platformSnapAndCompilerRel :: HasEnvConfig env => RIO env (Path Rel Dir)
platformSnapAndCompilerRel :: forall env. HasEnvConfig env => RIO env (Path Rel Dir)
platformSnapAndCompilerRel = do
  Path Rel Dir
platform <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir
  SourceMapHash
smh <- Getting SourceMapHash env SourceMapHash -> RIO env SourceMapHash
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMapHash env SourceMapHash -> RIO env SourceMapHash)
-> Getting SourceMapHash env SourceMapHash -> RIO env SourceMapHash
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMapHash EnvConfig)
-> env -> Const SourceMapHash env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL((EnvConfig -> Const SourceMapHash EnvConfig)
 -> env -> Const SourceMapHash env)
-> ((SourceMapHash -> Const SourceMapHash SourceMapHash)
    -> EnvConfig -> Const SourceMapHash EnvConfig)
-> Getting SourceMapHash env SourceMapHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMapHash)
-> SimpleGetter EnvConfig SourceMapHash
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMapHash
envConfigSourceMapHash
  Path Rel Dir
name <- SourceMapHash -> RIO env (Path Rel Dir)
forall (m :: * -> *).
MonadThrow m =>
SourceMapHash -> m (Path Rel Dir)
smRelDir SourceMapHash
smh
  Path Rel Dir
ghc <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
compilerVersionDir
  Path Rel Dir -> RIO env (Path Rel Dir)
forall (m :: * -> *).
MonadThrow m =>
Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows (Path Rel Dir
platform Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
name Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
ghc)

-- | Relative directory for the platform and GHC identifier

platformGhcRelDir ::
     (HasEnvConfig env, MonadReader env m, MonadThrow m)
  => m (Path Rel Dir)
platformGhcRelDir :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir = do
  CompilerPaths
cp <- Getting CompilerPaths env CompilerPaths -> m CompilerPaths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CompilerPaths env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL
  let cbSuffix :: String
cbSuffix = CompilerBuild -> String
compilerBuildSuffix (CompilerBuild -> String) -> CompilerBuild -> String
forall a b. (a -> b) -> a -> b
$ CompilerPaths -> CompilerBuild
cpBuild CompilerPaths
cp
  String
verOnly <- m String
forall env (m :: * -> *).
(HasGHCVariant env, HasPlatform env, MonadReader env m) =>
m String
platformGhcVerOnlyRelDirStr
  String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir ([String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
verOnly, String
cbSuffix ])

-- | Installation root for compiler tools

bindirCompilerTools ::
     (HasEnvConfig env, MonadReader env m, MonadThrow m)
  => m (Path Abs Dir)
bindirCompilerTools :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Abs Dir)
bindirCompilerTools = do
  Config
config <- Getting Config env Config -> m Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  Path Rel Dir
platform <- m (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir
  ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> m ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  Path Rel Dir
compiler <- String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> m (Path Rel Dir)) -> String -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ ActualCompiler -> String
compilerVersionString ActualCompiler
compilerVersion
  Path Abs Dir -> m (Path Abs Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> m (Path Abs Dir))
-> Path Abs Dir -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
    Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' Config (Path Abs Dir)
stackRootL Config
config Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>
    Path Rel Dir
relDirCompilerTools Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>
    Path Rel Dir
platform Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>
    Path Rel Dir
compiler Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>
    Path Rel Dir
bindirSuffix

-- | Hoogle directory.

hoogleRoot :: HasEnvConfig env => RIO env (Path Abs Dir)
hoogleRoot :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hoogleRoot = do
  Path Abs Dir
workDir <- RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasBuildConfig env, MonadReader env m) =>
m (Path Abs Dir)
getProjectWorkDir
  Path Rel Dir
psc <- Path Rel Dir -> RIO env (Path Rel Dir)
forall (m :: * -> *).
MonadThrow m =>
Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows (Path Rel Dir -> RIO env (Path Rel Dir))
-> RIO env (Path Rel Dir) -> RIO env (Path Rel Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RIO env (Path Rel Dir)
forall env. HasEnvConfig env => RIO env (Path Rel Dir)
platformSnapAndCompilerRel
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
workDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirHoogle Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
psc

compilerVersionDir ::
     (HasEnvConfig env, MonadReader env m, MonadThrow m)
  => m (Path Rel Dir)
compilerVersionDir :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
compilerVersionDir = do
  ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> m ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> m (Path Rel Dir)) -> String -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ case ActualCompiler
compilerVersion of
    ACGhc Version
version -> Version -> String
versionString Version
version
    ACGhcGit {} -> ActualCompiler -> String
compilerVersionString ActualCompiler
compilerVersion

-- | Package database for installing dependencies into

packageDatabaseDeps :: HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps = do
  Path Abs Dir
root <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPkgdb

-- | Package database for installing local packages into

packageDatabaseLocal :: HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal = do
  Path Abs Dir
root <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPkgdb

-- | Extra package databases

packageDatabaseExtra ::
     (HasEnvConfig env, MonadReader env m)
  => m [Path Abs Dir]
packageDatabaseExtra :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m) =>
m [Path Abs Dir]
packageDatabaseExtra = Getting [Path Abs Dir] env [Path Abs Dir] -> m [Path Abs Dir]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [Path Abs Dir] env [Path Abs Dir] -> m [Path Abs Dir])
-> Getting [Path Abs Dir] env [Path Abs Dir] -> m [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> env -> Const [Path Abs Dir] env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL((BuildConfig -> Const [Path Abs Dir] BuildConfig)
 -> env -> Const [Path Abs Dir] env)
-> (([Path Abs Dir] -> Const [Path Abs Dir] [Path Abs Dir])
    -> BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> Getting [Path Abs Dir] env [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> [Path Abs Dir])
-> SimpleGetter BuildConfig [Path Abs Dir]
forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> [Path Abs Dir]
bcExtraPackageDBs

-- | Where HPC reports and tix files get stored.

hpcReportDir :: HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir :: forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir = do
  Path Abs Dir
root <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirHpc

-- | Get the extra bin directories (for the PATH). Puts more local first

--

-- Bool indicates whether or not to include the locals

extraBinDirs :: HasEnvConfig env => RIO env (Bool -> [Path Abs Dir])
extraBinDirs :: forall env. HasEnvConfig env => RIO env (Bool -> [Path Abs Dir])
extraBinDirs = do
  Path Abs Dir
deps <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
  Path Abs Dir
local' <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  Path Abs Dir
tools <- RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Abs Dir)
bindirCompilerTools
  (Bool -> [Path Abs Dir]) -> RIO env (Bool -> [Path Abs Dir])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool -> [Path Abs Dir]) -> RIO env (Bool -> [Path Abs Dir]))
-> (Bool -> [Path Abs Dir]) -> RIO env (Bool -> [Path Abs Dir])
forall a b. (a -> b) -> a -> b
$ \Bool
locals -> if Bool
locals
    then [Path Abs Dir
local' Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix, Path Abs Dir
deps Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix, Path Abs Dir
tools]
    else [Path Abs Dir
deps Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix, Path Abs Dir
tools]

-- | The version of the compiler which will actually be used. May be different

-- than that specified in the 'SnapshotDef' and returned by

-- 'wantedCompilerVersionL'.

actualCompilerVersionL :: HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL :: forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL = (SourceMap -> Const r SourceMap) -> env -> Const r env
forall env. HasSourceMap env => Lens' env SourceMap
Lens' env SourceMap
sourceMapL((SourceMap -> Const r SourceMap) -> env -> Const r env)
-> ((ActualCompiler -> Const r ActualCompiler)
    -> SourceMap -> Const r SourceMap)
-> (ActualCompiler -> Const r ActualCompiler)
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SourceMap -> ActualCompiler)
-> SimpleGetter SourceMap ActualCompiler
forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> ActualCompiler
smCompiler

-- | Relative directory for the platform and GHC identifier without GHC bindist

-- build

platformGhcVerOnlyRelDir ::
     (HasGHCVariant env, HasPlatform env, MonadReader env m, MonadThrow m)
  => m (Path Rel Dir)
platformGhcVerOnlyRelDir :: forall env (m :: * -> *).
(HasGHCVariant env, HasPlatform env, MonadReader env m,
 MonadThrow m) =>
m (Path Rel Dir)
platformGhcVerOnlyRelDir =
  String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> m (Path Rel Dir)) -> m String -> m (Path Rel Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m String
forall env (m :: * -> *).
(HasGHCVariant env, HasPlatform env, MonadReader env m) =>
m String
platformGhcVerOnlyRelDirStr

-- | Relative directory for the platform and GHC identifier without GHC bindist

-- build (before parsing into a Path)

platformGhcVerOnlyRelDirStr ::
     (HasGHCVariant env, HasPlatform env, MonadReader env m)
  => m FilePath
platformGhcVerOnlyRelDirStr :: forall env (m :: * -> *).
(HasGHCVariant env, HasPlatform env, MonadReader env m) =>
m String
platformGhcVerOnlyRelDirStr = do
  Platform
platform <- Getting Platform env Platform -> m Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  PlatformVariant
platformVariant <- Getting PlatformVariant env PlatformVariant -> m PlatformVariant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PlatformVariant env PlatformVariant
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' env PlatformVariant
platformVariantL
  GHCVariant
ghcVariant <- Getting GHCVariant env GHCVariant -> m GHCVariant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GHCVariant env GHCVariant
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter env GHCVariant
ghcVariantL
  String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ Platform -> String
forall a. Pretty a => a -> String
Distribution.Text.display Platform
platform
                   , PlatformVariant -> String
platformVariantSuffix PlatformVariant
platformVariant
                   , GHCVariant -> String
ghcVariantSuffix GHCVariant
ghcVariant ]

-- | This is an attempt to shorten Stack paths on Windows to decrease our

-- chances of hitting 260 symbol path limit. The idea is to calculate

-- SHA1 hash of the path used on other architectures, encode with base

-- 16 and take first 8 symbols of it.

useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows :: forall (m :: * -> *).
MonadThrow m =>
Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows
  | Bool
osIsWindows = Path Rel Dir -> m (Path Rel Dir)
forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
Path Rel t -> m (Path Rel t)
shaPath
  | Bool
otherwise = Path Rel Dir -> m (Path Rel Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)
shaPath :: forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
Path Rel t -> m (Path Rel t)
shaPath = ByteString -> m (Path Rel t)
forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes (ByteString -> m (Path Rel t))
-> (Path Rel t -> ByteString) -> Path Rel t -> m (Path Rel t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Path Rel t -> Text) -> Path Rel t -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Path Rel t -> String) -> Path Rel t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel t -> String
forall b t. Path b t -> String
toFilePath

shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t)
shaPathForBytes :: forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes
  = String -> m (Path Rel t)
forall b t (m :: * -> *).
(IsPath b t, MonadThrow m) =>
String -> m (Path b t)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel t)
parsePath (String -> m (Path Rel t))
-> (ByteString -> String) -> ByteString -> m (Path Rel t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
S8.take Int
8
  (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
Mem.convertToBase Base
Mem.Base16 (Digest SHA1 -> ByteString)
-> (ByteString -> Digest SHA1) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> ByteString -> Digest SHA1
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA1
SHA1

-- TODO: Move something like this into the path package. Consider

-- subsuming path-io's 'AnyPath'?

class IsPath b t where
  parsePath :: MonadThrow m => FilePath -> m (Path b t)

instance IsPath Abs Dir where
  parsePath :: forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parsePath = String -> m (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir

instance IsPath Rel Dir where
  parsePath :: forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parsePath = String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir

instance IsPath Abs File where
  parsePath :: forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parsePath = String -> m (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile

instance IsPath Rel File where
  parsePath :: forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parsePath = String -> m (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile