{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternGuards #-}
-- | 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 Prelude ()
import Distribution.Compat.Prelude hiding ((<>))

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

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

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

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

import Distribution.Version
import Distribution.Pretty

-- | 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,
        -- | 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 -> OpenUnitId
rc_open_uid     :: OpenUnitId,
        -- | Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'
        -- records a 'ComponentId', it coincides with this one.
        ReadyComponent -> ComponentId
rc_cid          :: ComponentId,
        -- | Corresponds to 'lc_component'.
        ReadyComponent -> Component
rc_component    :: Component,
        -- | Corresponds to 'lc_exe_deps'.
        -- Build-tools don't participate in mix-in linking.
        -- (but what if they could?)
        ReadyComponent -> [AnnotatedId UnitId]
rc_exe_deps     :: [AnnotatedId UnitId],
        -- | Corresponds to 'lc_public'.
        ReadyComponent -> Bool
rc_public       :: Bool,
        -- | Extra metadata depending on whether or not this is an
        -- indefinite library (typechecked only) or an instantiated
        -- component (can be compiled).
        ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i            :: Either IndefiniteComponent InstantiatedComponent
    }

-- | The final, string 'UnitId' that will uniquely identify
-- the compilation products of this component.
rc_uid          :: ReadyComponent -> UnitId
rc_uid :: ReadyComponent -> UnitId
rc_uid = forall id. AnnotatedId id -> id
ann_id 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 = forall id. AnnotatedId id -> PackageId
ann_pid 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 {
        -- | How this library was instantiated.
        InstantiatedComponent -> [(ModuleName, Module)]
instc_insts    :: [(ModuleName, Module)],
        -- | 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 -> [(UnitId, MungedPackageId)]
instc_insts_deps :: [(UnitId, MungedPackageId)],
        -- | The modules exported/reexported by this library.
        InstantiatedComponent -> Map ModuleName Module
instc_provides :: Map ModuleName Module,
        -- | The dependencies which need to be passed to the compiler
        -- to bring modules into scope.  These always refer to installed
        -- fully instantiated libraries.
        InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
    }

-- | An 'IndefiniteComponent' is a library with requirements
-- which we will typecheck only.
data IndefiniteComponent
    = IndefiniteComponent {
        -- | The requirements of the library.
        IndefiniteComponent -> [ModuleName]
indefc_requires :: [ModuleName],
        -- | The modules exported/reexported by this library.
        IndefiniteComponent -> Map ModuleName OpenModule
indefc_provides :: Map ModuleName OpenModule,
        -- | 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.
        IndefiniteComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
    }

-- | 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 = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$
    case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
        Left IndefiniteComponent
indefc ->
            forall a b. (a -> b) -> [a] -> [b]
