module Distribution.Backpack.ReadyComponent (
ReadyComponent(..),
InstantiatedComponent(..),
IndefiniteComponent(..),
rc_compat_name,
rc_compat_key,
rc_depends,
dispReadyComponent,
toReadyComponents,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
import Distribution.Backpack
import Distribution.Backpack.Id
import Distribution.Backpack.LinkedComponent
import Distribution.Backpack.ModuleShape
import Distribution.Types.ModuleRenaming
import Distribution.Types.Component
import Distribution.Types.ComponentInclude
import Distribution.Compat.Graph (IsNode(..))
import Distribution.ModuleName
import Distribution.Package
import Distribution.Simple.Utils
import Distribution.Simple.Compiler
import qualified Control.Applicative as A
import qualified Data.Traversable as T
import Control.Monad
import Text.PrettyPrint
import qualified Data.Map as Map
import Distribution.Version
import Distribution.Text
data ReadyComponent
= ReadyComponent {
rc_uid :: UnitId,
rc_open_uid :: OpenUnitId,
rc_cid :: ComponentId,
rc_pkgid :: PackageId,
rc_component :: Component,
rc_internal_build_tools :: [DefUnitId],
rc_public :: Bool,
rc_i :: Either IndefiniteComponent InstantiatedComponent
}
data InstantiatedComponent
= InstantiatedComponent {
instc_insts :: [(ModuleName, Module)],
instc_insts_deps :: [(UnitId, PackageId)],
instc_provides :: Map ModuleName Module,
instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
}
data IndefiniteComponent
= IndefiniteComponent {
indefc_requires :: [ModuleName],
indefc_provides :: Map ModuleName OpenModule,
indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
}
rc_depends :: ReadyComponent -> [(UnitId, PackageId)]
rc_depends rc = ordNub $
case rc_i rc of
Left indefc ->
map (\ci -> (abstractUnitId (ci_id ci), ci_pkgid ci))
(indefc_includes indefc)
Right instc ->
map (\ci -> (unDefUnitId (ci_id ci), ci_pkgid ci))
(instc_includes instc)
++ instc_insts_deps instc
instance Package ReadyComponent where
packageId = rc_pkgid
instance HasUnitId ReadyComponent where
installedUnitId = rc_uid
instance IsNode ReadyComponent where
type Key ReadyComponent = UnitId
nodeKey = rc_uid
nodeNeighbors rc =
(case rc_i rc of
Right inst | [] <- instc_insts inst
-> []
| otherwise
-> [newSimpleUnitId (rc_cid rc)]
_ -> []) ++
ordNub (map fst (rc_depends rc))
rc_compat_name :: ReadyComponent -> PackageName
rc_compat_name ReadyComponent{
rc_pkgid = PackageIdentifier pkg_name _,
rc_component = component
}
= computeCompatPackageName pkg_name (componentName component)
rc_compat_key :: ReadyComponent -> Compiler -> String
rc_compat_key rc@ReadyComponent {
rc_pkgid = PackageIdentifier _ pkg_ver,
rc_uid = uid
} comp
= computeCompatPackageKey comp (rc_compat_name rc) pkg_ver uid
dispReadyComponent :: ReadyComponent -> Doc
dispReadyComponent rc =
hang (text (case rc_i rc of
Left _ -> "indefinite"
Right _ -> "definite")
<+> disp (nodeKey rc)
) 4 $
vcat [ text "depends" <+> disp uid
| uid <- nodeNeighbors rc ]
type InstS = Map UnitId (Maybe ReadyComponent)
newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }
instance Functor InstM where
fmap f (InstM m) = InstM $ \s -> let (x, s') = m s
in (f x, s')
instance A.Applicative InstM where
pure a = InstM $ \s -> (a, s)
InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s
(x', s'') = x s'
in (f' x', s'')
instance Monad InstM where
return = A.pure
InstM m >>= f = InstM $ \s -> let (x, s') = m s
in runInstM (f x) s'
toReadyComponents
:: Map UnitId PackageId
-> Map ModuleName Module
-> [LinkedComponent]
-> [ReadyComponent]
toReadyComponents pid_map subst0 comps
= catMaybes (Map.elems ready_map)
where
cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]
instantiateUnitId :: ComponentId -> Map ModuleName Module
-> InstM DefUnitId
instantiateUnitId cid insts = InstM $ \s ->
case Map.lookup uid s of
Nothing ->
let (r, s') = runInstM (instantiateComponent uid cid insts)
(Map.insert uid r s)
in (def_uid, Map.insert uid r s')
Just _ -> (def_uid, s)
where
def_uid = mkDefUnitId cid insts
uid = unDefUnitId def_uid
instantiateComponent
:: UnitId -> ComponentId -> Map ModuleName Module
-> InstM (Maybe ReadyComponent)
instantiateComponent uid cid insts
| Just lc <- Map.lookup cid cmap = do
provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc))
includes <- forM (lc_includes lc) $ \ci -> do
uid' <- substUnitId insts (ci_id ci)
return ci { ci_id = uid' }
build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc)
s <- InstM $ \s -> (s, s)
let getDep (Module dep_def_uid _)
| let dep_uid = unDefUnitId dep_def_uid
= [(dep_uid,
fromMaybe err_pid $
Map.lookup dep_uid pid_map A.<|>
fmap rc_pkgid (join (Map.lookup dep_uid s)))]
where
err_pid =
PackageIdentifier
(mkPackageName "nonexistent-package-this-is-a-cabal-bug")
(mkVersion [0])
instc = InstantiatedComponent {
instc_insts = Map.toList insts,
instc_insts_deps = concatMap getDep (Map.elems insts),
instc_provides = provides,
instc_includes = includes
}
return $ Just ReadyComponent {
rc_uid = uid,
rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid),
rc_cid = lc_cid lc,
rc_pkgid = lc_pkgid lc,
rc_component = lc_component lc,
rc_internal_build_tools = build_tools,
rc_public = lc_public lc,
rc_i = Right instc
}
| otherwise = return Nothing
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId _ (DefiniteUnitId uid) =
return uid
substUnitId subst (IndefFullUnitId cid insts) = do
insts' <- substSubst subst insts
instantiateUnitId cid insts'
substSubst :: Map ModuleName Module
-> Map ModuleName OpenModule
-> InstM (Map ModuleName Module)
substSubst subst insts = T.mapM (substModule subst) insts
substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule subst (OpenModuleVar mod_name)
| Just m <- Map.lookup mod_name subst = return m
| otherwise = error "substModule: non-closing substitution"
substModule subst (OpenModule uid mod_name) = do
uid' <- substUnitId subst uid
return (Module uid' mod_name)
indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId cid = do
let uid = newSimpleUnitId cid
r <- indefiniteComponent uid cid
InstM $ \s -> (uid, Map.insert uid r s)
indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent uid cid
| Just lc <- Map.lookup cid cmap = do
build_tools <- mapM (substUnitId Map.empty) (lc_internal_build_tools lc)
let indefc = IndefiniteComponent {
indefc_requires = map fst (lc_insts lc),
indefc_provides = modShapeProvides (lc_shape lc),
indefc_includes = lc_includes lc ++ lc_sig_includes lc
}
return $ Just ReadyComponent {
rc_uid = uid,
rc_open_uid = lc_uid lc,
rc_cid = lc_cid lc,
rc_pkgid = lc_pkgid lc,
rc_component = lc_component lc,
rc_internal_build_tools = build_tools,
rc_public = lc_public lc,
rc_i = Left indefc
}
| otherwise = return Nothing
ready_map = snd $ runInstM work Map.empty
work
| not (Map.null subst0)
, [lc] <- filter lc_public (Map.elems cmap)
= do _ <- instantiateUnitId (lc_cid lc) subst0
return ()
| otherwise
= forM_ (Map.elems cmap) $ \lc ->
if null (lc_insts lc)
then instantiateUnitId (lc_cid lc) Map.empty >> return ()
else indefiniteUnitId (lc_cid lc) >> return ()