{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}

-- | A module providing types and related helper functions used in module

-- "Stack.Build.ConstructPlan".

module Stack.Types.Build.ConstructPlan
  ( PackageInfo (..)
  , CombinedMap
  , M
  , W (..)
  , AddDepRes (..)
  , toTask
  , adrVersion
  , adrHasLibrary
  , Ctx (..)
  , UnregisterState (..)
  , ToolWarning (..)
  ) where

import           Generics.Deriving.Monoid ( mappenddefault, memptydefault )
import           RIO.Process ( HasProcessContext (..) )
import           RIO.State ( StateT )
import           RIO.Writer ( WriterT (..) )
import           Stack.Package ( hasBuildableMainLibrary )
import           Stack.Prelude hiding ( loadPackage )
import           Stack.Types.Build
                    ( Task (..), TaskType (..), taskProvides )
import           Stack.Types.Build.Exception ( ConstructPlanException )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig(..) )
import           Stack.Types.CompilerPaths ( HasCompiler (..) )
import           Stack.Types.Config ( HasConfig (..) )
import           Stack.Types.ConfigureOpts ( BaseConfigOpts )
import           Stack.Types.Curator ( Curator )
import           Stack.Types.DumpPackage ( DumpPackage )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
import           Stack.Types.Installed
                   ( InstallLocation, Installed (..), installedVersion )
import           Stack.Types.Package
                   ( ExeName (..), LocalPackage (..), Package (..)
                   , PackageSource (..)
                   )
import           Stack.Types.ParentMap ( ParentMap )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner (..) )

-- | Type representing information about packages, namely information about

-- whether or not a package is already installed and, unless the package is not

-- to be built (global packages), where its source code is located.

data PackageInfo
  = PIOnlyInstalled InstallLocation Installed
    -- ^ This indicates that the package is already installed, and that we

    -- shouldn't build it from source. This is only the case for global

    -- packages.

  | PIOnlySource PackageSource
    -- ^ This indicates that the package isn't installed, and we know where to

    -- find its source.

  | PIBoth PackageSource Installed
    -- ^ This indicates that the package is installed and we know where to find

    -- its source. We may want to reinstall from source.

  deriving Int -> PackageInfo -> ShowS
[PackageInfo] -> ShowS
PackageInfo -> String
(Int -> PackageInfo -> ShowS)
-> (PackageInfo -> String)
-> ([PackageInfo] -> ShowS)
-> Show PackageInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageInfo -> ShowS
showsPrec :: Int -> PackageInfo -> ShowS
$cshow :: PackageInfo -> String
show :: PackageInfo -> String
$cshowList :: [PackageInfo] -> ShowS
showList :: [PackageInfo] -> ShowS
Show

-- | A type synonym representing dictionaries of package names, and combined

-- information about the package in respect of whether or not it is already

-- installed and, unless the package is not to be built (global packages), where

-- its source code is located.

type CombinedMap = Map PackageName PackageInfo

-- | Type synonym representing values used during the construction of a build

-- plan. The type is an instance of 'Monad', hence its name.

type M =
  WriterT
    W
    -- ^ The output to be collected

    ( StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        -- ^ Library map

        (RIO Ctx)
    )

-- | Type representing values used as the output to be collected during the

-- construction of a build plan.

data W = W
  { W -> Map PackageName (Either ConstructPlanException Task)
wFinals :: !(Map PackageName (Either ConstructPlanException Task))
    -- ^ A dictionary of package names, and either a final task to perform when

    -- building the package or an exception.

  , W -> Map Text InstallLocation
wInstall :: !(Map Text InstallLocation)
    -- ^ A dictionary of executables to be installed, and location where the

    -- executable's binary is placed.

  , W -> Map PackageName Text
wDirty :: !(Map PackageName Text)
    -- ^ A dictionary of local packages, and the reason why the local package is

    -- considered dirty.

  , W -> [StyleDoc] -> [StyleDoc]
wWarnings :: !([StyleDoc] -> [StyleDoc])
    -- ^ Warnings.

  , W -> ParentMap
wParents :: !ParentMap
    -- ^ A dictionary of package names, and a list of pairs of the identifier

    -- of a package depending on the package and the version range specified for

    -- the dependency by that package. Used in the reporting of failure to

    -- construct a build plan.

  }
  deriving (forall x. W -> Rep W x) -> (forall x. Rep W x -> W) -> Generic W
forall x. Rep W x -> W
forall x. W -> Rep W x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. W -> Rep W x
from :: forall x. W -> Rep W x
$cto :: forall x. Rep W x -> W
to :: forall x. Rep W x -> W
Generic

