{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}

-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ReadyComponent
  ( ReadyComponent (..)
  , InstantiatedComponent (..)
  , IndefiniteComponent (..)
  , rc_depends
  , rc_uid
  , rc_pkgid
  , dispReadyComponent
  , toReadyComponents
  ) where

import Distribution.Compat.Prelude hiding ((<>))
import Prelude ()

import Distribution.Backpack
import Distribution.Backpack.LinkedComponent
import Distribution.Backpack.ModuleShape

import Distribution.Compat.Graph (IsNode (..))
import Distribution.Types.AnnotatedId
import Distribution.Types.Component
import Distribution.Types.ComponentId
import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentName
import Distribution.Types.Library
import Distribution.Types.LibraryName
import Distribution.Types.Module
import Distribution.Types.ModuleRenaming
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
import Distribution.Types.PackageId
import Distribution.Types.PackageName.Magic
import Distribution.Types.UnitId

import Distribution.ModuleName
import Distribution.Package
import Distribution.Simple.Utils

import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.PrettyPrint

import Distribution.Pretty
import Distribution.Version

-- | A 'ReadyComponent' is one that we can actually generate build
-- products for.  We have a ready component for the typecheck-only
-- products of every indefinite package, as well as a ready component
-- for every way these packages can be fully instantiated.
data ReadyComponent = ReadyComponent
  { ReadyComponent -> AnnotatedId UnitId
rc_ann_id :: AnnotatedId UnitId
  , ReadyComponent -> OpenUnitId
rc_open_uid :: OpenUnitId
  -- ^ The 'OpenUnitId' for this package.  At the moment, this
  -- is used in only one case, which is to determine if an
  -- export is of a module from this library (indefinite
  -- libraries record these exports as 'OpenModule');
  -- 'rc_open_uid' can be conveniently used to test for
  -- equality, whereas 'UnitId' cannot always be used in this
  -- case.
  , ReadyComponent -> ComponentId
rc_cid :: ComponentId
  -- ^ Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'
  -- records a 'ComponentId', it coincides with this one.
  , ReadyComponent -> Component
rc_component :: Component
  -- ^ Corresponds to 'lc_component'.
  , ReadyComponent -> [AnnotatedId UnitId]
rc_exe_deps :: [AnnotatedId UnitId]
  -- ^ Corresponds to 'lc_exe_deps'.
  -- Build-tools don't participate in mix-in linking.
  -- (but what if they could?)
  , ReadyComponent -> Bool
rc_public :: Bool
  -- ^ Corresponds to 'lc_public'.
  , ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i :: Either IndefiniteComponent InstantiatedComponent
  -- ^ Extra metadata depending on whether or not this is an
  -- indefinite library (typechecked only) or an instantiated
  -- component (can be compiled).
  }

-- | The final, string 'UnitId' that will uniquely identify
-- the compilation products of this component.
rc_uid :: ReadyComponent -> UnitId
rc_uid :: ReadyComponent -> UnitId
rc_uid = AnnotatedId UnitId -> UnitId
forall id. AnnotatedId id -> id
ann_id (AnnotatedId UnitId -> UnitId)
-> (ReadyComponent -> AnnotatedId UnitId)
-> ReadyComponent
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadyComponent -> AnnotatedId UnitId
rc_ann_id

-- | Corresponds to 'lc_pkgid'.
rc_pkgid :: ReadyComponent -> PackageId
rc_pkgid :: ReadyComponent -> PackageId
rc_pkgid = AnnotatedId UnitId -> PackageId
forall id. AnnotatedId id -> PackageId
ann_pid (AnnotatedId UnitId -> PackageId)
-> (ReadyComponent -> AnnotatedId UnitId)
-> ReadyComponent
-> PackageId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadyComponent -> AnnotatedId UnitId
rc_ann_id

-- | An 'InstantiatedComponent' is a library which is fully instantiated
-- (or, possibly, has no requirements at all.)
data InstantiatedComponent = InstantiatedComponent
  { InstantiatedComponent -> [(ModuleName, Module)]
instc_insts :: [(ModuleName, Module)]
  -- ^ How this library was instantiated.
  , InstantiatedComponent -> [(UnitId, MungedPackageId)]
instc_insts_deps :: [(UnitId, MungedPackageId)]
  -- ^ Dependencies induced by 'instc_insts'.  These are recorded
  -- here because there isn't a convenient way otherwise to get
  -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.
  , InstantiatedComponent -> Map ModuleName Module
instc_provides :: Map ModuleName Module
  -- ^ The modules exported/reexported by this library.
  , InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
  -- ^ The dependencies which need to be passed to the compiler
  -- to bring modules into scope.  These always refer to installed
  -- fully instantiated libraries.
  }

-- | An 'IndefiniteComponent' is a library with requirements
-- which we will typecheck only.
data IndefiniteComponent = IndefiniteComponent
  { IndefiniteComponent -> [ModuleName]
indefc_requires :: [ModuleName]
  -- ^ The requirements of the library.
  , IndefiniteComponent -> Map ModuleName OpenModule
indefc_provides :: Map ModuleName OpenModule
  -- ^ The modules exported/reexported by this library.
  , IndefiniteComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
  -- ^ The dependencies which need to be passed to the compiler
  -- to bring modules into scope.  These are 'OpenUnitId' because
  -- these may refer to partially instantiated libraries.
  }

-- | Compute the dependencies of a 'ReadyComponent' that should
-- be recorded in the @depends@ field of 'InstalledPackageInfo'.
rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends ReadyComponent
rc = [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a. Ord a => [a] -> [a]
ordNub ([(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)])
-> [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a b. (a -> b) -> a -> b
$
  case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
    Left IndefiniteComponent
indefc ->
      (ComponentInclude OpenUnitId ModuleRenaming
 -> (UnitId, MungedPackageId))
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [(UnitId, MungedPackageId)]
forall a b. (a -> b) -> [a] -> [b]
map
        (\ComponentInclude OpenUnitId ModuleRenaming
ci -> (OpenUnitId -> UnitId
abstractUnitId (OpenUnitId -> UnitId) -> OpenUnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci, ComponentInclude OpenUnitId ModuleRenaming -> MungedPackageId
forall id rn.
Pretty id =>
ComponentInclude id rn -> MungedPackageId
toMungedPackageId ComponentInclude OpenUnitId ModuleRenaming
ci))
        (IndefiniteComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes IndefiniteComponent
indefc)
    Right InstantiatedComponent
instc ->
      (ComponentInclude DefUnitId ModuleRenaming
 -> (UnitId, MungedPackageId))
-> [ComponentInclude DefUnitId ModuleRenaming]
-> [(UnitId, MungedPackageId)]
forall a b. (a -> b) -> [a] -> [b]
map
        (\ComponentInclude DefUnitId ModuleRenaming
ci -> (DefUnitId -> UnitId
unDefUnitId (DefUnitId -> UnitId) -> DefUnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ ComponentInclude DefUnitId ModuleRenaming -> DefUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude DefUnitId ModuleRenaming
ci, ComponentInclude DefUnitId ModuleRenaming -> MungedPackageId
forall id rn.
Pretty id =>
ComponentInclude id rn -> MungedPackageId
toMungedPackageId ComponentInclude DefUnitId ModuleRenaming
ci))
        (InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes InstantiatedComponent
instc)
        [(UnitId, MungedPackageId)]
-> [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a. [a] -> [a] -> [a]
++ InstantiatedComponent -> [(UnitId, MungedPackageId)]
instc_insts_deps InstantiatedComponent
instc
  where
    toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId
    toMungedPackageId :: forall id rn.
Pretty id =>
ComponentInclude id rn -> MungedPackageId
toMungedPackageId ComponentInclude id rn
ci =
      PackageId -> LibraryName -> MungedPackageId
computeCompatPackageId
        (ComponentInclude id rn -> PackageId
forall id rn. ComponentInclude id rn -> PackageId
ci_pkgid ComponentInclude id rn
ci)
        ( case ComponentInclude id rn -> ComponentName
forall id rn. ComponentInclude id rn -> ComponentName
ci_cname ComponentInclude id rn
ci of
            CLibName LibraryName
name -> LibraryName
name
            ComponentName
_ ->
              [Char] -> LibraryName
forall a. HasCallStack => [Char] -> a
error ([Char] -> LibraryName) -> [Char] -> LibraryName
forall a b. (a -> b) -> a -> b
$
                ComponentId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (ReadyComponent -> ComponentId
rc_cid ReadyComponent
rc)
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" depends on non-library "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ id -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (ComponentInclude id rn -> id
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude id rn
ci)
        )

-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is
-- a library.
rc_munged_id :: ReadyComponent -> MungedPackageId
rc_munged_id :: ReadyComponent -> MungedPackageId
rc_munged_id ReadyComponent
rc =
  PackageId -> LibraryName -> MungedPackageId
computeCompatPackageId
    (ReadyComponent -> PackageId
rc_pkgid ReadyComponent
rc)
    ( case ReadyComponent -> Component
rc_component ReadyComponent
rc of
        CLib Library
lib -> Library -> LibraryName
libName Library
lib
        Component
_ -> [Char] -> LibraryName
forall a. HasCallStack => [Char] -> a
error [Char]
"rc_munged_id: not library"
    )

instance Package ReadyComponent where
  packageId :: ReadyComponent -> PackageId
packageId = ReadyComponent -> PackageId
rc_pkgid

instance HasUnitId ReadyComponent where
  installedUnitId :: ReadyComponent -> UnitId
installedUnitId = ReadyComponent -> UnitId
rc_uid

instance IsNode ReadyComponent where
  type Key ReadyComponent = UnitId
  nodeKey :: ReadyComponent -> Key ReadyComponent
nodeKey = ReadyComponent -> Key ReadyComponent
ReadyComponent -> UnitId
rc_uid
  nodeNeighbors :: ReadyComponent -> [Key ReadyComponent]
nodeNeighbors ReadyComponent
rc =
    ( case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
        Right InstantiatedComponent
inst
          | [] <- InstantiatedComponent -> [(ModuleName, Module)]
instc_insts InstantiatedComponent
inst ->
              []
          | Bool
otherwise ->
              [ComponentId -> UnitId
newSimpleUnitId (ReadyComponent -> ComponentId
rc_cid ReadyComponent
rc)]
        Either IndefiniteComponent InstantiatedComponent
_ -> []
    )
      [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
ordNub (((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst (ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends ReadyComponent
rc))
      [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ (AnnotatedId UnitId -> UnitId) -> [AnnotatedId UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map AnnotatedId UnitId -> UnitId
forall id. AnnotatedId id -> id
ann_id (ReadyComponent -> [AnnotatedId UnitId]
rc_exe_deps ReadyComponent
rc)

dispReadyComponent :: ReadyComponent -> Doc
dispReadyComponent :: ReadyComponent -> Doc
dispReadyComponent ReadyComponent
rc =
  Doc -> Int -> Doc -> Doc
hang
    ( [Char] -> Doc
text
        ( case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
            Left IndefiniteComponent
_ -> [Char]
"indefinite"
            Right InstantiatedComponent
_ -> [Char]
"definite"
        )
        Doc -> Doc -> Doc
<+> UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (ReadyComponent -> Key ReadyComponent
forall a. IsNode a => a -> Key a
nodeKey ReadyComponent
rc)
        {- <+> dispModSubst (Map.fromList (lc_insts lc)) -}
    )
    Int
4
    (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
      [ [Char] -> Doc
text [Char]
"depends" Doc -> Doc -> Doc
<+> UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty UnitId
uid
      | UnitId
uid <- ReadyComponent -> [Key ReadyComponent]
forall a. IsNode a => a -> [Key a]
nodeNeighbors ReadyComponent
rc
      ]

-- | The state of 'InstM'; a mapping from 'UnitId's to their
-- ready component, or @Nothing@ if its an external
-- component which we don't know how to build.
type InstS = Map UnitId (Maybe ReadyComponent)

-- | A state monad for doing instantiations (can't use actual
-- State because that would be an extra dependency.)
newtype InstM a = InstM {forall a. InstM a -> InstS -> (a, InstS)
runInstM :: InstS -> (a, InstS)}

instance Functor InstM where
  fmap :: forall a b. (a -> b) -> InstM a -> InstM b
fmap a -> b
f (InstM InstS -> (a, InstS)
m) = (InstS -> (b, InstS)) -> InstM b
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (b, InstS)) -> InstM b)
-> (InstS -> (b, InstS)) -> InstM b
forall a b. (a -> b) -> a -> b
$ \InstS
s ->
    let (a
x, InstS
s') = InstS -> (a, InstS)
m InstS
s
     in (a -> b
f a
x, InstS
s')

instance Applicative InstM where
  pure :: forall a. a -> InstM a
pure a
a = (InstS -> (a, InstS)) -> InstM a
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (a, InstS)) -> InstM a)
-> (InstS -> (a, InstS)) -> InstM a
forall a b. (a -> b) -> a -> b
$ \InstS
s -> (a
a, InstS
s)
  InstM InstS -> (a -> b, InstS)
f <*> :: forall a b. InstM (a -> b) -> InstM a -> InstM b
<*> InstM InstS -> (a, InstS)
x = (InstS -> (b, InstS)) -> InstM b
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (b, InstS)) -> InstM b)
-> (InstS -> (b, InstS)) -> InstM b
forall a b. (a -> b) -> a -> b
$ \InstS
s ->
    let (a -> b
f', InstS
s') = InstS -> (a -> b, InstS)
f InstS
s
        (a
x', InstS
s'') = InstS -> (a, InstS)
x InstS
s'
     in (a -> b
f' a
x', InstS
s'')

instance Monad InstM where
  return :: forall a. a -> InstM a
return = a -> InstM a
forall a. a -> InstM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  InstM InstS -> (a, InstS)
m >>= :: forall a b. InstM a -> (a -> InstM b) -> InstM b
>>= a -> InstM b
f = (InstS -> (b, InstS)) -> InstM b
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (b, InstS)) -> InstM b)
-> (InstS -> (b, InstS)) -> InstM b
forall a b. (a -> b) -> a -> b
$ \InstS
s ->
    let (a
x, InstS
s') = InstS -> (a, InstS)
m InstS
s
     in InstM b -> InstS -> (b, InstS)
forall a. InstM a -> InstS -> (a, InstS)
runInstM (a -> InstM b
f a
x) InstS
s'

-- | Given a list of 'LinkedComponent's, expand the module graph
-- so that we have an instantiated graph containing all of the
-- instantiated components we need to build.
--
-- Instantiation intuitively follows the following algorithm:
--
--      instantiate a definite unit id p[S]:
--          recursively instantiate each module M in S
--          recursively instantiate modules exported by this unit
--          recursively instantiate dependencies substituted by S
--
-- The implementation is a bit more involved to memoize instantiation
-- if we have done it already.
--
-- We also call 'improveUnitId' during this process, so that fully
-- instantiated components are given 'HashedUnitId'.
toReadyComponents
  :: Map UnitId MungedPackageId
  -> Map ModuleName Module -- subst for the public component
  -> [LinkedComponent]
  -> [ReadyComponent]
toReadyComponents :: Map UnitId MungedPackageId
-> Map ModuleName Module -> [LinkedComponent] -> [ReadyComponent]
toReadyComponents Map UnitId MungedPackageId
pid_map Map ModuleName Module
subst0 [LinkedComponent]
comps =
  [Maybe ReadyComponent] -> [ReadyComponent]
forall a. [Maybe a] -> [a]
catMaybes (InstS -> [Maybe ReadyComponent]
forall k a. Map k a -> [a]
Map.elems InstS
ready_map)
  where
    cmap :: Map ComponentId LinkedComponent
cmap = [(ComponentId, LinkedComponent)] -> Map ComponentId LinkedComponent
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc, LinkedComponent
lc) | LinkedComponent
lc <- [LinkedComponent]
comps]

    instantiateUnitId
      :: ComponentId
      -> Map ModuleName Module
      -> InstM DefUnitId
    instantiateUnitId :: ComponentId -> Map ModuleName Module -> InstM DefUnitId
instantiateUnitId ComponentId
cid Map ModuleName Module
insts = (InstS -> (DefUnitId, InstS)) -> InstM DefUnitId
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (DefUnitId, InstS)) -> InstM DefUnitId)
-> (InstS -> (DefUnitId, InstS)) -> InstM DefUnitId
forall a b. (a -> b) -> a -> b
$ \InstS
s ->
      case UnitId -> InstS -> Maybe (Maybe ReadyComponent)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid InstS
s of
        Maybe (Maybe ReadyComponent)
Nothing ->
          -- Knot tied
          let (Maybe ReadyComponent
r, InstS
s') =
                InstM (Maybe ReadyComponent)
-> InstS -> (Maybe ReadyComponent, InstS)
forall a. InstM a -> InstS -> (a, InstS)
runInstM
                  (UnitId
-> ComponentId
-> Map ModuleName Module
-> InstM (Maybe ReadyComponent)
instantiateComponent UnitId
uid ComponentId
cid Map ModuleName Module
insts)
                  (UnitId -> Maybe ReadyComponent -> InstS -> InstS
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
uid Maybe ReadyComponent
r InstS
s)
           in (DefUnitId
def_uid, UnitId -> Maybe ReadyComponent -> InstS -> InstS
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
uid Maybe ReadyComponent
r InstS
s')
        Just Maybe ReadyComponent
_ -> (DefUnitId
def_uid, InstS
s)
      where
        -- The mkDefUnitId here indicates that we assume
        -- that Cabal handles unit id hash allocation.
        -- Good thing about hashing here: map is only on string.
        -- Bad thing: have to repeatedly hash.
        def_uid :: DefUnitId
def_uid = ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId ComponentId
cid Map ModuleName Module
insts
        uid :: UnitId
uid = DefUnitId -> UnitId
unDefUnitId DefUnitId
def_uid

    instantiateComponent
      :: UnitId
      -> ComponentId
      -> Map ModuleName Module
      -> InstM (Maybe ReadyComponent)
    instantiateComponent :: UnitId
-> ComponentId
-> Map ModuleName Module
-> InstM (Maybe ReadyComponent)
instantiateComponent UnitId
uid ComponentId
cid Map ModuleName Module
insts
      | Just LinkedComponent
lc <- ComponentId
-> Map ComponentId LinkedComponent -> Maybe LinkedComponent
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid Map ComponentId LinkedComponent
cmap = do
          provides <- (OpenModule -> InstM Module)
-> Map ModuleName OpenModule -> InstM (Map ModuleName Module)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse (Map ModuleName Module -> OpenModule -> InstM Module
substModule Map ModuleName Module
insts) (ModuleShape -> Map ModuleName OpenModule
modShapeProvides (LinkedComponent -> ModuleShape
lc_shape LinkedComponent
lc))
          -- NB: lc_sig_includes is omitted here, because we don't
          -- need them to build
          includes <- forM (lc_includes lc) $ \ComponentInclude OpenUnitId ModuleRenaming
ci -> do
            uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
insts (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci)
            return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)}
          exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)
          s <- InstM $ \InstS
