+{-# 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)
+