LocalBuildInfo.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}

module Distribution.Types.LocalBuildInfo
  ( -- * The types
    LocalBuildInfo
      ( LocalBuildInfo
      , configFlags
      , flagAssignment
      , componentEnabledSpec
      , extraConfigArgs
      , installDirTemplates
      , compiler
      , hostPlatform
      , pkgDescrFile
      , componentGraph
      , componentNameMap
      , promisedPkgs
      , installedPkgs
      , localPkgDescr
      , withPrograms
      , withPackageDB
      , withVanillaLib
      , withProfLib
      , withSharedLib
      , withStaticLib
      , withDynExe
      , withFullyStaticExe
      , withProfExe
      , withProfLibDetail
      , withProfExeDetail
      , withOptimization
      , withDebugInfo
      , withGHCiLib
      , splitSections
      , splitObjs
      , stripExes
      , stripLibs
      , exeCoverage
      , libCoverage
      , extraCoverageFor
      , relocatable
      , ..
      )

    -- * Convenience accessors
  , localComponentId
  , localUnitId
  , localCompatPackageKey
  , localPackage
  , buildDir
  , buildDirPBD
  , configFlagsBuildDir
  , cabalFilePath
  , progPrefix
  , progSuffix

    -- * Build targets of the 'LocalBuildInfo'.
  , componentNameCLBIs
  -- NB: the primes mean that they take a 'PackageDescription'
  -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.
  -- More logical types would drop this argument, but
  -- at the moment, this is the ONLY supported function, because
  -- 'localPkgDescr' is not guaranteed to match.  At some point
  -- we will fix it and then we can use the (free) unprimed
  -- namespace for the correct commands.
  --
  -- See https://github.com/haskell/cabal/issues/3606 for more
  -- details.

  , componentNameTargets'
  , unitIdTarget'
  , allTargetsInBuildOrder'
  , withAllTargetsInBuildOrder'
  , neededTargetsInBuildOrder'
  , withNeededTargetsInBuildOrder'
  , testCoverage

    -- * Functions you SHOULD NOT USE (yet), but are defined here to

  -- prevent someone from accidentally defining them

  , componentNameTargets
  , unitIdTarget
  , allTargetsInBuildOrder
  , withAllTargetsInBuildOrder
  , neededTargetsInBuildOrder
  , withNeededTargetsInBuildOrder
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Types.ComponentId
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import qualified Distribution.Types.LocalBuildConfig as LBC
import Distribution.Types.PackageDescription
import Distribution.Types.PackageId
import Distribution.Types.TargetInfo
import Distribution.Types.UnitId

import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.InstallDirs hiding
  ( absoluteInstallDirs
  , prefixRelativeInstallDirs
  , substPathTemplate
  )
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Setup.Config
import Distribution.System

import qualified Data.Map as Map
import Distribution.Compat.Graph (Graph)
import qualified Distribution.Compat.Graph as Graph
import System.FilePath ((</>))

-- | Data cached after configuration step.  See also
-- 'Distribution.Simple.Setup.ConfigFlags'.
data LocalBuildInfo = NewLocalBuildInfo
  { localBuildDescr :: LBC.LocalBuildDescr
  -- ^ Information about a package determined by Cabal
  -- after the configuration step.
  , localBuildConfig :: LBC.LocalBuildConfig
  -- ^ Information about a package configuration
  -- that can be modified by the user at configuration time.
  }
  deriving (Generic, Read, Show, Typeable)

{-# COMPLETE LocalBuildInfo #-}

-- | This pattern synonym is for backwards compatibility, to adapt
-- to 'LocalBuildInfo' being split into 'LocalBuildDescr' and 'LocalBuildConfig'.
pattern LocalBuildInfo
  :: ConfigFlags
  -> FlagAssignment
  -> ComponentRequestedSpec
  -> [String]
  -> InstallDirTemplates
  -> Compiler
  -> Platform
  -> Maybe FilePath
  -> Graph ComponentLocalBuildInfo
  -> Map ComponentName [ComponentLocalBuildInfo]
  -> Map (PackageName, ComponentName) ComponentId
  -> InstalledPackageIndex
  -> PackageDescription
  -> ProgramDb
  -> PackageDBStack
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> ProfDetailLevel
  -> ProfDetailLevel
  -> OptimisationLevel
  -> DebugInfoLevel
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> Bool
  -> [UnitId]
  -> Bool
  -> LocalBuildInfo
pattern LocalBuildInfo
  { configFlags
  , flagAssignment
  , componentEnabledSpec
  , extraConfigArgs
  , installDirTemplates
  , compiler
  , hostPlatform
  , pkgDescrFile
  , componentGraph
  , componentNameMap
  , promisedPkgs
  , installedPkgs
  , localPkgDescr
  , withPrograms
  , withPackageDB
  , withVanillaLib
  , withProfLib
  , withSharedLib
  , withStaticLib
  , withDynExe
  , withFullyStaticExe
  , withProfExe
  , withProfLibDetail
  , withProfExeDetail
  , withOptimization
  , withDebugInfo
  , withGHCiLib
  , splitSections
  , splitObjs
  , stripExes
  , stripLibs
  , exeCoverage
  , libCoverage
  , extraCoverageFor
  , relocatable
  } =
  NewLocalBuildInfo
    { localBuildDescr =
      LBC.LocalBuildDescr
        { packageBuildDescr =
          LBC.PackageBuildDescr
            { configFlags
            , flagAssignment
            , componentEnabledSpec
            , compiler
            , hostPlatform
            , localPkgDescr
            , installDirTemplates
            , withPackageDB
            , pkgDescrFile
            , extraCoverageFor
            }
        , componentBuildDescr =
          LBC.ComponentBuildDescr
            { componentGraph
            , componentNameMap
            , promisedPkgs
            , installedPkgs
            }
        }
    , localBuildConfig =
      LBC.LocalBuildConfig
        { extraConfigArgs
        , withPrograms
        , withBuildOptions =
          LBC.BuildOptions
            { withVanillaLib
            , withProfLib
            , withSharedLib
            , withStaticLib
            , withDynExe
            , withFullyStaticExe
            , withProfExe
            , withProfLibDetail
            , withProfExeDetail
            , withOptimization
            , withDebugInfo
            , withGHCiLib
            , splitSections
            , splitObjs
            , stripExes
            , stripLibs
            , exeCoverage
            , libCoverage
            , relocatable
            }
        }
    }

instance Binary LocalBuildInfo
instance Structured LocalBuildInfo

-------------------------------------------------------------------------------
-- Accessor functions

buildDir :: LocalBuildInfo -> FilePath
buildDir lbi =
  buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi

buildDirPBD :: LBC.PackageBuildDescr -> FilePath
buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) =
  configFlagsBuildDir cfg

configFlagsBuildDir :: ConfigFlags -> FilePath
configFlagsBuildDir cfg = fromFlag (configDistPref cfg) </> "build"

cabalFilePath :: LocalBuildInfo -> Maybe FilePath
cabalFilePath (LocalBuildInfo{configFlags = cfg}) =
  flagToMaybe (configCabalFilePath cfg)

progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate
progPrefix (LocalBuildInfo{configFlags = cfg}) =
  fromFlag $ configProgPrefix cfg
progSuffix (LocalBuildInfo{configFlags = cfg}) =
  fromFlag $ configProgSuffix cfg

-- TODO: Get rid of these functions, as much as possible.  They are
-- a bit useful in some cases, but you should be very careful!

-- | Extract the 'ComponentId' from the public library component of a
-- 'LocalBuildInfo' if it exists, or make a fake component ID based
-- on the package ID.
localComponentId :: LocalBuildInfo -> ComponentId
localComponentId lbi =
  case componentNameCLBIs lbi (CLibName LMainLibName) of
    [LibComponentLocalBuildInfo{componentComponentId = cid}] ->
      cid
    _ -> mkComponentId (prettyShow (localPackage lbi))

-- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'.
-- This is a "safe" use of 'localPkgDescr'
localPackage :: LocalBuildInfo -> PackageId
localPackage (LocalBuildInfo{localPkgDescr = pkg}) = package pkg

-- | Extract the 'UnitId' from the library component of a
-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on
-- the package ID.
localUnitId :: LocalBuildInfo -> UnitId
localUnitId lbi =
  case componentNameCLBIs lbi (CLibName LMainLibName) of
    [LibComponentLocalBuildInfo{componentUnitId = uid}] ->
      uid
    _ -> mkLegacyUnitId $ localPackage lbi

-- | Extract the compatibility package key from the public library component of a
-- 'LocalBuildInfo' if it exists, or make a fake package key based
-- on the package ID.
localCompatPackageKey :: LocalBuildInfo -> String
localCompatPackageKey lbi =
  case componentNameCLBIs lbi (CLibName LMainLibName) of
    [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] ->
      pk
    _ -> prettyShow (localPackage lbi)

-- | Convenience function to generate a default 'TargetInfo' from a
-- 'ComponentLocalBuildInfo'.  The idea is to call this once, and then
-- use 'TargetInfo' everywhere else.  Private to this module.
mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo
mkTargetInfo pkg_descr _lbi clbi =
  TargetInfo
    { targetCLBI = clbi
    , -- NB: @pkg_descr@, not @localPkgDescr lbi@!
      targetComponent =
        getComponent
          pkg_descr
          (componentLocalName clbi)
    }

-- | Return all 'TargetInfo's associated with 'ComponentName'.
-- In the presence of Backpack there may be more than one!
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' pkg_descr lbi@(LocalBuildInfo{componentNameMap = comps}) cname =
  case Map.lookup cname comps of
    Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis
    Nothing -> []

unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo
unitIdTarget' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uid =
  case Graph.lookup uid compsGraph of
    Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)
    Nothing -> Nothing

-- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'.
-- In the presence of Backpack there may be more than one!
componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]
componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname =
  case Map.lookup cname comps of
    Just clbis -> clbis
    Nothing -> []

-- TODO: Maybe cache topsort (Graph can do this)

-- | Return the list of default 'TargetInfo's associated with a
-- configured package, in the order they need to be built.
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) =
  map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort compsGraph)

-- | Execute @f@ for every 'TargetInfo' in the package, respecting the
-- build dependency order.  (TODO: We should use Shake!)
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()
withAllTargetsInBuildOrder' pkg_descr lbi f =
  sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi]

-- | Return the list of all targets needed to build the @uids@, in
-- the order they need to be built.
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo]
neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids =
  case Graph.closure compsGraph uids of
    Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids)
    Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos))

-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting
-- the build dependency order.
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()
withNeededTargetsInBuildOrder' pkg_descr lbi uids f =
  sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids]

-- | Is coverage enabled for test suites? In practice, this requires library
-- and executable profiling to be enabled.
testCoverage :: LocalBuildInfo -> Bool
testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) =
  exes && libs

-------------------------------------------------------------------------------
-- Stub functions to prevent someone from accidentally defining them

{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}
componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  componentNameTargets' pkg lbi
unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo
unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  unitIdTarget' pkg lbi
allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  allTargetsInBuildOrder' pkg lbi
withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()
withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  withAllTargetsInBuildOrder' pkg lbi
neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo]
neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  neededTargetsInBuildOrder' pkg lbi
withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()
withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =
  withNeededTargetsInBuildOrder' pkg lbi