git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/Idris/Chaser.hs
247 lines 10 kB history raw
1{-|
2Module : Idris.Chaser
3Description : Module chaser to determine cycles and import modules.
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE FlexibleContexts #-}
10module Idris.Chaser(
11 buildTree, getImports
12 , getModuleFiles
13 , ModuleTree(..)
14 ) where
16import Idris.AbsSyntax
17import Idris.Core.TT
18import Idris.Error
19import Idris.Imports
20import Idris.Parser
21import Idris.Unlit
23import Control.Monad.State
24import Data.List
25import qualified Data.Map as M
26import qualified Data.Set as S
27import Data.Time.Clock
28import System.Directory
29import Util.System (readSource)
31data ModuleTree = MTree { mod_path :: IFileType,
32 mod_needsRecheck :: Bool,
33 mod_time :: UTCTime,
34 mod_deps :: [ModuleTree] }
35 deriving Show
37latest :: UTCTime -> [IFileType] -> [ModuleTree] -> UTCTime
38latest tm done [] = tm
39latest tm done (m : ms)
40 | mod_path m `elem` done = latest tm done ms
41 | otherwise = latest (max tm (mod_time m)) (mod_path m : done) ms
43modName :: IFileType -> String
44modName (IDR fp) = fp
45modName (LIDR fp) = fp
46modName (IBC fp src) = modName src
48-- | Given a module tree, return the list of files to be loaded. If
49-- any module has a descendent which needs reloading, return its
50-- source, otherwise return the IBC
51getModuleFiles :: [ModuleTree] -> [IFileType]
52getModuleFiles ts
53 = let (files, (rebuild, _)) = runState (modList ts) (S.empty, M.empty) in
54 updateToSrc rebuild (reverse files)
55 where
56 -- Get the order of building modules. As we go we'll find things that
57 -- need rebuilding, which we keep track of in the Set.
58 -- The order of the list matters - things which get built first appear
59 -- in the list first. We'll remove any repetition later.
60 modList :: [ModuleTree] ->
61 State (S.Set IFileType,
62 M.Map IFileType (Bool, [IFileType])) [IFileType]
63 modList [] = return []
64 modList (m : ms) = do (_, fs) <- modTree S.empty m
65 fs' <- modList ms
66 pure (fs ++ fs')
68 modTree path m@(MTree p rechk tm deps)
69 = do let file = chkReload rechk p
70 (rebuild, res) <- get
71 case M.lookup file res of
72 Just ms -> pure ms
73 Nothing -> do
74 toBuildsAll <- mapM (modTree (S.insert (getSrc p) path)) deps
75 let (rechkDep_in, toBuilds) = unzip toBuildsAll
76 let rechkDep = or rechkDep_in
78 (rebuild, res) <- get
80 -- Needs rechecking if 'rechk' is true, or if any of the
81 -- modification times in 'deps' are later than tm, or
82 -- if any dependency needed rechecking
83 let depMod = latest tm [] deps
84 let needsRechk = rechkDep || rechk || depMod > tm
86 -- Remove duplicates, but keep the last...
87 let rnub = reverse . nub . reverse
89 let ret = if needsRechk
90 then (needsRechk, rnub (getSrc file : concat toBuilds))
91 else (needsRechk, rnub (file : concat toBuilds))
93 -- Cache the result
94 put (if needsRechk
95 then S.union path rebuild
96 else rebuild, M.insert file ret res)
97 pure ret
99 chkReload False p = p
100 chkReload True (IBC fn src) = chkReload True src
101 chkReload True p = p
103 getSrc (IBC fn src) = getSrc src
104 getSrc f = f
106 updateToSrc rebuilds [] = []
107 updateToSrc rebuilds (x : xs)
108 = if getSrc x `S.member` rebuilds
109 then getSrc x : updateToSrc rebuilds xs
110 else x : updateToSrc rebuilds xs
112-- | Strip quotes and the backslash escapes that Haskeline adds
113extractFileName :: String -> String
114extractFileName ('"':xs) = takeWhile (/= '"') xs
115extractFileName ('\'':xs) = takeWhile (/= '\'') xs
116extractFileName x = build x []
117 where
118 build [] acc = reverse $ dropWhile (== ' ') acc
119 build ('\\':' ':xs) acc = build xs (' ':acc)
120 build (x:xs) acc = build xs (x:acc)
122getIModTime (IBC i _) = getModificationTime i
123getIModTime (IDR i) = getModificationTime i
124getIModTime (LIDR i) = getModificationTime i
126getImports :: [(FilePath, [ImportInfo])]
127 -> [FilePath]
128 -> Idris [(FilePath, [ImportInfo])]
129getImports acc [] = return acc
130getImports acc (f : fs) = do
131 i <- getIState
132 let file = extractFileName f
133 ibcsd <- valIBCSubDir i
134 idrisCatch (do
135 srcds <- allSourceDirs
136 fp <- findImport srcds ibcsd file
137 let parsef = fname fp
138 case lookup parsef acc of
139 Just _ -> getImports acc fs
140 _ -> do
141 exist <- runIO $ doesFileExist parsef
142 if exist then do
143 src_in <- runIO $ readSource parsef
144 src <- if lit fp then tclift $ unlit parsef src_in
145 else return src_in
146 (_, _, modules, _) <- parseImports parsef src
147 clearParserWarnings
148 getImports ((parsef, modules) : acc)
149 (fs ++ map import_path modules)
150 else getImports ((parsef, []) : acc) fs)
151 (\_ -> getImports acc fs) -- not in current soure tree, ignore
152 where
153 lit (LIDR _) = True
154 lit _ = False
156 fname (IDR fn) = fn
157 fname (LIDR fn) = fn
158 fname (IBC _ src) = fname src
160buildTree :: [FilePath] -- ^ already guaranteed built
161 -> [(FilePath, [ImportInfo])] -- ^ import lists (don't reparse)
162 -> FilePath
163 -> Idris [ModuleTree]
164buildTree built importlists fp = evalStateT (btree [] fp) []
165 where
166 addFile :: FilePath -> [ModuleTree] ->
167 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
168 addFile f m = do fs <- get
169 put ((f, m) : fs)
170 return m
172 btree :: [FilePath] -> FilePath ->
173 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
174 btree stk f =
175 do i <- lift getIState
176 let file = extractFileName f
177 lift $ logLvl 1 $ "CHASING " ++ show file ++ " (" ++ show fp ++ ")"
178 ibcsd <- lift $ valIBCSubDir i
179 ids <- lift allImportDirs
180 fp <- lift $ findImport ids ibcsd file
181 lift $ logLvl 1 $ "Found " ++ show fp
182 mt <- lift $ runIO $ getIModTime fp
183 if (file `elem` built)
184 then return [MTree fp False mt []]
185 else if file `elem` stk then
186 do lift $ tclift $ tfail
187 (Msg $ "Cycle detected in imports: "
188 ++ showSep " -> " (reverse (file : stk)))
189 else do donetree <- get
190 case lookup file donetree of
191 Just t -> return t
192 _ -> do ms <- mkChildren file fp
193 addFile file ms
195 where mkChildren file (LIDR fn) = do ms <- children True fn (file : stk)
196 mt <- lift $ runIO $ getModificationTime fn
197 return [MTree (LIDR fn) True mt ms]
198 mkChildren file (IDR fn) = do ms <- children False fn (file : stk)
199 mt <- lift $ runIO $ getModificationTime fn
200 return [MTree (IDR fn) True mt ms]
201 mkChildren file (IBC fn src)
202 = do srcexist <- lift $ runIO $ doesFileExist (getSrcFile src)
203 ms <- if srcexist then
204 do [MTree _ _ _ ms'] <- mkChildren file src
205 return ms'
206 else return []
207 -- Modification time is the later of the source/ibc modification time
208 smt <- lift $ idrisCatch (runIO $ getIModTime src)
209 (\c -> runIO $ getModificationTime fn)
210 mt <- lift $ idrisCatch (do t <- runIO $ getModificationTime fn
211 return (max smt t))
212 (\c -> return smt)
213 -- FIXME: It's also not up to date if anything it imports has
214 -- been modified since its own ibc has.
215 --
216 -- Issue #1592 on the issue tracker.
217 --
218 -- https://github.com/idris-lang/Idris-dev/issues/1592
219 ibcOutdated <- lift $ fn `younger` (getSrcFile src)
220 -- FIXME (EB): The below 'hasValidIBCVersion' that's
221 -- commented out appears to be breaking reloading in vim
222 -- mode. Until we know why, I've commented it out.
223 ibcValid <- return True -- hasValidIBCVersion fn
224 return [MTree (IBC fn src) (ibcOutdated || not ibcValid) mt ms]
226 getSrcFile (IBC _ src) = getSrcFile src
227 getSrcFile (LIDR src) = src
228 getSrcFile (IDR src) = src
230 younger ibc src = do exist <- runIO $ doesFileExist src
231 if exist then do
232 ibct <- runIO $ getModificationTime ibc
233 srct <- runIO $ getModificationTime src
234 return (srct > ibct)
235 else return False
237 children :: Bool -> FilePath -> [FilePath] ->
238 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
239 children lit f stk = -- idrisCatch
240 do exist <- lift $ runIO $ doesFileExist f
241 if exist then do
242 lift $ logLvl 1 $ "Reading source " ++ show f
243 let modules = maybe [] id (lookup f importlists)
244 ms <- mapM (btree stk . import_path) modules
245 return (concat ms)
246 else return [] -- IBC with no source available
247-- (\c -> return []) -- error, can't chase modules here