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
  20 import Data.Generics
  21 import System.FilePath
  22
  23 override :: [Module] -> IO [Module]
  24 override = mapM overrideOne
  25   where overrideOne :: Module -> IO Module
  26         overrideOne (Module mn _ _) | mn `elem` wiredInModules =
  27            findWiredInModule mn >>= (return . snd)
  28         overrideOne m = return m
  29
  30 -- This function encapsulates all the business with overriden modules.
  31 -- The story is that if an "overridden" module exists for the given
  32 -- module, then we parse it in and rewrite all occurrences of the "base-extcore"
  33 -- package name inside it to "base". We have to do this b/c when compiling
  34 -- the overridden modules, we gave the package name "base-extcore", because
  35 -- GHC gets unhappy if we try to make it part of the "base" package.
  36 -- Was that clear? (No.)
  37 findWiredInModule :: AnMname -> IO (FilePath, Module)
  38 findWiredInModule m@(M (pn, encHier, encLeafName)) =
  39    findModuleIO (Just munged) (wiredInFileName m)
  40      where hier = map zDecodeString encHier
  41            leafName = zDecodeString encLeafName
  42            munged =
  43              M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
  44                  leafName)
  45
  46
  47 wiredInModules :: [AnMname]
  48 wiredInModules =
  49   map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
  50
  51 wiredInFileName :: AnMname -> FilePath
  52 wiredInFileName (M (_,_,leafName)) =
  53   "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"
  54
  55
  56 mungePackageName :: Module -> Module
  57 -- for now: just substitute "base-extcore" for "base"
  58 -- and "GHC" for "GHC_ExtCore" in every module name
  59 mungePackageName m@(Module _ _ _) = everywhere (mkT mungeMname)
  60     (everywhere (mkT mungePname)
  61        (everywhere (mkT mungeVarName) m))
  62   where mungePname (P s) | s == zEncodeString overriddenPname =
  63            (P "base")
  64         mungePname p = p
  65 {- TODO: Commented out because this code should eventually
  66    be completely rewritten. No time to do it now.
  67         -- rewrite uses of fake primops
  68         mungeVarName (Var (Just mn', v))
  69           | mn' == mn && v `elem` (fst (unzip newPrimVars)) =
  70             Var (Just primMname, v)
  71 -}
  72         mungeVarName :: Exp -> Exp
  73         mungeVarName e = e
  74
  75 mungeMname :: AnMname -> AnMname
  76 mungeMname (M (pname, (hd:rest), leaf))
  77   | zDecodeString hd == "GHC_ExtCore" =
  78           (M (pname, ("GHC":rest), leaf))
  79 mungeMname mn = mn
  80
  81 overriddenPname :: String
  82 overriddenPname = "base-extcore"
  83
  84
  85 findModuleIO :: Mname -> FilePath -> IO (FilePath, Module)
  86 findModuleIO trueName fp = do
  87    res <- parseCore fp
  88    case res of
  89      Left _   -> error ("findModule: error parsing dependency " ++ fp)
  90      Right parsedMod -> do
  91               let resultMod@(Module _ _ _) =
  92                       case trueName of
  93                         Just _ -> mungePackageName parsedMod
  94                         Nothing -> parsedMod
  95               return (fp, resultMod)
  96