utils/ext-core/Dependencies.hs

   1 {-# OPTIONS -Wall #-}
   2 {-
   3    Besides computing dependencies between External Core modules,
   4    this module encapsulates some magic regarding overridden modules.
   5
   6    In the interpreter, we use "overridden" versions of certain
   7    standard GHC library modules in order to avoid implementing
   8    more primitives than we need to implement to run simple programs.
   9    So, during the dependency-finding process (which, because the
  10    dependency-finder maintains a module cache to make sure no
  11    module is loaded/parsed more than once), references to overridden
  12    modules are resolved to references to modules in our simplified
  13    version of the standard library.
  14
  15    It's kind of ugly.
  16 -}
  17 module Dependencies(getDependencies) where
  18
  19 import Core
  20 import Encoding
  21 import ParsecParser
  22 import Prims
  23
  24 import Control.Monad.State
  25 import Data.Generics
  26 import Data.List
  27 import qualified Data.Map as M
  28 import Data.Maybe
  29 import System.Directory
  30 import System.FilePath
  31 import System.IO
  32
  33 type DepM a = StateT (FilePath, -- "main" module file path
  34                  -- maps module names onto dependencies
  35                  M.Map (Either AnMname FilePath) [AnMname],
  36                  -- module cache
  37                  M.Map (Either AnMname FilePath) (FilePath, Module)) IO a
  38
  39 -- Given a module, return all the modules it
  40 -- depends on (directly or indirectly).
  41 getDependencies :: [FilePath] -> IO [(FilePath, Module)]
  42 getDependencies ms =
  43   evalStateT (do
  44     (mapM_ (\ f -> do
  45               liftIO $ putStrLn $ "==== Finding deps for " ++ show f ++ "====="
  46               -- Every module depends on itself anyway,
  47               -- so we ignore the FilePath deps.
  48               ds <- go getDeps lefts (map Left) (map Right ms)
  49               return (f, ds)) ms)
  50     (_,t,_) <- get
  51     let modNames = nub $ concat (snd (unzip (leftsPairs (M.toList t))))
  52     (liftM catMaybes) $ mapM findModuleP (map Left modNames))
  53    (last ms, M.empty, M.empty)
  54
  55 go :: (Show a, Show b, Eq b, MonadIO m) =>
  56   (a -> m [b]) -> ([a] -> [b]) -> ([b] -> [a]) -> [a] -> m [b]
  57 go getMore p fixUp start = do
  58   next <- concatMapM getMore start
  59   let more = nub $ (p start) ++ next
  60   if (length start == length more)
  61     then return more
  62     else go getMore p fixUp (fixUp more)
  63
  64 varRef :: Exp -> [AnMname]
  65 varRef (Var v) | Just m' <- getModule v = [m']
  66 varRef (Dcon dc) | Just m' <- getModule dc = [m']
  67 varRef _ = []
  68
  69 tyRef :: Ty -> [AnMname]
  70 tyRef (Tcon tc) | Just m' <- getModule tc = [m']
  71 tyRef  _ = []
  72
  73
  74 getDeps :: Either AnMname FilePath -> DepM [AnMname]
  75 getDeps mn = do
  76           (a,t,b) <- get
  77           case M.lookup mn t of
  78             Just ds -> return ds
  79             Nothing -> do
  80               maybeM <- findModule mn
  81               case maybeM of
  82                 Nothing -> return []
  83                 Just m@(Module mname _ _) -> do
  84                   let ds =   (everything union ([] `mkQ` varRef) m)
  85                             `union` (everything union ([] `mkQ` tyRef) m) in do
  86                   put (a, M.insert mn ds t, b)
  87                   -- in case we were given a filepath, register the
  88                   -- module name too
  89                   put (a, M.insert (Left mname) ds t, b)
  90                   return ds
  91
  92 findModule :: Either AnMname FilePath -> DepM (Maybe Module)
  93 findModule x = do
  94  maybeRes <- findModuleP x
  95  case maybeRes of
  96    Just (_,m) -> return $ Just m
  97    _          -> return Nothing
  98
  99 findModuleP :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
 100 findModuleP (Left mn) | mn `elem` wiredInModules =
 101   findWiredInModule mn >>= (return . Just)
 102 findModuleP (Left mn) | mn == wrapperMainMname || mn == mainMname = do
 103   (f,_,_) <- get
 104   findModuleP (Right f)
 105 findModuleP (Left mn) | mn == primMname = return Nothing
 106   -- Nothing means that this module is valid; it just doesn't have
 107   -- an implementation
 108 findModuleP m = tryFindModule m
 109
 110 tryFindModule :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
 111 tryFindModule k = do
 112   (_,_,mCache) <- get
 113   liftM Just $ case M.lookup k mCache of
 114     Just p -> return p
 115     Nothing -> findModuleNotCached k
 116
 117 -- This function encapsulates all the business with overriden modules.
 118 -- The story is that if an "overridden" module exists for the given
 119 -- module, then we parse it in and rewrite all occurrences of the "base-extcore"
 120 -- package name inside it to "base". We have to do this b/c when compiling
 121 -- the overridden modules, we gave the package name "base-extcore", because
 122 -- GHC gets unhappy if we try to make it part of the "base" package.
 123 -- Was that clear? (No.)
 124 findModuleNotCached :: Either AnMname FilePath -> DepM (FilePath, Module)
 125 findModuleNotCached (Left m@(M (P pkgName, encHier, encLeafName))) = do
 126       let hier = map zDecodeString encHier
 127           leafName = zDecodeString encLeafName
 128           possibleFiles = (map (dirs hier leafName) searchPath)
 129                      ++ map (dirs (zDecodeString pkgName:hier) leafName) searchPath in do
 130       match <- liftIO $ findM doesFileExist possibleFiles
 131       case match of
 132          Just fp -> findModule' Nothing fp
 133          Nothing -> error ("findModule: failed to find dependency " ++ show m
 134                       ++ " tried " ++ show possibleFiles)
 135 findModuleNotCached (Right fp) = findModule' Nothing fp
 136
 137 dirs :: [String] -> String -> FilePath -> FilePath
 138 dirs modulePath leafName dir = dir </>
 139                  (foldr (</>) (addExtension leafName "hcr") modulePath)
 140
 141 findWiredInModule :: AnMname -> DepM (FilePath, Module)
 142 findWiredInModule m@(M (pn, encHier, encLeafName)) =
 143    findModule' (Just munged) (wiredInFileName m)
 144      where hier = map zDecodeString encHier
 145            leafName = zDecodeString encLeafName
 146            munged =
 147              M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
 148                  leafName)
 149
 150 findModule' :: Mname -> FilePath -> DepM (FilePath, Module)
 151 findModule' trueName fp = do
 152           res <- liftIO $ parseCore fp
 153           case res of
 154             Left _   -> error ("findModule: error parsing dependency " ++ fp)
 155             Right parsedMod -> do
 156                 let resultMod@(Module mn _ _) =
 157                       case trueName of
 158                         Just _ -> mungePackageName parsedMod
 159                         Nothing -> parsedMod
 160                 cacheModule mn fp resultMod
 161                 return (fp, resultMod)
 162
 163 cacheModule :: AnMname -> FilePath -> Module -> DepM ()
 164 cacheModule mn fp m = modify (\ (a, b, cache) ->
 165                            (a, b, M.insert (Left mn) (fp, m)
 166                                     (M.insert (Right fp) (fp, m)
 167                                        cache)))
 168
 169 searchPath :: [FilePath]
 170 searchPath = overriddenDir:["../../libraries/",
 171               "../../libraries/integer-gmp/"]
 172
 173 overriddenDir :: FilePath
 174 overriddenDir = "./lib/"
 175
 176 findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
 177 findM p = liftM listToMaybe . filterM p
 178
 179 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
 180 concatMapM f = (liftM concat) . (mapM f)
 181
 182 lefts :: [Either a b] -> [a]
 183 lefts = foldr lefts' []
 184   where lefts' (Left a) xs = a:xs
 185         lefts' _        xs = xs
 186
 187 leftsPairs :: [(Either a b, c)] -> [(a, c)]
 188 leftsPairs = foldr leftsPairs' []
 189   where leftsPairs' ((Left x), y) xs = (x, y):xs
 190         leftsPairs' _             xs = xs
 191
 192 mungePackageName :: Module -> Module
 193 -- for now: just substitute "base-extcore" for "base"
 194 -- and "GHC" for "GHC_ExtCore" in every module name
 195 mungePackageName m@(Module mn _ _) = everywhere (mkT mungeMname)
 196     (everywhere (mkT mungePname)
 197        (everywhere (mkT mungeVarName) m))
 198   where mungePname (P s) | s == zEncodeString overriddenPname =
 199            (P "base")
 200         mungePname p = p
 201         -- rewrite uses of fake primops
 202         mungeVarName (Var (Just mn', v))
 203           | mn' == mn && v `elem` (fst (unzip newPrimVars)) =
 204             Var (Just primMname, v)
 205         mungeVarName e = e
 206
 207 mungeMname :: AnMname -> AnMname
 208 mungeMname (M (pname, (hd:rest), leaf))
 209   | zDecodeString hd == "GHC_ExtCore" =
 210           (M (pname, ("GHC":rest), leaf))
 211 mungeMname mn = mn
 212
 213 overriddenPname :: String
 214 overriddenPname = "base-extcore"
 215
 216 wiredInModules :: [AnMname]
 217 wiredInModules =
 218   map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
 219
 220 wiredInFileName :: AnMname -> FilePath
 221 wiredInFileName (M (_,_,leafName)) =
 222   "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"