External Core tools: track new syntax for newtypes

[ghc-hetmet.git] / utils / ext-core / Overrides.hs

diff --git a/utils/ext-core/Overrides.hs b/utils/ext-core/Overrides.hs
new file mode 100644 (file)
index 0000000..1542e09
--- /dev/null
+++ b/utils/ext-core/Overrides.hs
@@ -0,0 +1,93 @@
+{-# OPTIONS -Wall #-}
+{- 
+   This module encapsulates some magic regarding overridden modules.
+
+   In the interpreter, we use "overridden" versions of certain
+   standard GHC library modules in order to avoid implementing
+   more primitives than we need to implement to run simple programs.
+   So, after typechecking but before interpretation, references to overridden
+   modules are resolved to references to modules in our simplified
+   version of the standard library.
+
+   It's kind of ugly.
+-}
+module Overrides (override) where
+
+import Core
+import Encoding
+import ParsecParser
+import Prims
+
+import Data.Generics
+import System.FilePath
+
+override :: [Module] -> IO [Module]
+override = mapM overrideOne
+  where overrideOne :: Module -> IO Module
+        overrideOne (Module mn _ _) | mn `elem` wiredInModules =
+           findWiredInModule mn >>= (return . snd)
+        overrideOne m = return m
+
+-- This function encapsulates all the business with overriden modules.
+-- The story is that if an "overridden" module exists for the given
+-- module, then we parse it in and rewrite all occurrences of the "base-extcore"
+-- package name inside it to "base". We have to do this b/c when compiling
+-- the overridden modules, we gave the package name "base-extcore", because
+-- GHC gets unhappy if we try to make it part of the "base" package.
+-- Was that clear? (No.)
+findWiredInModule :: AnMname -> IO (FilePath, Module)
+findWiredInModule m@(M (pn, encHier, encLeafName)) =
+   findModuleIO (Just munged) (wiredInFileName m)
+     where hier = map zDecodeString encHier
+           leafName = zDecodeString encLeafName
+           munged = 
+             M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
+                 leafName)
+
+
+wiredInModules :: [AnMname]
+wiredInModules =
+  map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
+
+wiredInFileName :: AnMname -> FilePath
+wiredInFileName (M (_,_,leafName)) =
+  "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"
+
+
+mungePackageName :: Module -> Module
+-- for now: just substitute "base-extcore" for "base"
+-- and "GHC" for "GHC_ExtCore" in every module name
+mungePackageName m@(Module mn _ _) = everywhere (mkT mungeMname)
+    (everywhere (mkT mungePname) 
+       (everywhere (mkT mungeVarName) m))
+  where mungePname (P s) | s == zEncodeString overriddenPname =
+           (P "base")
+        mungePname p = p
+        -- rewrite uses of fake primops
+        mungeVarName (Var (Just mn', v))
+          | mn' == mn && v `elem` (fst (unzip newPrimVars)) =
+            Var (Just primMname, v)
+        mungeVarName e = e
+
+mungeMname :: AnMname -> AnMname
+mungeMname (M (pname, (hd:rest), leaf)) 
+  | zDecodeString hd == "GHC_ExtCore" =
+          (M (pname, ("GHC":rest), leaf))
+mungeMname mn = mn
+
+overriddenPname :: String
+overriddenPname = "base-extcore"
+
+
+findModuleIO :: Mname -> FilePath -> IO (FilePath, Module)
+findModuleIO trueName fp = do
+   res <- parseCore fp
+   case res of
+     Left _   -> error ("findModule: error parsing dependency " ++ fp)
+     Right parsedMod -> do
+              let resultMod@(Module _ _ _) = 
+                      case trueName of
+                        Just _ -> mungePackageName parsedMod
+                        Nothing -> parsedMod
+              return (fp, resultMod)
+