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