s -> (InstS
s, InstS
s)
          let getDep (Module DefUnitId
dep_def_uid ModuleName
_)
                | let dep_uid :: UnitId
dep_uid = DefUnitId -> UnitId
unDefUnitId DefUnitId
dep_def_uid =
                    -- Lose DefUnitId invariant for rc_depends
                    [
                      ( UnitId
dep_uid
                      , MungedPackageId -> Maybe MungedPackageId -> MungedPackageId
forall a. a -> Maybe a -> a
fromMaybe MungedPackageId
err_pid (Maybe MungedPackageId -> MungedPackageId)
-> Maybe MungedPackageId -> MungedPackageId
forall a b. (a -> b) -> a -> b
$
                          UnitId -> Map UnitId MungedPackageId -> Maybe MungedPackageId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
dep_uid Map UnitId MungedPackageId
pid_map
                            Maybe MungedPackageId
-> Maybe MungedPackageId -> Maybe MungedPackageId
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ReadyComponent -> MungedPackageId)
-> Maybe ReadyComponent -> Maybe MungedPackageId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReadyComponent -> MungedPackageId
rc_munged_id (Maybe (Maybe ReadyComponent) -> Maybe ReadyComponent
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (UnitId -> InstS -> Maybe (Maybe ReadyComponent)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
dep_uid InstS
s))
                      )
                    ]
                where
                  err_pid :: MungedPackageId
