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

   1 module Language.Core.Dependencies(getDependencies) where
   2
   3 import Language.Core.Core
   4 import Language.Core.Encoding
   5 import Language.Core.ParsecParser
   6
   7 import Control.Monad.State
   8 import Data.Generics
   9 import Data.List
  10 import qualified Data.Map as M
  11 import Data.Maybe
  12 import System.Directory
  13 import System.FilePath
  14 import System.IO
  15
  16 type DepM a = StateT (FilePath, -- "main" module file path
  17                  -- maps module names onto dependencies
  18                  M.Map (Either AnMname FilePath) [AnMname],
  19                  -- module cache
  20                  M.Map (Either AnMname FilePath) (FilePath, Module)) IO a
  21
  22 -- Given a module, return all the modules it
  23 -- depends on (directly or indirectly).
  24 getDependencies :: [FilePath] -> IO [(FilePath, Module)]
  25 getDependencies ms =
  26   evalStateT (do
  27     (mapM_ (\ f -> do
  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)
  32               return (f, ds)) ms)
  33     (_,t,c) <- get
  34     let modNames = nub $ concat (snd (unzip (leftsPairs (M.toList t))))
  35
  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)
  41
  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)
  48     then return more
  49     else go getMore p fixUp (fixUp more)
  50
  51 varRef :: Exp -> [AnMname]
  52 varRef (Var v) | Just m' <- getModule v = [m']
  53 varRef (Dcon dc) | Just m' <- getModule dc = [m']
  54 varRef _ = []
  55
  56 tyRef :: Ty -> [AnMname]
  57 tyRef (Tcon tc) | Just m' <- getModule tc = [m']
  58 tyRef  _ = []
  59
  60
  61 getDeps :: Either AnMname FilePath -> DepM [AnMname]
  62 getDeps mn = do
  63           (_,t,_) <- get
  64           case M.lookup mn t of
  65             Just ds -> return ds
  66             Nothing -> do
  67               maybeM <- findModule mn
  68               case maybeM of
  69                 Nothing -> return []
  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)
  74                   (a1,t1,b1) <- get
  75                   -- in case we were given a filepath, register the
  76                   -- module name too
  77                   put (a1, M.insert mn ds (M.insert (Left mname) ds t1), b1)
  78                   return ds
  79
  80 findModule :: Either AnMname FilePath -> DepM (Maybe Module)
  81 findModule x = do
  82  maybeRes <- findModuleP x
  83  case maybeRes of
  84    Just (_,m) -> return $ Just m
  85    _          -> return Nothing
  86
  87 findModuleP :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
  88 findModuleP (Left mn) | mn == wrapperMainMname || mn == mainMname = do
  89   (f,_,_) <- get
  90   findModuleP (Right f)
  91 findModuleP (Left mn) | mn == primMname = return Nothing
  92   -- Nothing means that this module is valid; it just doesn't have
  93   -- an implementation
  94 findModuleP m = tryFindModule m
  95
  96 tryFindModule :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
  97 tryFindModule k = do
  98   (_,_,mCache) <- get
  99   liftM Just $ case M.lookup k mCache of
 100     Just p -> return p
 101     Nothing -> findModuleNotCached k
 102
 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
 110       case match of
 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
 115
 116 dirs :: [String] -> String -> FilePath -> FilePath
 117 dirs modulePath leafName dir = dir </>
 118                  (foldr (</>) (addExtension leafName "hcr") modulePath)
 119
 120 findModule' :: FilePath -> DepM (FilePath, Module)
 121 findModule' fp = do
 122           res <- liftIO $ parseCore fp
 123           case res of
 124             Left _   -> error ("findModule: error parsing dependency " ++ fp)
 125             Right parsedMod@(Module mn _ _) -> do
 126                 cacheModule mn fp parsedMod
 127                 return (fp, parsedMod)
 128
 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)
 133                                     cache)))
 134
 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/"]
 141
 142 overriddenDir :: FilePath
 143 overriddenDir = "./lib/"
 144
 145 findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
 146 findM p = liftM listToMaybe . filterM p
 147
 148 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
 149 concatMapM f = (liftM concat) . (mapM f)
 150
 151 lefts :: [Either a b] -> [a]
 152 lefts = foldr lefts' []
 153   where lefts' (Left a) xs = a:xs
 154         lefts' _        xs = xs
 155
 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
 160
 161 {-
 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
 166 -}