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
  15 {-
  16    merge turns a group of (possibly mutually recursive) modules
  17    into a single module, which should be called main:Main.
  18
  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.
  23
  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.
  34
  35    You can pass in the empty list if you don't understand what the
  36    purpose of the substitution is.
  37 -}
  38
  39 merge    :: [(Qual Var, Qual Var)] -> [Module] -> Module
  40 merge subst ms =
  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)
  46                                              -> (tds, vdefgs)) ms
  47            (deadIds,_) = unzip subst
  48            topNames    = uniqueNamesIn topBinds (concat allTdefs)
  49            topBinds    = finishVdefs deadIds $ flattenBinds (concat allVdefgs)
  50
  51 {-
  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.
  57
  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
  62    strictly necessary.)
  63 -}
  64 uniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var]
  65 uniqueNamesIn topBinds allTdefs = res
  66   where vars  = vdefNamesQ topBinds
  67         dcons = tdefDcons allTdefs
  68         tcons = tdefTcons allTdefs
  69         uniqueVars  = vars \\ dupsUnqual vars
  70         uniqueDcons = dcons \\ dupsUnqual dcons
  71         uniqueTcons = tcons \\ dupsUnqual tcons
  72         res = uniqueVars ++ uniqueDcons ++ uniqueTcons
  73
  74 nonUniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var]
  75 nonUniqueNamesIn topBinds allTdefs = dupsUnqual allNames
  76   where allNames = vdefNamesQ topBinds ++ tdefNames allTdefs
  77
  78 -- This takes each top-level name of the form Foo.Bar.blah and
  79 -- renames it to FoozuBarzublah (note we *don't* make it exported!
  80 -- This is so we know which names were in the original program and
  81 -- which were dumped in from other modules, and thus can eliminate
  82 -- dead code.)
  83 zapNames :: Data a => [(Qual Var, Qual Var)] -> [Qual Var] -> a -> a
  84 zapNames subst qvs = everywhereBut (mkQ False (\ (_::String) -> True))
  85              (mkT (fixupName subst qvs))
  86
  87 -- also need version for type and data constructors
  88 -- don't forget to *not* zap if something has the primitive module name
  89 -- We hope and pray there are no top-level unqualified names that are used in
  90 -- more than one module. (Can we assume this?) (I think so, b/c -fext-core
  91 -- attaches uniques to things. But could still perhaps go wrong if we fed
  92 -- in .hcr files that were generated in diff. compilation sessions...)
  93 -- (This wouldn't be too hard to fix, but should state the assumption,
  94 -- and how to remove it.)
  95
  96 fixupName :: [(Qual Var, Qual Var)] -> [Qual Var] -> Qual Var -> Qual Var
  97 -- For a variable in the domain of the substitution, just
  98 -- apply the substitution.
  99 fixupName subst _ oldVar | Just newVar <- lookup oldVar subst = newVar
 100 -- We don't alter unqualified names, since we just need to make sure
 101 -- everything can go in the Main module.
 102 fixupName _ _ vr@(Nothing,_) = vr
 103 -- Nor do we alter anything defined in the Main module or the primitive module.
 104 fixupName _ _ vr@(Just mn, _) | mn == mainMname || mn == wrapperMainMname ||
 105                             mn == primMname = vr
 106 -- For a variable that is defined by only one module in scope, we
 107 -- give it a name that is just its unqualified name, without the original
 108 -- module and package names.
 109 fixupName _ uniqueNames (_, v) | okay =
 110    (mkMname v, v)
 111      where okay = any (\ (_,v1) -> v == v1) uniqueNames
 112 -- This is the case for a name that is defined in more than one
 113 -- module. In this case, we have to give it a unique name to disambiguate
 114 -- it from other definitions of the same name. We combine the package and
 115 -- module name to give a unique prefix.
 116 fixupName _ _ (Just (M (P pname, hierNames, leafName)), varName) =
 117    (mkMname varName, -- see comment for zapNames
 118      (if isUpperStr varName then capitalize else id) $
 119        intercalate "zu" (pname:(hierNames ++ [leafName, varName])))
 120   where capitalize (ch:rest) = (toUpper ch):rest
 121         capitalize ""        = ""
 122
 123 mkMname :: Var -> Mname
 124 -- icky hack :-(
 125 -- necessary b/c tycons and datacons have to be qualified,
 126 -- but we want to write fixupName as a generic transformation on vars.
 127 mkMname v = if isUpperStr v then Just mainMname else Nothing
 128
 129 isUpperStr :: String -> Bool
 130 isUpperStr (c:_)     = isUpper c
 131 isUpperStr []        = False
 132
 133 dupsUnqual :: [Qual Var] -> [Qual Var]
 134 dupsUnqual = dupsBy (\ (_,v1) (_,v2) -> v1 == v2)
 135
 136 -- We remove any declarations for tcons/dcons that are in
 137 -- the domain of the substitution. Why? Because we assume that
 138 -- the substitution maps anything in its domain onto something
 139 -- with a different module name from the main one. If you want
 140 -- to substitute Main-module-defined things for Main-module-defined
 141 -- things, you can do that before merging modules.
 142 finishTdefs :: [Qual Var] -> [Tdef] -> [Tdef]
 143 finishTdefs namesToDrop = filter isOkay
 144   where isOkay (Newtype qtc qtc1 _ _) =
 145                qtc `notElem` namesToDrop
 146             && qtc1 `notElem` namesToDrop
 147         isOkay (Data qtc _ cdefs) =
 148                qtc `notElem` namesToDrop
 149             && cdefsOkay cdefs
 150         cdefsOkay = all cdefOkay
 151         cdefOkay (Constr qdc _ _) = qdc `notElem` namesToDrop
 152 finishVdefs :: [Qual Var] -> [Vdef] -> [Vdef]
 153 finishVdefs namesToDrop = filter (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop)