utils/ext-core/Language/Core/Overrides.hs

   1 {-# OPTIONS -Wall #-}
   2 {-
   3    This module encapsulates some magic regarding overridden modules.
   4
   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.
  11
  12    It's kind of ugly.
  13 -}
  14 module Language.Core.Overrides (override) where
  15
  16 import Language.Core.Core
  17 import Language.Core.Encoding
  18 import Language.Core.ParsecParser
  19 import Language.Core.Prims
  20
  21 import Data.Generics
  22 import System.FilePath
  23
  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
  30
  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
  43            munged =
  44              M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
  45                  leafName)
  46
  47
  48 wiredInModules :: [AnMname]
  49 wiredInModules =
  50   map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
  51
  52 wiredInFileName :: AnMname -> FilePath
  53 wiredInFileName (M (_,_,leafName)) =
  54   "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"
  55
  56
  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 =
  64            (P "base")
  65         mungePname p = p
  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)
  70         mungeVarName e = e
  71
  72 mungeMname :: AnMname -> AnMname
  73 mungeMname (M (pname, (hd:rest), leaf))
  74   | zDecodeString hd == "GHC_ExtCore" =
  75           (M (pname, ("GHC":rest), leaf))
  76 mungeMname mn = mn
  77
  78 overriddenPname :: String
  79 overriddenPname = "base-extcore"
  80
  81
  82 findModuleIO :: Mname -> FilePath -> IO (FilePath, Module)
  83 findModuleIO trueName fp = do
  84    res <- parseCore fp
  85    case res of
  86      Left _   -> error ("findModule: error parsing dependency " ++ fp)
  87      Right parsedMod -> do
  88               let resultMod@(Module _ _ _) =
  89                       case trueName of
  90                         Just _ -> mungePackageName parsedMod
  91                         Nothing -> parsedMod
  92               return (fp, resultMod)
  93