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

{-|
Module      : Stack.Types.SourceMap
License     : BSD-3-Clause

A source map maps a package name to how it should be built, including source
code, flags and options. This module exports types used in various stages of
source map construction. See @build_overview.md@ for details on these stages.
-}

module Stack.Types.SourceMap
  ( -- * Source map types

    SMWanted (..)
  , SMActual (..)
  , Target (..)
  , PackageType (..)
  , SMTargets (..)
  , SourceMap (..)
    -- * Helper types

  , FromSnapshot (..)
  , DepPackage (..)
  , ProjectPackage (..)
  , ppComponents
  , ppComponentsMaybe
  , ppGPD
  , ppRoot
  , ppVersion
  , CommonPackage (..)
  , GlobalPackageVersion (..)
  , GlobalPackage (..)
  , isReplacedGlobal
  , SourceMapHash (..)
  , smRelDir
  ) where

import qualified Data.Set as Set
import qualified Data.Text as T
import           Distribution.PackageDescription ( GenericPackageDescription )
import qualified Distribution.PackageDescription as C
import qualified Pantry.SHA256 as SHA256
import           Path ( parent, parseRelDir )
import           Stack.Prelude
import           Stack.Types.Compiler ( ActualCompiler )
import           Stack.Types.ComponentUtils ( fromCabalName )
import           Stack.Types.NamedComponent ( NamedComponent (..) )

-- | Settings common to dependency packages ('Stack.Types.SourceMap.DepPackage')

-- and project packages ('Stack.Types.SourceMap.ProjectPackage').

data CommonPackage = CommonPackage
  { CommonPackage -> IO GenericPackageDescription
gpd :: !(IO GenericPackageDescription)
  , CommonPackage -> PackageName
name :: !PackageName
  , CommonPackage -> Map FlagName Bool
flags :: !(Map FlagName Bool)
    -- ^ overrides default flags

  , CommonPackage -> [Text]
ghcOptions :: ![Text]
    -- also lets us know if we're doing profiling

  , CommonPackage -> [Text]
cabalConfigOpts :: ![Text]
  , CommonPackage -> Bool
buildHaddocks :: !Bool
    -- ^ Should Haddock documentation be built for this package?

  }

-- | Flag showing if package comes from a snapshot. Used to ignore dependency

-- bounds between such packages.

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

-- | A view of a dependency package, specified in stack.yaml

data DepPackage = DepPackage
  { DepPackage -> CommonPackage
depCommon :: !CommonPackage
  , DepPackage -> PackageLocation
location :: !PackageLocation
  , DepPackage -> Bool
hidden :: !Bool
    -- ^ Should the package be hidden after registering? Affects the script

    -- interpreter's module name import parser.

  , DepPackage -> FromSnapshot
fromSnapshot :: !FromSnapshot
    -- ^ Needed to ignore bounds between snapshot packages

    -- See https://github.com/commercialhaskell/stackage/issues/3185

  }

-- | A view of a project package. Used to resolve components.

data ProjectPackage = ProjectPackage
  { ProjectPackage -> CommonPackage
projectCommon :: !CommonPackage
  , ProjectPackage -> Path Abs File
cabalFP :: !(Path Abs File)
  , ProjectPackage -> ResolvedPath Dir
resolvedDir :: !(ResolvedPath Dir)
  }

-- | A type representing versions of packages in the global package database.

newtype GlobalPackageVersion
  = GlobalPackageVersion Version

-- | A view of a package installed in the global package database or a marker

-- for a replaced global package. A global package could be replaced because of

-- a replaced dependency.

data GlobalPackage
  = GlobalPackage !Version
  | ReplacedGlobalPackage ![PackageName]
  deriving GlobalPackage -> GlobalPackage -> Bool
(GlobalPackage -> GlobalPackage -> Bool)
-> (GlobalPackage -> GlobalPackage -> Bool) -> Eq GlobalPackage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalPackage -> GlobalPackage -> Bool
== :: GlobalPackage -> GlobalPackage -> Bool
$c/= :: GlobalPackage -> GlobalPackage -> Bool
/= :: GlobalPackage -> GlobalPackage -> Bool
Eq

isReplacedGlobal :: GlobalPackage -> Bool
isReplacedGlobal :: GlobalPackage -> Bool
isReplacedGlobal (ReplacedGlobalPackage [PackageName]
_) = Bool
True
isReplacedGlobal (GlobalPackage Version
_) = Bool
False

-- | A type representing how a package is intended to be built.

data Target
  = TargetAll !PackageType
    -- ^ Build all of the default components.

  | TargetComps !(Set NamedComponent)
    -- ^ Only build specific components


-- | A type representing types of packages.

