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)