3 This module encapsulates some magic regarding overridden modules.
5 In the interpreter, we use "overridden" versions of certain
6 standard GHC library modules in order to avoid implementing
7 more primitives than we need to implement to run simple programs.
8 So, after typechecking but before interpretation, references to overridden
9 modules are resolved to references to modules in our simplified
10 version of the standard library.
14 module Language.Core.Overrides (override) where
16 import Language.Core.Core
17 import Language.Core.Encoding
18 import Language.Core.ParsecParser
19 import Language.Core.Prims
22 import System.FilePath
24 override :: [Module] -> IO [Module]
25 override = mapM overrideOne
26 where overrideOne :: Module -> IO Module
27 overrideOne (Module mn _ _) | mn `elem` wiredInModules =
28 findWiredInModule mn >>= (return . snd)
29 overrideOne m = return m
31 -- This function encapsulates all the business with overriden modules.
32 -- The story is that if an "overridden" module exists for the given
33 -- module, then we parse it in and rewrite all occurrences of the "base-extcore"
34 -- package name inside it to "base". We have to do this b/c when compiling
35 -- the overridden modules, we gave the package name "base-extcore", because
36 -- GHC gets unhappy if we try to make it part of the "base" package.
37 -- Was that clear? (No.)
38 findWiredInModule :: AnMname -> IO (FilePath, Module)
39 findWiredInModule m@(M (pn, encHier, encLeafName)) =
40 findModuleIO (Just munged) (wiredInFileName m)
41 where hier = map zDecodeString encHier
42 leafName = zDecodeString encLeafName
44 M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
48 wiredInModules :: [AnMname]
50 map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
52 wiredInFileName :: AnMname -> FilePath
53 wiredInFileName (M (_,_,leafName)) =
54 "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"
57 mungePackageName :: Module -> Module
58 -- for now: just substitute "base-extcore" for "base"
59 -- and "GHC" for "GHC_ExtCore" in every module name
60 mungePackageName m@(Module mn _ _) = everywhere (mkT mungeMname)
61 (everywhere (mkT mungePname)
62 (everywhere (mkT mungeVarName) m))
63 where mungePname (P s) | s == zEncodeString overriddenPname =
66 -- rewrite uses of fake primops
67 mungeVarName (Var (Just mn', v))
68 | mn' == mn && v `elem` (fst (unzip newPrimVars)) =
69 Var (Just primMname, v)
72 mungeMname :: AnMname -> AnMname
73 mungeMname (M (pname, (hd:rest), leaf))
74 | zDecodeString hd == "GHC_ExtCore" =
75 (M (pname, ("GHC":rest), leaf))
78 overriddenPname :: String
79 overriddenPname = "base-extcore"
82 findModuleIO :: Mname -> FilePath -> IO (FilePath, Module)
83 findModuleIO trueName fp = do
86 Left _ -> error ("findModule: error parsing dependency " ++ fp)
88 let resultMod@(Module _ _ _) =
90 Just _ -> mungePackageName parsedMod
92 return (fp, resultMod)