instance Semigroup W where
  <> :: W -> W -> W
(<>) = W -> W -> W
forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault

instance Monoid W where
  mempty :: W
mempty = W
forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
  mappend :: W -> W -> W
mappend = W -> W -> W
forall a. Semigroup a => a -> a -> a
(<>)

-- | Type representing results of 'addDep'.

data AddDepRes
  = ADRToInstall Task
    -- ^ A task must be performed to provide the package name.

  | ADRFound InstallLocation Installed
    -- ^ An existing installation provides the package name.

  deriving Int -> AddDepRes -> ShowS
[AddDepRes] -> ShowS
AddDepRes -> String
(Int -> AddDepRes -> ShowS)
-> (AddDepRes -> String)
-> ([AddDepRes] -> ShowS)
-> Show AddDepRes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddDepRes -> ShowS
showsPrec :: Int -> AddDepRes -> ShowS
$cshow :: AddDepRes -> String
show :: AddDepRes -> String
$cshowList :: [AddDepRes] -> ShowS
showList :: [AddDepRes] -> ShowS
Show

toTask :: AddDepRes -> Maybe Task
toTask :: AddDepRes -> Maybe Task
toTask (ADRToInstall Task
task) = Task -> Maybe Task
forall a. a -> Maybe a
Just Task
task
toTask (ADRFound InstallLocation
_ Installed
_) = Maybe Task
forall a. Maybe a
Nothing

adrVersion :: AddDepRes -> Version
adrVersion :: AddDepRes -> Version
adrVersion (ADRToInstall Task
task) = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
adrVersion (ADRFound InstallLocation
_ Installed
installed) = Installed -> Version
installedVersion Installed
installed

adrHasLibrary :: AddDepRes -> Bool
adrHasLibrary :: AddDepRes -> Bool
adrHasLibrary (ADRToInstall Task
task) = case Task
task.taskType of
  TTLocalMutable LocalPackage
lp -> Package -> Bool
packageHasLibrary LocalPackage
lp.package
  TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package -> Bool
packageHasLibrary Package
p
 where
  -- make sure we consider sub-libraries as libraries too

  packageHasLibrary :: Package -> Bool
  packageHasLibrary :: Package -> Bool
packageHasLibrary Package
p =
    Package -> Bool
hasBuildableMainLibrary Package
p Bool -> Bool -> Bool
|| Bool -> Bool
not (CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
p.subLibraries)
adrHasLibrary (ADRFound InstallLocation
_ Library{}) = Bool
True
adrHasLibrary (ADRFound InstallLocation
_ Executable{}) = Bool
False

-- | Type representing values used as the environment to be read from during the

-- construction of a build plan (the \'context\').

data Ctx = Ctx
  { Ctx -> BaseConfigOpts
baseConfigOpts :: !BaseConfigOpts
    -- ^ Basic information used to determine configure options

  , Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage    :: !(  PackageLocationImmutable
                       -> Map FlagName Bool
                       -> [Text]
                          -- ^ GHC options.

                       -> [Text]
                          -- ^ Cabal configure options.

                       -> M Package
                       )
  , Ctx -> CombinedMap
combinedMap    :: !CombinedMap
    -- ^ A dictionary of package names, and combined information about the

    -- package in respect of whether or not it is already installed and, unless

    -- the package is not to be built (global packages), where its source code

    -- is located.

  , Ctx -> EnvConfig
ctxEnvConfig   :: !EnvConfig
    -- ^ Configuration after the environment has been setup.

  , Ctx -> [PackageName]
callStack      :: ![PackageName]
  , Ctx -> Set PackageName
wanted         :: !(Set PackageName)
  , Ctx -> Set PackageName
localNames     :: !(Set PackageName)
  , Ctx -> Maybe Curator
curator       :: !(Maybe Curator)
  , Ctx -> Text
pathEnvVar     :: !Text
  }

instance HasPlatform Ctx where
  platformL :: Lens' Ctx Platform
platformL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> Ctx
-> f Ctx
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' Ctx PlatformVariant
platformVariantL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> Ctx
-> f Ctx
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 Ctx where
  ghcVariantL :: SimpleGetter Ctx GHCVariant
ghcVariantL = (Config -> Const r Config) -> Ctx -> Const r Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> Const r Config) -> Ctx -> Const r Ctx)
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> Ctx
-> Const r Ctx
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 HasLogFunc Ctx where
  logFuncL :: Lens' Ctx LogFunc
logFuncL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((LogFunc -> f LogFunc) -> Config -> f Config)
-> (LogFunc -> f LogFunc)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogFunc -> f LogFunc) -> Config -> f Config
forall env. HasLogFunc env => Lens' env LogFunc
Lens' Config LogFunc
logFuncL