data PackageType
  = PTProject
    -- ^ The package is a project package.

  | PTDependency
    -- ^ The package is other than a project package and a dependency.

  deriving (PackageType -> PackageType -> Bool
(PackageType -> PackageType -> Bool)
-> (PackageType -> PackageType -> Bool) -> Eq PackageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PackageType -> PackageType -> Bool
== :: PackageType -> PackageType -> Bool
$c/= :: PackageType -> PackageType -> Bool
/= :: PackageType -> PackageType -> Bool
Eq, Int -> PackageType -> ShowS
[PackageType] -> ShowS
PackageType -> String
(Int -> PackageType -> ShowS)
-> (PackageType -> String)
-> ([PackageType] -> ShowS)
-> Show PackageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageType -> ShowS
showsPrec :: Int -> PackageType -> ShowS
$cshow :: PackageType -> String
show :: PackageType -> String
$cshowList :: [PackageType] -> ShowS
showList :: [PackageType] -> ShowS
Show)

-- | A source map with information on the wanted (but not actual) compiler. This

-- is derived by parsing the @stack.yaml@ file for @packages@, @extra-deps@,

-- their configuration (e.g., flags and options), and parsing the snapshot it

-- refers to. It does not include global packages or any information from the

-- command line.

--

-- Invariant: a @PackageName@ appears in either 'SMWanted.project' or

-- 'SMWanted.deps', but not both.

data SMWanted = SMWanted
  { SMWanted -> WantedCompiler
compiler :: !WantedCompiler
  , SMWanted -> Map PackageName ProjectPackage
project :: !(Map PackageName ProjectPackage)
  , SMWanted -> Map PackageName DepPackage
deps :: !(Map PackageName DepPackage)
  , SMWanted -> RawSnapshotLocation
snapshotLocation :: !RawSnapshotLocation
    -- ^ Where this snapshot is loaded from.

  }

-- | A source map with information on the actual compiler, including the

-- contents of its global package database. It does not include any information

-- from the command line.

--

-- Invariant: a @PackageName@ appears in only one of the @Map@s.

data SMActual global = SMActual
  { forall global. SMActual global -> ActualCompiler
compiler :: !ActualCompiler
  , forall global. SMActual global -> Map PackageName ProjectPackage
project :: !(Map PackageName ProjectPackage)
  , forall global. SMActual global -> Map PackageName DepPackage
deps :: !(Map PackageName DepPackage)
  , forall global. SMActual global -> Map PackageName global
globals :: !(Map PackageName global)
  }

-- | Builds on an t'SMActual' by resolving the targets specified on the command

-- line, potentially adding in new dependency packages in the process.

data SMTargets = SMTargets
  { SMTargets -> Map PackageName Target
targets :: !(Map PackageName Target)
  , SMTargets -> Map PackageName DepPackage
deps :: !(Map PackageName DepPackage)
  }

-- | The final source map, taking an t'SMTargets' and applying all command line

-- flags and GHC options.

--

-- One source map value is distinguished from another by a hash of the parts of

-- the value that are immutable.

data SourceMap = SourceMap
  { SourceMap -> SMTargets
targets :: !SMTargets
    -- ^ Doesn't need to be included in the hash, does not affect the source

    -- map.

  , SourceMap -> ActualCompiler
compiler :: !ActualCompiler
    -- ^ Need to hash the compiler version _and_ its installation path. Ideally

    -- there would be some kind of output from GHC telling us some unique ID for

    -- the compiler itself.

  , SourceMap -> Map PackageName ProjectPackage
project :: !(Map PackageName ProjectPackage)
    -- ^ Doesn't need to be included in hash, doesn't affect any of the packages

    -- that get stored in the snapshot database.

  , SourceMap -> Map PackageName DepPackage
deps :: !(Map PackageName DepPackage)
    -- ^ Need to hash all of the immutable dependencies, can ignore the mutable

    -- dependencies.

  , SourceMap -> Map PackageName GlobalPackage
globalPkgs :: !(Map PackageName GlobalPackage)
    -- ^ Doesn't actually need to be hashed, implicitly captured by smCompiler.

    -- Can be broken if someone installs new global packages. We can document

    -- that as not supported, _or_ we could actually include all of this in the

    -- hash and make Stack more resilient.

  }

-- | A unique hash for the immutable portions of a t'SourceMap'.

newtype SourceMapHash
  = SourceMapHash SHA256

-- | Returns relative directory name with source map's hash

smRelDir :: (MonadThrow m) => SourceMapHash -> m (Path Rel Dir)
smRelDir :: forall (m :: * -> *).
MonadThrow m =>
SourceMapHash -> m (Path Rel Dir)
smRelDir (SourceMapHash SHA256
smh) = 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
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SHA256 -> Text
SHA256.toHexText SHA256
smh

ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription
ppGPD :: forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD = IO GenericPackageDescription -> m GenericPackageDescription
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> m GenericPackageDescription)
-> (ProjectPackage -> IO GenericPackageDescription)
-> ProjectPackage
-> m GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.projectCommon.gpd)

-- | Root directory for the given t'ProjectPackage'