err_pid =
                    MungedPackageName -> Version -> MungedPackageId
MungedPackageId
                      (PackageName -> LibraryName -> MungedPackageName
MungedPackageName PackageName
nonExistentPackageThisIsCabalBug LibraryName
LMainLibName)
                      ([Int] -> Version
mkVersion [Int
0])
              instc =
                InstantiatedComponent
                  { instc_insts :: [(ModuleName, Module)]
instc_insts = Map ModuleName Module -> [(ModuleName, Module)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ModuleName Module
insts
                  , instc_insts_deps :: [(UnitId, MungedPackageId)]
instc_insts_deps = (Module -> [(UnitId, MungedPackageId)])
-> [Module] -> [(UnitId, MungedPackageId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Module -> [(UnitId, MungedPackageId)]
getDep (Map ModuleName Module -> [Module]
forall k a. Map k a -> [a]
Map.elems Map ModuleName Module
insts)
                  , instc_provides :: Map ModuleName Module
instc_provides = Map ModuleName Module
provides
                  , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
instc_includes = [ComponentInclude DefUnitId ModuleRenaming]
includes
                  -- NB: there is no dependency on the
                  -- indefinite version of this instantiated package here,
                  -- as (1) it doesn't go in depends in the
                  -- IPI: it's not a run time dep, and (2)
                  -- we don't have to tell GHC about it, it
                  -- will match up the ComponentId
                  -- automatically
                  }
          return $
            Just
              ReadyComponent
                { rc_ann_id = (lc_ann_id lc){ann_id = uid}
                , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid)
                , rc_cid = lc_cid lc
                , rc_component = lc_component lc
                , rc_exe_deps = exe_deps
                , rc_public = lc_public lc
                , rc_i = Right instc
                }
      | Bool
otherwise = Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReadyComponent
forall a. Maybe a
Nothing

    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
_ (DefiniteUnitId DefUnitId
uid) =
      DefUnitId -> InstM DefUnitId
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return DefUnitId
uid
    substUnitId Map ModuleName Module
subst (IndefFullUnitId ComponentId
cid Map ModuleName OpenModule
insts) = do
      insts' <- Map ModuleName Module
-> Map ModuleName OpenModule -> InstM (Map ModuleName Module)
substSubst Map ModuleName Module
subst Map ModuleName OpenModule
insts
      instantiateUnitId cid insts'

    -- NB: NOT composition
    substSubst
      :: Map ModuleName Module
      -> Map ModuleName OpenModule
      -> InstM (Map ModuleName Module)
    substSubst :: Map ModuleName Module
-> Map ModuleName OpenModule -> InstM (Map ModuleName Module)
substSubst Map ModuleName Module
subst Map ModuleName OpenModule
insts = (OpenModule -> InstM Module)
-> Map ModuleName OpenModule -> InstM (Map ModuleName Module)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse (Map ModuleName Module -> OpenModule -> InstM Module
substModule Map ModuleName Module
subst) Map ModuleName OpenModule
insts

    substModule :: Map ModuleName Module -> OpenModule -> InstM Module
    substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule Map ModuleName Module
subst (OpenModuleVar ModuleName
mod_name)
      | Just Module
m <- ModuleName -> Map ModuleName Module -> Maybe Module
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name Map ModuleName Module
subst = Module -> InstM Module
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
      | Bool
otherwise = [Char] -> InstM Module
forall a. HasCallStack => [Char] -> a
error [Char]
"substModule: non-closing substitution"
    substModule Map ModuleName Module
subst (OpenModule OpenUnitId
uid ModuleName
mod_name) = do
      uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
subst OpenUnitId
uid
      return (Module uid' mod_name)

    substExeDep
      :: Map ModuleName Module
      -> AnnotatedId OpenUnitId
      -> InstM (AnnotatedId UnitId)
    substExeDep :: Map ModuleName Module
-> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
substExeDep Map ModuleName Module
insts AnnotatedId OpenUnitId
exe_aid = do
      exe_uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
insts (AnnotatedId OpenUnitId -> OpenUnitId
forall id. AnnotatedId id -> id
ann_id AnnotatedId OpenUnitId
exe_aid)
      return exe_aid{ann_id = unDefUnitId exe_uid'}

    indefiniteUnitId :: ComponentId -> InstM UnitId
    indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId ComponentId
cid = do
      let uid :: UnitId
uid = ComponentId -> UnitId
newSimpleUnitId ComponentId
cid
      r <- UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent UnitId
uid ComponentId
cid
      InstM $ \InstS
s -> (UnitId
uid, UnitId -> Maybe ReadyComponent -> InstS -> InstS
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
uid Maybe ReadyComponent
r InstS
s)

    indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
    indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent UnitId
uid ComponentId
cid
      | Just LinkedComponent
lc <- ComponentId
-> Map ComponentId LinkedComponent -> Maybe LinkedComponent
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid Map ComponentId LinkedComponent
cmap = do
          -- We're going to process includes, in case some of them
          -- are fully definite even without any substitution.  We
          -- want to build those too; see #5634.
          inst_includes <- [ComponentInclude OpenUnitId ModuleRenaming]
-> (ComponentInclude OpenUnitId ModuleRenaming
    -> InstM (ComponentInclude OpenUnitId ModuleRenaming))
-> InstM [ComponentInclude OpenUnitId ModuleRenaming]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_includes LinkedComponent
lc) ((ComponentInclude OpenUnitId ModuleRenaming
  -> InstM (ComponentInclude OpenUnitId ModuleRenaming))
 -> InstM [ComponentInclude OpenUnitId ModuleRenaming])
-> (ComponentInclude OpenUnitId ModuleRenaming
    -> InstM (ComponentInclude OpenUnitId ModuleRenaming))
-> InstM [ComponentInclude OpenUnitId ModuleRenaming]
forall a b. (a -> b) -> a -> b
$ \ComponentInclude OpenUnitId ModuleRenaming
ci ->
            if Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null (OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci))
              then do
                uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
forall k a. Map k a
Map.empty (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci)
                return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)}
              else ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude OpenUnitId ModuleRenaming)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentInclude OpenUnitId ModuleRenaming
