1{-# LANGUAGE TypeFamilies #-} 2{-# LANGUAGE PatternGuards #-} 3-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> 4module Distribution.Backpack.ReadyComponent ( 5 ReadyComponent(..), 6 InstantiatedComponent(..), 7 IndefiniteComponent(..), 8 rc_depends, 9 rc_uid, 10 rc_pkgid, 11 dispReadyComponent, 12 toReadyComponents, 13) where 14 15import Prelude () 16import Distribution.Compat.Prelude hiding ((<>)) 17 18import Distribution.Backpack 19import Distribution.Backpack.LinkedComponent 20import Distribution.Backpack.ModuleShape 21 22import Distribution.Types.AnnotatedId 23import Distribution.Types.ModuleRenaming 24import Distribution.Types.Component 25import Distribution.Types.ComponentInclude 26import Distribution.Types.ComponentId 27import Distribution.Types.ComponentName 28import Distribution.Types.PackageId 29import Distribution.Types.PackageName.Magic 30import Distribution.Types.UnitId 31import Distribution.Compat.Graph (IsNode(..)) 32import Distribution.Types.Module 33import Distribution.Types.MungedPackageId 34import Distribution.Types.MungedPackageName 35import Distribution.Types.Library 36import Distribution.Types.LibraryName 37 38import Distribution.ModuleName 39import Distribution.Package 40import Distribution.Simple.Utils 41 42import Control.Monad 43import Text.PrettyPrint 44import qualified Data.Map as Map 45import qualified Data.Set as Set 46 47import Distribution.Version 48import Distribution.Pretty 49 50-- | A 'ReadyComponent' is one that we can actually generate build 51-- products for. We have a ready component for the typecheck-only 52-- products of every indefinite package, as well as a ready component 53-- for every way these packages can be fully instantiated. 54-- 55data ReadyComponent 56 = ReadyComponent { 57 rc_ann_id :: AnnotatedId UnitId, 58 -- | The 'OpenUnitId' for this package. At the moment, this 59 -- is used in only one case, which is to determine if an 60 -- export is of a module from this library (indefinite 61 -- libraries record these exports as 'OpenModule'); 62 -- 'rc_open_uid' can be conveniently used to test for 63 -- equality, whereas 'UnitId' cannot always be used in this 64 -- case. 65 rc_open_uid :: OpenUnitId, 66 -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' 67 -- records a 'ComponentId', it coincides with this one. 68 rc_cid :: ComponentId, 69 -- | Corresponds to 'lc_component'. 70 rc_component :: Component, 71 -- | Corresponds to 'lc_exe_deps'. 72 -- Build-tools don't participate in mix-in linking. 73 -- (but what if they could?) 74 rc_exe_deps :: [AnnotatedId UnitId], 75 -- | Corresponds to 'lc_public'. 76 rc_public :: Bool, 77 -- | Extra metadata depending on whether or not this is an 78 -- indefinite library (typechecked only) or an instantiated 79 -- component (can be compiled). 80 rc_i :: Either IndefiniteComponent InstantiatedComponent 81 } 82 83-- | The final, string 'UnitId' that will uniquely identify 84-- the compilation products of this component. 85rc_uid :: ReadyComponent -> UnitId 86rc_uid = ann_id . rc_ann_id 87 88-- | Corresponds to 'lc_pkgid'. 89rc_pkgid :: ReadyComponent -> PackageId 90rc_pkgid = ann_pid . rc_ann_id 91 92-- | An 'InstantiatedComponent' is a library which is fully instantiated 93-- (or, possibly, has no requirements at all.) 94data InstantiatedComponent 95 = InstantiatedComponent { 96 -- | How this library was instantiated. 97 instc_insts :: [(ModuleName, Module)], 98 -- | Dependencies induced by 'instc_insts'. These are recorded 99 -- here because there isn't a convenient way otherwise to get 100 -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. 101 instc_insts_deps :: [(UnitId, MungedPackageId)], 102 -- | The modules exported/reexported by this library. 103 instc_provides :: Map ModuleName Module, 104 -- | The dependencies which need to be passed to the compiler 105 -- to bring modules into scope. These always refer to installed 106 -- fully instantiated libraries. 107 instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] 108 } 109 110-- | An 'IndefiniteComponent' is a library with requirements 111-- which we will typecheck only. 112data IndefiniteComponent 113 = IndefiniteComponent { 114 -- | The requirements of the library. 115 indefc_requires :: [ModuleName], 116 -- | The modules exported/reexported by this library. 117 indefc_provides :: Map ModuleName OpenModule, 118 -- | The dependencies which need to be passed to the compiler 119 -- to bring modules into scope. These are 'OpenUnitId' because 120 -- these may refer to partially instantiated libraries. 121 indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] 122 } 123 124-- | Compute the dependencies of a 'ReadyComponent' that should 125-- be recorded in the @depends@ field of 'InstalledPackageInfo'. 126rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] 127rc_depends rc = ordNub $ 128 case rc_i rc of 129 Left indefc -> 130 map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) 131 (indefc_includes indefc) 132 Right instc -> 133 map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) 134 (instc_includes instc) 135 ++ instc_insts_deps instc 136 where 137 toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId 138 toMungedPackageId ci = 139 computeCompatPackageId 140 (ci_pkgid ci) 141 (case ci_cname ci of 142 CLibName name -> name 143 _ -> error $ prettyShow (rc_cid rc) ++ 144 " depends on non-library " ++ prettyShow (ci_id ci)) 145 146-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is 147-- a library. 148rc_munged_id :: ReadyComponent -> MungedPackageId 149rc_munged_id rc = 150 computeCompatPackageId 151 (rc_pkgid rc) 152 (case rc_component rc of 153 CLib lib -> libName lib 154 _ -> error "rc_munged_id: not library") 155 156instance Package ReadyComponent where 157 packageId = rc_pkgid 158 159instance HasUnitId ReadyComponent where 160 installedUnitId = rc_uid 161 162instance IsNode ReadyComponent where 163 type Key ReadyComponent = UnitId 164 nodeKey = rc_uid 165 nodeNeighbors rc = 166 (case rc_i rc of 167 Right inst | [] <- instc_insts inst 168 -> [] 169 | otherwise 170 -> [newSimpleUnitId (rc_cid rc)] 171 _ -> []) ++ 172 ordNub (map fst (rc_depends rc)) ++ 173 map ann_id (rc_exe_deps rc) 174 175dispReadyComponent :: ReadyComponent -> Doc 176dispReadyComponent rc = 177 hang (text (case rc_i rc of 178 Left _ -> "indefinite" 179 Right _ -> "definite") 180 <+> pretty (nodeKey rc) 181 {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ 182 vcat [ text "depends" <+> pretty uid 183 | uid <- nodeNeighbors rc ] 184 185-- | The state of 'InstM'; a mapping from 'UnitId's to their 186-- ready component, or @Nothing@ if its an external 187-- component which we don't know how to build. 188type InstS = Map UnitId (Maybe ReadyComponent) 189 190-- | A state monad for doing instantiations (can't use actual 191-- State because that would be an extra dependency.) 192newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } 193 194instance Functor InstM where 195 fmap f (InstM m) = InstM $ \s -> let (x, s') = m s 196 in (f x, s') 197 198instance Applicative InstM where 199 pure a = InstM $ \s -> (a, s) 200 InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s 201 (x', s'') = x s' 202 in (f' x', s'') 203 204instance Monad InstM where 205 return = pure 206 InstM m >>= f = InstM $ \s -> let (x, s') = m s 207 in runInstM (f x) s' 208 209-- | Given a list of 'LinkedComponent's, expand the module graph 210-- so that we have an instantiated graph containing all of the 211-- instantiated components we need to build. 212-- 213-- Instantiation intuitively follows the following algorithm: 214-- 215-- instantiate a definite unit id p[S]: 216-- recursively instantiate each module M in S 217-- recursively instantiate modules exported by this unit 218-- recursively instantiate dependencies substituted by S 219-- 220-- The implementation is a bit more involved to memoize instantiation 221-- if we have done it already. 222-- 223-- We also call 'improveUnitId' during this process, so that fully 224-- instantiated components are given 'HashedUnitId'. 225-- 226toReadyComponents 227 :: Map UnitId MungedPackageId 228 -> Map ModuleName Module -- subst for the public component 229 -> [LinkedComponent] 230 -> [ReadyComponent] 231toReadyComponents pid_map subst0 comps 232 = catMaybes (Map.elems ready_map) 233 where 234 cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] 235 236 instantiateUnitId :: ComponentId -> Map ModuleName Module 237 -> InstM DefUnitId 238 instantiateUnitId cid insts = InstM $ \s -> 239 case Map.lookup uid s of 240 Nothing -> 241 -- Knot tied 242 let (r, s') = runInstM (instantiateComponent uid cid insts) 243 (Map.insert uid r s) 244 in (def_uid, Map.insert uid r s') 245 Just _ -> (def_uid, s) 246 where 247 -- The mkDefUnitId here indicates that we assume 248 -- that Cabal handles unit id hash allocation. 249 -- Good thing about hashing here: map is only on string. 250 -- Bad thing: have to repeatedly hash. 251 def_uid = mkDefUnitId cid insts 252 uid = unDefUnitId def_uid 253 254 instantiateComponent 255 :: UnitId -> ComponentId -> Map ModuleName Module 256 -> InstM (Maybe ReadyComponent) 257 instantiateComponent uid cid insts 258 | Just lc <- Map.lookup cid cmap = do 259 provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) 260 -- NB: lc_sig_includes is omitted here, because we don't 261 -- need them to build 262 includes <- forM (lc_includes lc) $ \ci -> do 263 uid' <- substUnitId insts (ci_id ci) 264 return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } 265 exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) 266 s <- InstM $ \s -> (s, s) 267 let getDep (Module dep_def_uid _) 268 | let dep_uid = unDefUnitId dep_def_uid 269 -- Lose DefUnitId invariant for rc_depends 270 = [(dep_uid, 271 fromMaybe err_pid $ 272 Map.lookup dep_uid pid_map <|> 273 fmap rc_munged_id (join (Map.lookup dep_uid s)))] 274 where 275 err_pid = MungedPackageId 276 (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) 277 (mkVersion [0]) 278 instc = InstantiatedComponent { 279 instc_insts = Map.toList insts, 280 instc_insts_deps = concatMap getDep (Map.elems insts), 281 instc_provides = provides, 282 instc_includes = includes 283 -- NB: there is no dependency on the 284 -- indefinite version of this instantiated package here, 285 -- as (1) it doesn't go in depends in the 286 -- IPI: it's not a run time dep, and (2) 287 -- we don't have to tell GHC about it, it 288 -- will match up the ComponentId 289 -- automatically 290 } 291 return $ Just ReadyComponent { 292 rc_ann_id = (lc_ann_id lc) { ann_id = uid }, 293 rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), 294 rc_cid = lc_cid lc, 295 rc_component = lc_component lc, 296 rc_exe_deps = exe_deps, 297 rc_public = lc_public lc, 298 rc_i = Right instc 299 } 300 | otherwise = return Nothing 301 302 substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId 303 substUnitId _ (DefiniteUnitId uid) = 304 return uid 305 substUnitId subst (IndefFullUnitId cid insts) = do 306 insts' <- substSubst subst insts 307 instantiateUnitId cid insts' 308 309 -- NB: NOT composition 310 substSubst :: Map ModuleName Module 311 -> Map ModuleName OpenModule 312 -> InstM (Map ModuleName Module) 313 substSubst subst insts = traverse (substModule subst) insts 314 315 substModule :: Map ModuleName Module -> OpenModule -> InstM Module 316 substModule subst (OpenModuleVar mod_name) 317 | Just m <- Map.lookup mod_name subst = return m 318 | otherwise = error "substModule: non-closing substitution" 319 substModule subst (OpenModule uid mod_name) = do 320 uid' <- substUnitId subst uid 321 return (Module uid' mod_name) 322 323 substExeDep :: Map ModuleName Module 324 -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) 325 substExeDep insts exe_aid = do 326 exe_uid' <- substUnitId insts (ann_id exe_aid) 327 return exe_aid { ann_id = unDefUnitId exe_uid' } 328 329 indefiniteUnitId :: ComponentId -> InstM UnitId 330 indefiniteUnitId cid = do 331 let uid = newSimpleUnitId cid 332 r <- indefiniteComponent uid cid 333 InstM $ \s -> (uid, Map.insert uid r s) 334 335 indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) 336 indefiniteComponent uid cid 337 | Just lc <- Map.lookup cid cmap = do 338 -- We're going to process includes, in case some of them 339 -- are fully definite even without any substitution. We 340 -- want to build those too; see #5634. 341 inst_includes <- forM (lc_includes lc) $ \ci -> 342 if Set.null (openUnitIdFreeHoles (ci_id ci)) 343 then do uid' <- substUnitId Map.empty (ci_id ci) 344 return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } 345 else return ci 346 exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) 347 let indefc = IndefiniteComponent { 348 indefc_requires = map fst (lc_insts lc), 349 indefc_provides = modShapeProvides (lc_shape lc), 350 indefc_includes = inst_includes ++ lc_sig_includes lc 351 } 352 return $ Just ReadyComponent { 353 rc_ann_id = (lc_ann_id lc) { ann_id = uid }, 354 rc_cid = lc_cid lc, 355 rc_open_uid = lc_uid lc, 356 rc_component = lc_component lc, 357 -- It's always fully built 358 rc_exe_deps = exe_deps, 359 rc_public = lc_public lc, 360 rc_i = Left indefc 361 } 362 | otherwise = return Nothing 363 364 ready_map = snd $ runInstM work Map.empty 365 366 work 367 -- Top-level instantiation per subst0 368 | not (Map.null subst0) 369 , [lc] <- filter lc_public (Map.elems cmap) 370 = do _ <- instantiateUnitId (lc_cid lc) subst0 371 return () 372 | otherwise 373 = forM_ (Map.elems cmap) $ \lc -> 374 if null (lc_insts lc) 375 then instantiateUnitId (lc_cid lc) Map.empty >> return () 376 else indefiniteUnitId (lc_cid lc) >> return () 377