SourceMap.hs

{-# 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
  { gpd :: !(IO GenericPackageDescription)
  , name :: !PackageName
  , flags :: !(Map FlagName Bool)
    -- ^ overrides default flags
  , ghcOptions :: ![Text]
    -- also lets us know if we're doing profiling
  , cabalConfigOpts :: ![Text]
  , 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 Show

-- | A view of a dependency package, specified in stack.yaml
data DepPackage = DepPackage
  { depCommon :: !CommonPackage
  , location :: !PackageLocation
  , hidden :: !Bool
    -- ^ Should the package be hidden after registering? Affects the script
    -- interpreter's module name import parser.
  , 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
  { projectCommon :: !CommonPackage
  , cabalFP :: !(Path Abs File)
  , 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 Eq

isReplacedGlobal :: GlobalPackage -> Bool
isReplacedGlobal (ReplacedGlobalPackage _) = True
isReplacedGlobal (GlobalPackage _) = 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 (Eq, 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
  { compiler :: !WantedCompiler
  , project :: !(Map PackageName ProjectPackage)
  , deps :: !(Map PackageName DepPackage)
  , 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
  { compiler :: !ActualCompiler
  , project :: !(Map PackageName ProjectPackage)
  , deps :: !(Map PackageName DepPackage)
  , 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
  { targets :: !(Map PackageName Target)
  , 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
  { targets :: !SMTargets
    -- ^ Doesn't need to be included in the hash, does not affect the source
    -- map.
  , 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.
  , 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.
  , deps :: !(Map PackageName DepPackage)
    -- ^ Need to hash all of the immutable dependencies, can ignore the mutable
    -- dependencies.
  , 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 (SourceMapHash smh) = parseRelDir $ T.unpack $ SHA256.toHexText smh

ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription
ppGPD = liftIO . (.projectCommon.gpd)

-- | Root directory for the given t'ProjectPackage'
ppRoot :: ProjectPackage -> Path Abs Dir
ppRoot = parent . (.cabalFP)

-- | All components available in the given t'ProjectPackage'
ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)
ppComponents = ppComponentsMaybe Just

ppComponentsMaybe ::
     MonadIO m
  => (NamedComponent -> Maybe NamedComponent)
  -> ProjectPackage
  -> m (Set NamedComponent)
ppComponentsMaybe compType pp = do
  gpd <- ppGPD pp
  pure $ Set.fromList $ concat
    [ maybe [] (const $ catMaybes [compType CLib]) (C.condLibrary gpd)
    , mapMaybe ((compType . CExe . fromCabalName) . fst) (C.condExecutables gpd)
    , mapMaybe ((compType . CTest . fromCabalName) . fst) (C.condTestSuites gpd)
    , mapMaybe
        ((compType . CBench . fromCabalName) . fst)
        (C.condBenchmarks gpd)
    ]

-- | Version for the given t'ProjectPackage
ppVersion :: MonadIO m => ProjectPackage -> m Version
ppVersion = fmap gpdVersion . ppGPD