ci
          exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)
          let indefc =
                IndefiniteComponent
                  { indefc_requires :: [ModuleName]
indefc_requires = ((ModuleName, OpenModule) -> ModuleName)
-> [(ModuleName, OpenModule)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, OpenModule) -> ModuleName
forall a b. (a, b) -> a
fst (LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts LinkedComponent
lc)
                  , indefc_provides :: Map ModuleName OpenModule
indefc_provides = ModuleShape -> Map ModuleName OpenModule
modShapeProvides (LinkedComponent -> ModuleShape
lc_shape LinkedComponent
lc)
                  , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes = [ComponentInclude OpenUnitId ModuleRenaming]
inst_includes [ComponentInclude OpenUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
forall a. [a] -> [a] -> [a]
++ LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes LinkedComponent
lc
                  }
          return $
            Just
              ReadyComponent
                { rc_ann_id = (lc_ann_id lc){ann_id = uid}
                , rc_cid = lc_cid lc
                , rc_open_uid = lc_uid lc
                , rc_component = lc_component lc
                , -- It's always fully built
                  rc_exe_deps = exe_deps
                , rc_public = lc_public lc
                , rc_i = Left indefc
                }
      | Bool
otherwise = Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReadyComponent
forall a. Maybe a
Nothing

    ready_map :: InstS
ready_map = ((), InstS) -> InstS
forall a b. (a, b) -> b
snd (((), InstS) -> InstS) -> ((), InstS) -> InstS
forall a b. (a -> b) -> a -> b
$ InstM () -> InstS -> ((), InstS)
forall a. InstM a -> InstS -> (a, InstS)
runInstM InstM ()
work InstS
forall k a. Map k a
Map.empty

    work :: InstM ()
work
      -- Top-level instantiation per subst0
      | Bool -> Bool
not (Map ModuleName Module -> Bool
forall k a. Map k a -> Bool
Map.null Map ModuleName Module
subst0)
      , [LinkedComponent
lc] <- (LinkedComponent -> Bool) -> [LinkedComponent] -> [LinkedComponent]
forall a. (a -> Bool) -> [a] -> [a]
filter LinkedComponent -> Bool
lc_public (Map ComponentId LinkedComponent -> [LinkedComponent]
forall k a. Map k a -> [a]
Map.elems Map ComponentId LinkedComponent
cmap) =
          do
            _ <- ComponentId -> Map ModuleName Module -> InstM DefUnitId
instantiateUnitId (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) Map ModuleName Module
subst0
            return ()
      | Bool
otherwise =
          [LinkedComponent] -> (LinkedComponent -> InstM ()) -> InstM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ComponentId LinkedComponent -> [LinkedComponent]
forall k a. Map k a -> [a]
Map.elems Map ComponentId LinkedComponent
cmap) ((LinkedComponent -> InstM ()) -> InstM ())
-> (LinkedComponent -> InstM ()) -> InstM ()
forall a b. (a -> b) -> a -> b
$ \LinkedComponent
lc ->
            if [(ModuleName, OpenModule)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts LinkedComponent
lc)
              then ComponentId -> Map ModuleName Module -> InstM DefUnitId
instantiateUnitId (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) Map ModuleName Module
forall k a. Map k a
Map.empty InstM DefUnitId -> InstM () -> InstM ()
forall a b. InstM a -> InstM b -> InstM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> InstM ()
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else ComponentId -> InstM UnitId
indefiniteUnitId (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) InstM UnitId -> InstM () -> InstM ()
forall a b. InstM a -> InstM b -> InstM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> InstM ()
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()