GenericPackageDescription.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Types.GenericPackageDescription (
    GenericPackageDescription(..),
    emptyGenericPackageDescription,
) where

import Prelude ()
import Distribution.Compat.Prelude

-- lens
import Distribution.Compat.Lens                     as L
import qualified Distribution.Types.BuildInfo.Lens  as L

import Distribution.Types.PackageDescription

import Distribution.Types.Benchmark
import Distribution.Types.CondTree
import Distribution.Types.ConfVar
import Distribution.Types.Dependency
import Distribution.Types.Executable
import Distribution.Types.Flag
import Distribution.Types.ForeignLib
import Distribution.Types.Library
import Distribution.Types.TestSuite
import Distribution.Types.UnqualComponentName
import Distribution.Package
import Distribution.Version

-- ---------------------------------------------------------------------------
-- The 'GenericPackageDescription' type

data GenericPackageDescription =
  GenericPackageDescription
  { packageDescription :: PackageDescription
  , gpdScannedVersion  :: Maybe Version
    -- ^ This is a version as specified in source.
    --   We populate this field in index reading for dummy GPDs,
    --   only when GPD reading failed, but scanning haven't.
    --
    --   Cabal-the-library never produces GPDs with Just as gpdScannedVersion.
    --
    --   Perfectly, PackageIndex should have sum type, so we don't need to
    --   have dummy GPDs.
  , genPackageFlags    :: [PackageFlag]
  , condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library)
  , condSubLibraries   :: [( UnqualComponentName
                           , CondTree ConfVar [Dependency] Library )]
  , condForeignLibs    :: [( UnqualComponentName
                           , CondTree ConfVar [Dependency] ForeignLib )]
  , condExecutables    :: [( UnqualComponentName
                           , CondTree ConfVar [Dependency] Executable )]
  , condTestSuites     :: [( UnqualComponentName
                           , CondTree ConfVar [Dependency] TestSuite )]
  , condBenchmarks     :: [( UnqualComponentName
                           , CondTree ConfVar [Dependency] Benchmark )]
  }
    deriving (Show, Eq, Typeable, Data, Generic)

instance Package GenericPackageDescription where
  packageId = packageId . packageDescription

instance Binary GenericPackageDescription
instance Structured GenericPackageDescription
instance NFData GenericPackageDescription where rnf = genericRnf

emptyGenericPackageDescription :: GenericPackageDescription
emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] []

-- -----------------------------------------------------------------------------
-- Traversal Instances

instance L.HasBuildInfos GenericPackageDescription where
    traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
        GenericPackageDescription
            <$> L.traverseBuildInfos f p
            <*> pure v
            <*> pure a1
            <*> (traverse . traverseCondTreeBuildInfo) f x1
            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2
            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3
            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
      where

-- We use this traversal to keep [Dependency] field in CondTree up to date.
traverseCondTreeBuildInfo
    :: forall f comp v. (Applicative f, L.HasBuildInfo comp)
    => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo
traverseCondTreeBuildInfo g = node where
    mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp
    mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches

    node (CondNode comp _ branches) = mkCondNode
        <$> L.buildInfo g comp
        <*> traverse branch branches

    branch (CondBranch v x y) = CondBranch v
        <$> node x
        <*> traverse node y