ppRoot :: ProjectPackage -> Path Abs Dir
ppRoot :: ProjectPackage -> Path Abs Dir
ppRoot = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir)
-> (ProjectPackage -> Path Abs File)
-> ProjectPackage
-> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.cabalFP)

-- | All components available in the given t'ProjectPackage'

ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)
ppComponents :: forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents = (NamedComponent -> Maybe NamedComponent)
-> ProjectPackage -> m (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
(NamedComponent -> Maybe NamedComponent)
-> ProjectPackage -> m (Set NamedComponent)
ppComponentsMaybe NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just

ppComponentsMaybe ::
     MonadIO m
  => (NamedComponent -> Maybe NamedComponent)
  -> ProjectPackage
  -> m (Set NamedComponent)
ppComponentsMaybe :: forall (m :: * -> *).
MonadIO m =>
(NamedComponent -> Maybe NamedComponent)
-> ProjectPackage -> m (Set NamedComponent)
ppComponentsMaybe NamedComponent -> Maybe NamedComponent
compType ProjectPackage
pp = do
  GenericPackageDescription
gpd <- ProjectPackage -> m GenericPackageDescription
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD ProjectPackage
pp
  Set NamedComponent -> m (Set NamedComponent)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set NamedComponent -> m (Set NamedComponent))
-> Set NamedComponent -> m (Set NamedComponent)
forall a b. (a -> b) -> a -> b
$ [NamedComponent] -> Set NamedComponent
forall a. Ord a => [a] -> Set a
Set.fromList ([NamedComponent] -> Set NamedComponent)
-> [NamedComponent] -> Set NamedComponent
forall a b. (a -> b) -> a -> b
$ [[NamedComponent]] -> [NamedComponent]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [NamedComponent]
-> (CondTree ConfVar [Dependency] Library -> [NamedComponent])
-> Maybe (CondTree ConfVar [Dependency] Library)
-> [NamedComponent]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([NamedComponent]
-> CondTree ConfVar [Dependency] Library -> [NamedComponent]
forall a b. a -> b -> a
const ([NamedComponent]
 -> CondTree ConfVar [Dependency] Library -> [NamedComponent])
-> [NamedComponent]
-> CondTree ConfVar [Dependency] Library
-> [NamedComponent]
forall a b. (a -> b) -> a -> b
$ [Maybe NamedComponent] -> [NamedComponent]
forall a. [Maybe a] -> [a]
catMaybes [NamedComponent -> Maybe NamedComponent
compType NamedComponent
CLib]) (GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
C.condLibrary GenericPackageDescription
gpd)
    , ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> Maybe NamedComponent)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [NamedComponent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((NamedComponent -> Maybe NamedComponent
compType (NamedComponent -> Maybe NamedComponent)
-> (UnqualComponentName -> NamedComponent)
-> UnqualComponentName
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackUnqualCompName -> NamedComponent
CExe (StackUnqualCompName -> NamedComponent)
-> (UnqualComponentName -> StackUnqualCompName)
-> UnqualComponentName
-> NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> StackUnqualCompName
fromCabalName) (UnqualComponentName -> Maybe NamedComponent)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) (GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
C.condExecutables GenericPackageDescription
gpd)
    , ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> Maybe NamedComponent)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [NamedComponent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((NamedComponent -> Maybe NamedComponent
compType (NamedComponent -> Maybe NamedComponent)
-> (UnqualComponentName -> NamedComponent)
-> UnqualComponentName
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackUnqualCompName -> NamedComponent
CTest (StackUnqualCompName -> NamedComponent)
-> (UnqualComponentName -> StackUnqualCompName)
-> UnqualComponentName
-> NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> StackUnqualCompName
fromCabalName) (UnqualComponentName -> Maybe NamedComponent)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
C.condTestSuites GenericPackageDescription
gpd)
    , ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> Maybe NamedComponent)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [NamedComponent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ((NamedComponent -> Maybe NamedComponent
compType (NamedComponent -> Maybe NamedComponent)
-> (UnqualComponentName -> NamedComponent)
-> UnqualComponentName
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackUnqualCompName -> NamedComponent
CBench (StackUnqualCompName -> NamedComponent)
-> (UnqualComponentName -> StackUnqualCompName)
-> UnqualComponentName
-> NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> StackUnqualCompName
fromCabalName) (UnqualComponentName -> Maybe NamedComponent)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> Maybe NamedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> UnqualComponentName
forall a b. (a, b) -> a
fst)
        (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
C.condBenchmarks GenericPackageDescription
gpd)
    ]

-- | Version for the given t'ProjectPackage

ppVersion :: MonadIO m => ProjectPackage -> m Version
ppVersion :: forall (m :: * -> *). MonadIO m => ProjectPackage -> m Version
ppVersion = (GenericPackageDescription -> Version)
-> m GenericPackageDescription -> m Version
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPackageDescription -> Version
gpdVersion (m GenericPackageDescription -> m Version)
-> (ProjectPackage -> m GenericPackageDescription)
-> ProjectPackage
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> m GenericPackageDescription
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD