3 Besides computing dependencies between External Core modules,
4 this module encapsulates some magic regarding overridden modules.
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.
17 module Dependencies(getDependencies) where
24 import Control.Monad.State
27 import qualified Data.Map as M
29 import System.Directory
30 import System.FilePath
33 type DepM a = StateT (FilePath, -- "main" module file path
34 -- maps module names onto dependencies
35 M.Map (Either AnMname FilePath) [AnMname],
37 M.Map (Either AnMname FilePath) (FilePath, Module)) IO a
39 -- Given a module, return all the modules it
40 -- depends on (directly or indirectly).
41 getDependencies :: [FilePath] -> IO [(FilePath, Module)]
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)
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)
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)
62 else go getMore p fixUp (fixUp more)
64 varRef :: Exp -> [AnMname]
65 varRef (Var v) | Just m' <- getModule v = [m']
66 varRef (Dcon dc) | Just m' <- getModule dc = [m']
69 tyRef :: Ty -> [AnMname]
70 tyRef (Tcon tc) | Just m' <- getModule tc = [m']
74 getDeps :: Either AnMname FilePath -> DepM [AnMname]
80 maybeM <- findModule mn
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
89 put (a, M.insert (Left mname) ds t, b)
92 findModule :: Either AnMname FilePath -> DepM (Maybe Module)
94 maybeRes <- findModuleP x
96 Just (_,m) -> return $ Just m
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
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
108 findModuleP m = tryFindModule m
110 tryFindModule :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
113 liftM Just $ case M.lookup k mCache of
115 Nothing -> findModuleNotCached k
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
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
137 dirs :: [String] -> String -> FilePath -> FilePath
138 dirs modulePath leafName dir = dir </>
139 (foldr (</>) (addExtension leafName "hcr") modulePath)
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
147 M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
150 findModule' :: Mname -> FilePath -> DepM (FilePath, Module)
151 findModule' trueName fp = do
152 res <- liftIO $ parseCore fp
154 Left _ -> error ("findModule: error parsing dependency " ++ fp)
155 Right parsedMod -> do
156 let resultMod@(Module mn _ _) =
158 Just _ -> mungePackageName parsedMod
160 cacheModule mn fp resultMod
161 return (fp, resultMod)
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)
169 searchPath :: [FilePath]
170 searchPath = overriddenDir:["../../libraries/",
171 "../../libraries/integer-gmp/"]
173 overriddenDir :: FilePath
174 overriddenDir = "./lib/"
176 findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
177 findM p = liftM listToMaybe . filterM p
179 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
180 concatMapM f = (liftM concat) . (mapM f)
182 lefts :: [Either a b] -> [a]
183 lefts = foldr lefts' []
184 where lefts' (Left a) xs = a:xs
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
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 =
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)
207 mungeMname :: AnMname -> AnMname
208 mungeMname (M (pname, (hd:rest), leaf))
209 | zDecodeString hd == "GHC_ExtCore" =
210 (M (pname, ("GHC":rest), leaf))
213 overriddenPname :: String
214 overriddenPname = "base-extcore"
216 wiredInModules :: [AnMname]
218 map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
220 wiredInFileName :: AnMname -> FilePath
221 wiredInFileName (M (_,_,leafName)) =
222 "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"