instance HasRunner Ctx where
  runnerL :: Lens' Ctx Runner
runnerL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> Ctx
-> f Ctx
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 HasStylesUpdate Ctx where
  stylesUpdateL :: Lens' Ctx StylesUpdate
stylesUpdateL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL ((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> Ctx
-> f Ctx
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 Ctx where
  useColorL :: Lens' Ctx Bool
useColorL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL ((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> Ctx
-> f Ctx
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' Ctx Int
termWidthL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL ((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> Ctx
-> f Ctx
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

instance HasConfig Ctx where
  configL :: Lens' Ctx Config
configL = (BuildConfig -> f BuildConfig) -> Ctx -> f Ctx
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' Ctx BuildConfig
buildConfigL ((BuildConfig -> f BuildConfig) -> Ctx -> f Ctx)
-> ((Config -> f Config) -> BuildConfig -> f BuildConfig)
-> (Config -> f Config)
-> Ctx
-> f Ctx
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 (.config) (\BuildConfig
x Config
y -> BuildConfig
x { config = y })
  {-# INLINE configL #-}

instance HasPantryConfig Ctx where
  pantryConfigL :: Lens' Ctx PantryConfig
pantryConfigL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> Ctx
-> f Ctx
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 HasProcessContext Ctx where
  processContextL :: Lens' Ctx ProcessContext
processContextL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL ((Config -> f Config) -> Ctx -> f Ctx)
-> ((ProcessContext -> f ProcessContext) -> Config -> f Config)
-> (ProcessContext -> f ProcessContext)
-> Ctx
-> f Ctx
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 HasBuildConfig Ctx where
  buildConfigL :: Lens' Ctx BuildConfig
buildConfigL = (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL ((EnvConfig -> f EnvConfig) -> Ctx -> f Ctx)
-> ((BuildConfig -> f BuildConfig) -> EnvConfig -> f EnvConfig)
-> (BuildConfig -> f BuildConfig)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> BuildConfig)
-> (EnvConfig -> BuildConfig -> EnvConfig)
-> Lens EnvConfig EnvConfig BuildConfig BuildConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (.buildConfig)
    (\EnvConfig
x BuildConfig
y -> EnvConfig
x { buildConfig = y })

instance HasSourceMap Ctx where
  sourceMapL :: Lens' Ctx SourceMap
sourceMapL = (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL ((EnvConfig -> f EnvConfig) -> Ctx -> f Ctx)
-> ((SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig)
-> (SourceMap -> f SourceMap)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig
forall env. HasSourceMap env => Lens' env SourceMap
Lens' EnvConfig SourceMap
sourceMapL

instance HasCompiler Ctx where
  compilerPathsL :: SimpleGetter Ctx CompilerPaths
compilerPathsL = (EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL ((EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx)
-> ((CompilerPaths -> Const r CompilerPaths)
    -> EnvConfig -> Const r EnvConfig)
-> (CompilerPaths -> Const r CompilerPaths)
-> Ctx
-> Const r Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Const r CompilerPaths)
-> EnvConfig -> Const r EnvConfig
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter EnvConfig CompilerPaths
compilerPathsL

instance HasEnvConfig Ctx where
  envConfigL :: Lens' Ctx EnvConfig
envConfigL = (Ctx -> EnvConfig)
-> (Ctx -> EnvConfig -> Ctx) -> Lens' Ctx EnvConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.ctxEnvConfig) (\Ctx
x EnvConfig
y -> Ctx
x { ctxEnvConfig = y })

-- | State to be maintained during the calculation of local packages to

-- unregister.

data UnregisterState = UnregisterState
  { UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
toUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))
  , UnregisterState -> [DumpPackage]
toKeep :: ![DumpPackage]
  , UnregisterState -> Bool
anyAdded :: !Bool
  }

-- | Warn about tools in the snapshot definition. States the tool name

-- expected and the package name using it.

data ToolWarning
  = ToolWarning ExeName PackageName
  deriving Int -> ToolWarning -> ShowS
[ToolWarning] -> ShowS
ToolWarning -> String
(Int -> ToolWarning -> ShowS)
-> (ToolWarning -> String)
-> ([ToolWarning] -> ShowS)
-> Show ToolWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ToolWarning -> ShowS
showsPrec :: Int -> ToolWarning -> ShowS
$cshow :: ToolWarning -> String
show :: ToolWarning -> String
$cshowList :: [ToolWarning] -> ShowS
showList :: [ToolWarning] -> ShowS
Show