{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternGuards #-}
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
data ReadyComponent
= ReadyComponent {
ReadyComponent -> AnnotatedId UnitId
rc_ann_id :: AnnotatedId UnitId,
ReadyComponent -> OpenUnitId
rc_open_uid :: OpenUnitId,
ReadyComponent -> ComponentId
rc_cid :: ComponentId,
ReadyComponent -> Component
rc_component :: Component,
ReadyComponent -> [AnnotatedId UnitId]
rc_exe_deps :: [AnnotatedId UnitId],
ReadyComponent -> Bool
rc_public :: Bool,
ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i :: Either IndefiniteComponent InstantiatedComponent
}
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
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
data InstantiatedComponent
= InstantiatedComponent {
InstantiatedComponent -> [(ModuleName, Module)]
instc_insts :: [(ModuleName, Module)],
InstantiatedComponent -> [(UnitId, MungedPackageId)]
instc_insts_deps :: [(UnitId, MungedPackageId)],
InstantiatedComponent -> Map ModuleName Module
instc_provides :: Map ModuleName Module,
InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
}
data IndefiniteComponent
= IndefiniteComponent {
IndefiniteComponent -> [ModuleName]
indefc_requires :: [ModuleName],
IndefiniteComponent -> Map ModuleName OpenModule
indefc_provides :: Map ModuleName OpenModule,
IndefiniteComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
}
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))
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)
) 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 ]
type InstS = Map UnitId (Maybe ReadyComponent)
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'
toReadyComponents
:: Map UnitId MungedPackageId
-> Map ModuleName Module
-> [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 ->
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
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
Map ModuleName Module
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))
[ComponentInclude DefUnitId ModuleRenaming]
includes <- [ComponentInclude OpenUnitId ModuleRenaming]
-> (ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude DefUnitId ModuleRenaming))
-> InstM [ComponentInclude DefUnitId 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 DefUnitId ModuleRenaming))
-> InstM [ComponentInclude DefUnitId ModuleRenaming])
-> (ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude DefUnitId ModuleRenaming))
-> InstM [ComponentInclude DefUnitId ModuleRenaming]
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 (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci)
ComponentInclude DefUnitId ModuleRenaming
-> InstM (ComponentInclude DefUnitId ModuleRenaming)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentInclude OpenUnitId ModuleRenaming
ci { ci_ann_id :: AnnotatedId DefUnitId
ci_ann_id = (OpenUnitId -> DefUnitId)
-> AnnotatedId OpenUnitId -> AnnotatedId DefUnitId
forall a b. (a -> b) -> AnnotatedId a -> AnnotatedId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DefUnitId -> OpenUnitId -> DefUnitId
forall a b. a -> b -> a
const DefUnitId
uid') (ComponentInclude OpenUnitId ModuleRenaming
-> AnnotatedId OpenUnitId
forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id ComponentInclude OpenUnitId ModuleRenaming
ci) }
[AnnotatedId UnitId]
exe_deps <- (AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId))
-> [AnnotatedId OpenUnitId] -> InstM [AnnotatedId UnitId]
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) -> [a] -> f [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 <- (InstS -> (InstS, InstS)) -> InstM InstS
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (InstS, InstS)) -> InstM InstS)
-> (InstS -> (InstS, InstS)) -> InstM InstS
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
= [(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 = 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
}
Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReadyComponent -> InstM (Maybe ReadyComponent))
-> Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a b. (a -> b) -> a -> b
$ ReadyComponent -> Maybe ReadyComponent
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 = InstantiatedComponent
-> Either IndefiniteComponent InstantiatedComponent
forall a b. b -> Either a b
Right InstantiatedComponent
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
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'
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
DefUnitId
uid' <- Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId Map ModuleName Module
subst OpenUnitId
uid
Module -> InstM Module
forall a. a -> InstM a
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 (AnnotatedId OpenUnitId -> OpenUnitId
forall id. AnnotatedId id -> id
ann_id AnnotatedId OpenUnitId
exe_aid)
AnnotatedId UnitId -> InstM (AnnotatedId UnitId)
forall a. a -> InstM a
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
(InstS -> (UnitId, InstS)) -> InstM UnitId
forall a. (InstS -> (a, InstS)) -> InstM a
InstM ((InstS -> (UnitId, InstS)) -> InstM UnitId)
-> (InstS -> (UnitId, InstS)) -> InstM UnitId
forall a b. (a -> b) -> a -> b
$ \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
[ComponentInclude OpenUnitId ModuleRenaming]
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 DefUnitId
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)
ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude OpenUnitId ModuleRenaming)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude OpenUnitId ModuleRenaming))
-> ComponentInclude OpenUnitId ModuleRenaming
-> InstM (ComponentInclude OpenUnitId ModuleRenaming)
forall a b. (a -> b) -> a -> b
$ ComponentInclude OpenUnitId ModuleRenaming
ci { ci_ann_id :: AnnotatedId OpenUnitId
ci_ann_id = (OpenUnitId -> OpenUnitId)
-> AnnotatedId OpenUnitId -> AnnotatedId OpenUnitId
forall a b. (a -> b) -> AnnotatedId a -> AnnotatedId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OpenUnitId -> OpenUnitId -> OpenUnitId
forall a b. a -> b -> a
const (DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid')) (ComponentInclude OpenUnitId ModuleRenaming
-> AnnotatedId OpenUnitId
forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id ComponentInclude OpenUnitId ModuleRenaming
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
[AnnotatedId UnitId]
exe_deps <- (AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId))
-> [AnnotatedId OpenUnitId] -> InstM [AnnotatedId UnitId]
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) -> [a] -> f [b]
traverse (Map ModuleName Module
-> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
substExeDep Map ModuleName Module
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 = ((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
}
Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReadyComponent -> InstM (Maybe ReadyComponent))
-> Maybe ReadyComponent -> InstM (Maybe ReadyComponent)
forall a b. (a -> b) -> a -> b
$ ReadyComponent -> Maybe ReadyComponent
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,
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 = IndefiniteComponent
-> Either IndefiniteComponent InstantiatedComponent
forall a b. a -> Either a b
Left IndefiniteComponent
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
| 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 DefUnitId
_ <- ComponentId -> Map ModuleName Module -> InstM DefUnitId
instantiateUnitId (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) Map ModuleName Module
subst0
() -> InstM ()
forall a. a -> InstM a
forall (m :: * -> *) a. Monad m => a -> m a
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 ()