git.iko.soy/Idris-dev
on bba09bd help sign in
Idris-dev/src/Idris/Chaser.hs
135 lines 5.2 kB history raw
1module Idris.Chaser(buildTree, getModuleFiles, ModuleTree(..)) where
3import Idris.Parser
4import Idris.AbsSyntax
5import Idris.Imports
6import Idris.Unlit
7import Idris.Error
8import Idris.IBC
10import System.FilePath
11import System.Directory
12import Data.Time.Clock
13import Control.Monad.Trans
14import Control.Monad.State
15import Data.List
17import Debug.Trace
19data ModuleTree = MTree { mod_path :: IFileType,
20 mod_needsRecheck :: Bool,
21 mod_time :: UTCTime,
22 mod_deps :: [ModuleTree] }
23 deriving Show
25latest :: UTCTime -> [ModuleTree] -> UTCTime
26latest tm [] = tm
27latest tm (m : ms) = latest (max tm (mod_time m)) (ms ++ mod_deps m)
29-- Given a module tree, return the list of files to be loaded. If any
30-- module has a descendent which needs reloading, return its source, otherwise
31-- return the IBC
33getModuleFiles :: [ModuleTree] -> [IFileType]
34getModuleFiles ts = nub $ execState (modList ts) [] where
35 modList :: [ModuleTree] -> State [IFileType] ()
36 modList [] = return ()
37 modList (m : ms) = do modTree [] m; modList ms
39 modTree path (MTree p rechk tm deps)
40 = do let file = chkReload rechk p
41 -- Needs rechecking if 'rechk' is true, or if any of the
42 -- modification times in 'deps' are later than tm
43 let depMod = latest tm deps
44 let needsRechk = rechk || depMod > tm
46 st <- get
47 if needsRechk then put $ nub (getSrc file : updateToSrc path st)
48 else put $ nub (file : st)
49-- when (not (ibc p) || rechk) $
50 mapM_ (modTree (getSrc p : path)) deps
52 ibc (IBC _ _) = True
53 ibc _ = False
55 chkReload False p = p
56 chkReload True (IBC fn src) = chkReload True src
57 chkReload True p = p
59 getSrc (IBC fn src) = getSrc src
60 getSrc f = f
62 updateToSrc path [] = []
63 updateToSrc path (x : xs) = if getSrc x `elem` path
64 then getSrc x : updateToSrc path xs
65 else x : updateToSrc path xs
67getIModTime (IBC i _) = getModificationTime i
68getIModTime (IDR i) = getModificationTime i
69getIModTime (LIDR i) = getModificationTime i
71buildTree :: [FilePath] -> -- already guaranteed built
72 FilePath -> Idris [ModuleTree]
73buildTree built fp = idrisCatch (btree [] fp)
74 (\e -> do now <- runIO $ getCurrentTime
75 return [MTree (IDR fp) True now []])
76 where
77 btree done f =
78 do i <- getIState
79 let file = takeWhile (/= ' ') f
80 iLOG $ "CHASING " ++ show file
81 ibcsd <- valIBCSubDir i
82 ids <- allImportDirs
83 fp <- runIO $ findImport ids ibcsd file
84 mt <- runIO $ getIModTime fp
85 if (file `elem` built)
86 then return [MTree fp False mt []]
87 else if file `elem` done
88 then return []
89 else mkChildren fp
91 where mkChildren (LIDR fn) = do ms <- children True fn (f:done)
92 mt <- runIO $ getModificationTime fn
93 return [MTree (LIDR fn) True mt ms]
94 mkChildren (IDR fn) = do ms <- children False fn (f:done)
95 mt <- runIO $ getModificationTime fn
96 return [MTree (IDR fn) True mt ms]
97 mkChildren (IBC fn src)
98 = do srcexist <- runIO $ doesFileExist (getSrcFile src)
99 ms <- if srcexist then
100 do [MTree _ _ _ ms'] <- mkChildren src
101 return ms'
102 else return []
103 mt <- idrisCatch (runIO $ getModificationTime fn)
104 (\c -> runIO $ getIModTime src)
105 ok <- checkIBCUpToDate fn src
106 return [MTree (IBC fn src) ok mt ms]
108 getSrcFile (IBC _ src) = getSrcFile src
109 getSrcFile (LIDR src) = src
110 getSrcFile (IDR src) = src
112 -- FIXME: It's also not up to date if anything it imports has
113 -- been modified since its own ibc has.
115 checkIBCUpToDate fn (LIDR src) = older fn src
116 checkIBCUpToDate fn (IDR src) = older fn src
118 older ibc src = do exist <- runIO $ doesFileExist src
119 if exist then do
120 ibct <- runIO $ getModificationTime ibc
121 srct <- runIO $ getModificationTime src
122 return (srct > ibct)
123 else return False
125 children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree]
126 children lit f done = idrisCatch
127 (do exist <- runIO $ doesFileExist f
128 if exist then do
129 file_in <- runIO $ readFile f
130 file <- if lit then tclift $ unlit f file_in else return file_in
131 (_, modules, _) <- parseImports f file
132 ms <- mapM (btree done) modules
133 return (concat ms)
134 else return []) -- IBC with no source available
135 (\c -> return []) -- error, can't chase modules here