{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.Types.Plan
Description : Plan-related types and functions.
License     : BSD-3-Clause

Plan-related types and functions.
-}

module Stack.Types.Plan
  ( Plan (..)
  , Task (..)
  , TaskType (..)
  , TaskConfigOpts (..)
  , taskAnyMissing
  , taskIsTarget
  , taskLocation
  , taskProvides
  , taskTargetIsMutable
  , taskTypeLocation
  , taskTypePackageIdentifier
  , installLocationIsMutable
  ) where

import           Data.List as L
import qualified RIO.Set as Set
import           Stack.Prelude
import           Stack.Types.Cache ( CachePkgSrc )
import           Stack.Types.ComponentUtils ( StackUnqualCompName )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts, PackageConfigureOpts )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.Package
                   ( InstallLocation (..), LocalPackage (..), Package (..)
                   , packageIdentifier
                   )

-- | A complete plan of what needs to be built and how to do it

data Plan = Plan
  { Plan -> Map PackageName Task
tasks :: !(Map PackageName Task)
  , Plan -> Map PackageName Task
finals :: !(Map PackageName Task)
    -- ^ Final actions to be taken (test, benchmark, etc)

  , Plan -> Map GhcPkgId (PackageIdentifier, Text)
unregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text))
    -- ^ Text is reason we're unregistering, for display only

  , Plan -> Map StackUnqualCompName InstallLocation
installExes :: !(Map StackUnqualCompName InstallLocation)
    -- ^ Executables that should be installed after successful building

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

-- | A type representing tasks to perform when building.

data Task = Task
  { Task -> TaskType
taskType        :: !TaskType
    -- ^ The task type, telling us how to build this

  , Task -> TaskConfigOpts
configOpts      :: !TaskConfigOpts
    -- ^ A set of the package identifiers of dependencies for which 'GhcPkgId'

    -- are missing and a function which yields configure options, given a

    -- dictionary of those identifiers and their 'GhcPkgId'.

  , Task -> Bool
buildHaddocks   :: !Bool
  , Task -> Map PackageIdentifier GhcPkgId
present         :: !(Map PackageIdentifier GhcPkgId)
    -- ^ A dictionary of the package identifiers of already-installed

    -- dependencies, and their 'GhcPkgId'.

  , Task -> Bool
allInOne        :: !Bool
    -- ^ indicates that the package can be built in one step

  , Task -> CachePkgSrc
cachePkgSrc     :: !CachePkgSrc
  , Task -> Bool
buildTypeConfig :: !Bool
    -- ^ Is the build type of this package Configure. Check out

    -- ensureConfigureScript in Stack.Build.Execute for the motivation

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

-- | Type representing different types of task, depending on what is to be

-- built.

data TaskType
  = TTLocalMutable LocalPackage
    -- ^ Building local source code.

  | TTRemotePackage IsMutable Package PackageLocationImmutable
    -- ^ Building something from the package index (upstream).

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

-- | Given the IDs of any missing packages, produce the configure options

data TaskConfigOpts = TaskConfigOpts
  { TaskConfigOpts -> Set PackageIdentifier
missing :: !(Set PackageIdentifier)
    -- ^ Dependencies for which we don't yet have a 'GhcPkgId'

  , TaskConfigOpts -> EnvConfig
envConfig :: !EnvConfig
  , TaskConfigOpts -> BaseConfigOpts
baseConfigOpts :: !BaseConfigOpts
  , TaskConfigOpts -> Bool
isLocalNonExtraDep :: !Bool
  , TaskConfigOpts -> IsMutable
isMutable :: !IsMutable
  , TaskConfigOpts -> PackageConfigureOpts
pkgConfigOpts :: PackageConfigureOpts
  }

instance Show TaskConfigOpts where
  show :: TaskConfigOpts -> String
show TaskConfigOpts
tco = String
"Missing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set PackageIdentifier -> String
forall a. Show a => a -> String
show TaskConfigOpts
tco.missing

-- | Were any of the dependencies missing?


taskAnyMissing :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskAnyMissing Task
task = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Task
task.configOpts.missing

-- | A function to yield the package name and version of a given 'TaskType'

-- value.

taskTypePackageIdentifier :: TaskType -> PackageIdentifier
taskTypePackageIdentifier :: TaskType -> PackageIdentifier
taskTypePackageIdentifier (TTLocalMutable LocalPackage
lp) = Package -> PackageIdentifier
packageIdentifier LocalPackage
lp.package
taskTypePackageIdentifier (TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_) = Package -> PackageIdentifier
packageIdentifier Package
p

taskIsTarget :: Task -> Bool
taskIsTarget :: Task -> Bool
taskIsTarget Task
t =
  case Task
t.taskType of
    TTLocalMutable LocalPackage
lp -> LocalPackage
lp.wanted
    TaskType
_ -> Bool
False

-- | A function to yield the relevant database (write-only or mutable) of a

-- given 'TaskType' value.

taskTypeLocation :: TaskType -> InstallLocation
taskTypeLocation :: TaskType -> InstallLocation
taskTypeLocation (TTLocalMutable LocalPackage
_) = InstallLocation
Local
taskTypeLocation (TTRemotePackage IsMutable
Mutable Package
_ PackageLocationImmutable
_) = InstallLocation
Local
taskTypeLocation (TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
_) = InstallLocation
Snap

-- | A function to yield the relevant database (write-only or mutable) of the

-- given task.

taskLocation :: Task -> InstallLocation
taskLocation :: Task -> InstallLocation
taskLocation = TaskType -> InstallLocation
taskTypeLocation (TaskType -> InstallLocation)
-> (Task -> TaskType) -> Task -> InstallLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.taskType)

-- | A function to yield the package name and version to be built by the given

-- task.

taskProvides :: Task -> PackageIdentifier
taskProvides :: Task -> PackageIdentifier
taskProvides = TaskType -> PackageIdentifier
taskTypePackageIdentifier (TaskType -> PackageIdentifier)
-> (Task -> TaskType) -> Task -> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.taskType)

taskTargetIsMutable :: Task -> IsMutable
taskTargetIsMutable :: Task -> IsMutable
taskTargetIsMutable Task
task =
  case Task
task.taskType of
    TTLocalMutable LocalPackage
_ -> IsMutable
Mutable
    TTRemotePackage IsMutable
mutable Package
_ PackageLocationImmutable
_ -> IsMutable
mutable

installLocationIsMutable :: InstallLocation -> IsMutable
installLocationIsMutable :: InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
Snap = IsMutable
Immutable
installLocationIsMutable InstallLocation
Local = IsMutable
Mutable