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