2 This module combines multiple External Core modules into
3 a single module, including both datatype and value definitions.
5 module Language.Core.Merge(merge) where
7 import Language.Core.Core
8 import Language.Core.CoreUtils
9 import Language.Core.Utils
16 merge turns a group of (possibly mutually recursive) modules
17 into a single module, which should be called main:Main.
19 This doesn't handle dependency-finding; you have to hand it all
20 the modules that your main module depends on (transitively).
21 Language.Core.Dependencies does automatic dependency-finding,
22 but that code is a bit moldy.
24 merge takes an extra argument that is a variable substitution.
25 This is because you may want to treat some defined names specially
26 rather than dumping their definitions into the Main module. For
27 example, if my back-end tool defines a new primop that has
28 the type IO (), it's easiest for me if I can consider IO and () as
29 primitive type constructors, though they are not. Thus, I pass in
30 a substitution that says to replace GHC.IOBase.IO with GHC.Prim.IO,
31 and GHC.Base.() with GHC.Prim.(). Of course, I am responsible for
32 providing a type environment defining those names if I want to be
33 able to type the resulting program.
35 You can pass in the empty list if you don't understand what the
36 purpose of the substitution is.
39 merge :: [(Qual Var, Qual Var)] -> [Module] -> Module
41 zapNames subst topNames (Module mainMname newTdefs [Rec topBinds])
42 where -- note: dead code elimination will later remove any names
43 -- that were in the domain of the substitution
44 newTdefs = finishTdefs deadIds $ concat allTdefs
45 (allTdefs, allVdefgs) = unzip $ map (\ (Module _ tds vdefgs)
47 (deadIds,_) = unzip subst
48 topNames = uniqueNamesIn topBinds (concat allTdefs)
49 topBinds = finishVdefs deadIds $ flattenBinds (concat allVdefgs)
52 This function finds all of the names in the given group of vdefs and
53 tdefs that are only defined by one module. This is because if function
54 quux is only defined in module foo:Bar.Blat, we want to call it
55 main:Main.quux in the final module, and not main:Main.foo_Bar_Blat_quux,
56 for file size and readability's sake.
58 Possible improvements:
59 * take into account that tcons/dcons are separate namespaces
60 * restructure the whole thing to shorten names *after* dead code elim.
61 (Both of those would allow for more names to be shortened, but aren't
64 uniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var]
65 uniqueNamesIn topBinds allTdefs = res
66 where allNames = vdefNamesQ topBinds ++ tdefNames allTdefs
67 dups = dupsUnqual allNames
68 res = allNames \\ dups
70 -- This takes each top-level name of the form Foo.Bar.blah and
71 -- renames it to FoozuBarzublah (note we *don't* make it exported!
72 -- This is so we know which names were in the original program and
73 -- which were dumped in from other modules, and thus can eliminate
75 zapNames :: Data a => [(Qual Var, Qual Var)] -> [Qual Var] -> a -> a
76 zapNames subst qvs = everywhereBut (mkQ False (\ (_::String) -> True))
77 (mkT (fixupName subst qvs))
79 -- also need version for type and data constructors
80 -- don't forget to *not* zap if something has the primitive module name
81 -- We hope and pray there are no top-level unqualified names that are used in
82 -- more than one module. (Can we assume this?) (I think so, b/c -fext-core
83 -- attaches uniques to things. But could still perhaps go wrong if we fed
84 -- in .hcr files that were generated in diff. compilation sessions...)
85 -- (This wouldn't be too hard to fix, but should state the assumption,
86 -- and how to remove it.)
88 fixupName :: [(Qual Var, Qual Var)] -> [Qual Var] -> Qual Var -> Qual Var
89 -- For a variable in the domain of the substitution, just
90 -- apply the substitution.
91 fixupName subst _ oldVar | Just newVar <- lookup oldVar subst = newVar
92 -- We don't alter unqualified names, since we just need to make sure
93 -- everything can go in the Main module.
94 fixupName _ _ vr@(Nothing,_) = vr
95 -- Nor do we alter anything defined in the Main module
96 -- or in the primitive or Bool modules
97 -- (because we basically treat the Bool type as primitive.)
98 fixupName _ _ vr@(Just mn, _) | mn == mainMname || mn == wrapperMainMname ||
99 mn == primMname || mn == boolMname = vr
100 -- For a variable that is defined by only one module in scope, we
101 -- give it a name that is just its unqualified name, without the original
102 -- module and package names.
103 fixupName _ uniqueNames (_, v) | okay =
105 where okay = any (\ (_,v1) -> v == v1) uniqueNames
106 -- This is the case for a name that is defined in more than one
107 -- module. In this case, we have to give it a unique name to disambiguate
108 -- it from other definitions of the same name. We combine the package and
109 -- module name to give a unique prefix.
110 fixupName _ _ (Just (M (P pname, hierNames, leafName)), varName) =
111 (mkMname varName, -- see comment for zapNames
112 (if isUpperStr varName then capitalize else id) $
113 intercalate "zu" (pname:(hierNames ++ [leafName, varName])))
114 where capitalize (ch:rest) = (toUpper ch):rest
117 mkMname :: Var -> Mname
119 -- necessary b/c tycons and datacons have to be qualified,
120 -- but we want to write fixupName as a generic transformation on vars.
121 mkMname v = if isUpperStr v then Just mainMname else Nothing
123 isUpperStr :: String -> Bool
124 isUpperStr (c:_) = isUpper c
125 isUpperStr [] = False
127 dupsUnqual :: [Qual Var] -> [Qual Var]
128 dupsUnqual = dupsBy (\ (_,v1) (_,v2) -> v1 == v2)
130 -- We remove any declarations for tcons/dcons that are in
131 -- the domain of the substitution. Why? Because we assume that
132 -- the substitution maps anything in its domain onto something
133 -- with a different module name from the main one. If you want
134 -- to substitute Main-module-defined things for Main-module-defined
135 -- things, you can do that before merging modules.
136 finishTdefs :: [Qual Var] -> [Tdef] -> [Tdef]
137 finishTdefs namesToDrop = filter isOkay
138 where isOkay (Newtype qtc qtc1 _ _) =
139 qtc `notElem` namesToDrop
140 && qtc1 `notElem` namesToDrop
141 isOkay (Data qtc _ cdefs) =
142 qtc `notElem` namesToDrop
144 cdefsOkay = all cdefOkay
145 cdefOkay (Constr qdc _ _) = qdc `notElem` namesToDrop
146 finishVdefs :: [Qual Var] -> [Vdef] -> [Vdef]
147 finishVdefs namesToDrop = filter (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop)