1 module Language.Core.Dependencies(getDependencies) where
3 import Language.Core.Core
4 import Language.Core.Encoding
5 import Language.Core.ParsecParser
7 import Control.Monad.State
10 import qualified Data.Map as M
12 import System.Directory
13 import System.FilePath
16 type DepM a = StateT (FilePath, -- "main" module file path
17 -- maps module names onto dependencies
18 M.Map (Either AnMname FilePath) [AnMname],
20 M.Map (Either AnMname FilePath) (FilePath, Module)) IO a
22 -- Given a module, return all the modules it
23 -- depends on (directly or indirectly).
24 getDependencies :: [FilePath] -> IO [(FilePath, Module)]
28 liftIO $ putStrLn $ "==== Finding deps for " ++ show f ++ "====="
29 -- Every module depends on itself anyway,
30 -- so we ignore the FilePath deps.
31 ds <- go getDeps lefts (map Left) (map Right ms)
34 let modNames = nub $ concat (snd (unzip (leftsPairs (M.toList t))))
36 res1 <- (liftM catMaybes) $ mapM findModuleP (map Left modNames)
37 return $ res1 `unionByFirst`
38 (snd (unzip (M.toList c))))
39 (last ms, M.empty, M.empty)
40 where unionByFirst = unionBy (\ (f,_) (g,_) -> f == g)
42 go :: (Show a, Show b, Eq b, MonadIO m) =>
43 (a -> m [b]) -> ([a] -> [b]) -> ([b] -> [a]) -> [a] -> m [b]
44 go getMore p fixUp start = do
45 next <- concatMapM getMore start
46 let more = nub $ (p start) ++ next
47 if (length start == length more)
49 else go getMore p fixUp (fixUp more)
51 varRef :: Exp -> [AnMname]
52 varRef (Var v) | Just m' <- getModule v = [m']
53 varRef (Dcon dc) | Just m' <- getModule dc = [m']
56 tyRef :: Ty -> [AnMname]
57 tyRef (Tcon tc) | Just m' <- getModule tc = [m']
61 getDeps :: Either AnMname FilePath -> DepM [AnMname]
67 maybeM <- findModule mn
70 Just m@(Module mname _ _) -> do
71 let ds = (everything union ([] `mkQ` varRef) m)
72 `union` (everything union ([] `mkQ` tyRef) m) in do
73 liftIO $ putStrLn (show mn ++ " : " ++ show ds)
75 -- in case we were given a filepath, register the
77 put (a1, M.insert mn ds (M.insert (Left mname) ds t1), b1)
80 findModule :: Either AnMname FilePath -> DepM (Maybe Module)
82 maybeRes <- findModuleP x
84 Just (_,m) -> return $ Just m
87 findModuleP :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
88 findModuleP (Left mn) | mn == wrapperMainMname || mn == mainMname = do
91 findModuleP (Left mn) | mn == primMname = return Nothing
92 -- Nothing means that this module is valid; it just doesn't have
94 findModuleP m = tryFindModule m
96 tryFindModule :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
99 liftM Just $ case M.lookup k mCache of
101 Nothing -> findModuleNotCached k
103 findModuleNotCached :: Either AnMname FilePath -> DepM (FilePath, Module)
104 findModuleNotCached (Left m@(M (P pkgName, encHier, encLeafName))) = do
105 let hier = map zDecodeString encHier
106 leafName = zDecodeString encLeafName
107 possibleFiles = (map (dirs hier leafName) searchPath)
108 ++ map (dirs (zDecodeString pkgName:hier) leafName) searchPath in do
109 match <- liftIO $ findM doesFileExist possibleFiles
111 Just fp -> findModule' fp
112 Nothing -> error ("findModule: failed to find dependency " ++ show m
113 ++ " tried " ++ show possibleFiles)
114 findModuleNotCached (Right fp) = findModule' fp
116 dirs :: [String] -> String -> FilePath -> FilePath
117 dirs modulePath leafName dir = dir </>
118 (foldr (</>) (addExtension leafName "hcr") modulePath)
120 findModule' :: FilePath -> DepM (FilePath, Module)
122 res <- liftIO $ parseCore fp
124 Left _ -> error ("findModule: error parsing dependency " ++ fp)
125 Right parsedMod@(Module mn _ _) -> do
126 cacheModule mn fp parsedMod
127 return (fp, parsedMod)
129 cacheModule :: AnMname -> FilePath -> Module -> DepM ()
130 cacheModule mn fp m = modify (\ (a, b, cache) ->
131 (a, b, M.insert (Left mn) (fp, m)
132 (M.insert (Right fp) (fp, m)
135 searchPath :: [FilePath]
136 searchPath = overriddenDir:["../../libraries/",
137 -- kludgy: we wouldn't need these if we parsed the
138 -- package.conf file, but for now, we are too lazy
139 "../../libraries/integer-gmp/",
140 "../../libraries/array/"]
142 overriddenDir :: FilePath
143 overriddenDir = "./lib/"
145 findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
146 findM p = liftM listToMaybe . filterM p
148 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
149 concatMapM f = (liftM concat) . (mapM f)
151 lefts :: [Either a b] -> [a]
152 lefts = foldr lefts' []
153 where lefts' (Left a) xs = a:xs
156 leftsPairs :: [(Either a b, c)] -> [(a, c)]
157 leftsPairs = foldr leftsPairs' []
158 where leftsPairs' ((Left x), y) xs = (x, y):xs
159 leftsPairs' _ xs = xs
162 rightsPairs :: [(Either a b, c)] -> [(b, c)]
163 rightsPairs = foldr rightsPairs' []
164 where rightsPairs' ((Right x), y) xs = (x, y):xs
165 rightsPairs' _ xs = xs