map (\ComponentInclude OpenUnitId ModuleRenaming
ci -> (OpenUnitId -> UnitId
abstractUnitId forall a b. (a -> b) -> a -> b
$ forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci, 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 ->
            forall a b. (a -> b) -> [a] -> [b]
map (\ComponentInclude DefUnitId ModuleRenaming
ci -> (DefUnitId -> UnitId
unDefUnitId forall a b. (a -> b) -> a -> b
$ forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude DefUnitId ModuleRenaming
ci, forall id rn.
Pretty id =>
ComponentInclude id rn -> MungedPackageId
toMungedPackageId ComponentInclude DefUnitId ModuleRenaming
ci))
                (InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes InstantiatedComponent
instc)
              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
            (forall id rn. ComponentInclude id rn -> PackageId
ci_pkgid ComponentInclude id rn
ci)
            (case forall id rn. ComponentInclude id rn -> ComponentName
ci_cname ComponentInclude id rn
ci of
                CLibName LibraryName
name -> LibraryName
name
                ComponentName
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
prettyShow (ReadyComponent -> ComponentId
rc_cid ReadyComponent
rc) forall a. [a] -> [a] -> [a]
++
                        [Char]
" depends on non-library " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (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
_ -> 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 -> 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
_ -> []) forall a. [a] -> [a] -> [a]
++
      forall a. Ord a => [a] -> [a]
ordNub (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends ReadyComponent
rc)) forall a. [a] -> [a] -> [a]
++
      forall a b. (a -> b) -> [a] -> [b]
map 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
<+> forall a. Pretty a => a -> Doc
pretty (forall a. IsNode a => a -> Key a
nodeKey ReadyComponent
rc)
            {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) Int
4 forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
vcat [ [Char] -> Doc
text [Char]
"depends" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty UnitId
uid
             | UnitId
uid <- 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) = forall a. (InstS -> (a, InstS)) -> InstM a
InstM 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 = forall a. (InstS -> (a, InstS)) -> InstM a
InstM 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 = forall a. (InstS -> (a, InstS)) -> InstM a
InstM 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 = 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 = forall a. (InstS -> (a, InstS)) -> InstM a
InstM forall a b. (a -> b) -> a -> b
$ \InstS
s -> let (a
x, InstS
s') = InstS -> (a, InstS)
m InstS
s
                                  in 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
    = forall a. [Maybe a] -> [a]
catMaybes (forall k a. Map k a -> [a]
Map.elems InstS
ready_map)
  where
    cmap :: Map ComponentId LinkedComponent
cmap = 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 = forall a. (InstS -> (a, InstS)) -> InstM a
InstM forall a b. (a -> b) -> a -> b
$ \InstS
s ->
        case 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') = 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)
                                       (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, 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid Map ComponentId LinkedComponent
cmap = do
            Map ModuleName Module
provides <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
            [ComponentInclude DefUnitId ModuleRenaming]
includes <- 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) forall a b. (a -> b) -> a -> b
$ \ComponentInclude OpenUnitId ModuleRenaming
ci -> do
                DefUnitId
uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
insts (forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci)
                forall (m :: * -> *) a. Monad m => a -> m a
return ComponentInclude OpenUnitId ModuleRenaming
ci { ci_ann_id :: AnnotatedId DefUnitId
ci_ann_id = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const DefUnitId
uid') (forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id ComponentInclude OpenUnitId ModuleRenaming
ci) }
            [AnnotatedId UnitId]
exe_deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map ModuleName Module
-> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
substExeDep Map ModuleName Module
insts) (LinkedComponent -> [AnnotatedId OpenUnitId]
lc_exe_deps LinkedComponent
lc)
            InstS
s <- forall a. (InstS -> (a, InstS)) -> InstM a
InstM forall a b. (a -> b) -> a -> b
$ \InstS
s -> (InstS
s, InstS
s)
            let getDep :: Module -> [(UnitId, MungedPackageId)]
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,
                          forall a. a -> Maybe a -> a
fromMaybe MungedPackageId
err_pid forall a b. (a -> b) -> a -> b
$
                            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
dep_uid Map UnitId MungedPackageId
pid_map forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReadyComponent -> MungedPackageId
rc_munged_id (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (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 = InstantiatedComponent {
                            instc_insts :: [(ModuleName, Module)]
instc_insts = forall k a. Map k a -> [(k, a)]
Map.toList Map ModuleName Module
insts,
                            instc_insts_deps :: [(UnitId, MungedPackageId)]
instc_insts_deps = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Module -> [(UnitId, MungedPackageId)]
getDep (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
                        }
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ReadyComponent {
                    rc_ann_id :: AnnotatedId UnitId
rc_ann_id       = (LinkedComponent -> AnnotatedId ComponentId
lc_ann_id LinkedComponent
lc) { ann_id :: UnitId
ann_id = UnitId
uid },
                    rc_open_uid :: OpenUnitId
rc_open_uid     = DefUnitId -> OpenUnitId
DefiniteUnitId (UnitId -> DefUnitId
unsafeMkDefUnitId UnitId
uid),
                    rc_cid :: ComponentId
rc_cid          = LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc,
                    rc_component :: Component
rc_component    = LinkedComponent -> Component
lc_component LinkedComponent
lc,
                    rc_exe_deps :: [AnnotatedId UnitId]
rc_exe_deps     = [AnnotatedId UnitId]
exe_deps,
                    rc_public :: Bool
rc_public       = LinkedComponent -> Bool
lc_public LinkedComponent
lc,
                    rc_i :: Either IndefiniteComponent InstantiatedComponent
rc_i            = forall a b. b -> Either a b
Right InstantiatedComponent
instc
                   }
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return 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) =
        forall (m :: * -> *) a. Monad m => a -> m a
return DefUnitId
uid
    substUnitId Map ModuleName Module
subst (IndefFullUnitId ComponentId
cid Map ModuleName OpenModule
insts) = do
        Map ModuleName Module
insts' <- Map ModuleName Module
-> Map ModuleName OpenModule -> InstM (Map ModuleName Module)
substSubst Map ModuleName Module
subst Map ModuleName OpenModule
insts
        ComponentId -> Map ModuleName Module -> InstM DefUnitId
instantiateUnitId ComponentId
cid Map ModuleName Module
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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name Map ModuleName Module
subst = forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"substModule: non-closing substitution"
    substModule Map ModuleName Module
subst (OpenModule OpenUnitId
uid ModuleName
mod_name) = do
        DefUnitId
uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
subst OpenUnitId
uid
        forall (m :: * -> *) a. Monad m => a -> m a
return (DefUnitId -> ModuleName -> Module
Module DefUnitId
uid' ModuleName
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
        DefUnitId
exe_uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
insts (forall id. AnnotatedId id -> id
ann_id AnnotatedId OpenUnitId
exe_aid)
        forall (m :: * -> *) a. Monad m => a -> m a
return AnnotatedId OpenUnitId
exe_aid { ann_id :: UnitId
ann_id = DefUnitId -> UnitId
unDefUnitId DefUnitId
exe_uid' }

    indefiniteUnitId :: ComponentId -> InstM UnitId
    indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId ComponentId
cid = do
        let uid :: UnitId
uid = ComponentId -> UnitId
newSimpleUnitId ComponentId
cid
        Maybe ReadyComponent
r <- UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent UnitId
uid ComponentId
cid
        forall a. (InstS -> (a, InstS)) -> InstM a
InstM forall a b. (a -> b) -> a -> b
$ \InstS
s -> (UnitId
uid, 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 <- 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.
            [ComponentInclude OpenUnitId ModuleRenaming]
inst_includes <- 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) forall a b. (a -> b) -> a -> b
$ \ComponentInclude OpenUnitId ModuleRenaming
ci ->
                if forall a. Set a -> Bool
Set.null (OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci))
                    then do DefUnitId
uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId forall k a. Map k a
Map.empty (forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci)
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ComponentInclude OpenUnitId ModuleRenaming
ci { ci_ann_id :: AnnotatedId OpenUnitId
ci_ann_id = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const (DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid')) (forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id ComponentInclude OpenUnitId ModuleRenaming
ci) }
                    else forall (m :: * -> *) a. Monad m => a -> m a
return ComponentInclude OpenUnitId ModuleRenaming
ci
            [AnnotatedId UnitId]
exe_deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map ModuleName Module
-> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
substExeDep forall k a. Map k a
Map.empty) (LinkedComponent -> [AnnotatedId OpenUnitId]
lc_exe_deps LinkedComponent
lc)
            let indefc :: IndefiniteComponent
indefc = IndefiniteComponent {
                        indefc_requires :: [ModuleName]
indefc_requires = forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. [a] -> [a] -> [a]
++ LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes LinkedComponent
lc
                    }
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ReadyComponent {
                    rc_ann_id :: AnnotatedId UnitId
rc_ann_id       = (LinkedComponent -> AnnotatedId ComponentId
lc_ann_id LinkedComponent
lc) { ann_id :: UnitId
ann_id = UnitId
uid },
                    rc_cid :: ComponentId
rc_cid          = LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc,
                    rc_open_uid :: OpenUnitId
rc_open_uid     = LinkedComponent -> OpenUnitId
lc_uid LinkedComponent
lc,
                    rc_component :: Component
rc_component    = LinkedComponent -> Component
lc_component LinkedComponent
lc,
                    -- It's always fully built
                    rc_exe_deps :: [AnnotatedId UnitId]
rc_exe_deps     = [AnnotatedId UnitId]
exe_deps,
                    rc_public :: Bool
rc_public       = LinkedComponent -> Bool
lc_public LinkedComponent
lc,
                    rc_i :: Either IndefiniteComponent InstantiatedComponent
rc_i            = forall a b. a -> Either a b
Left IndefiniteComponent
indefc
                }
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

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

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