git.iko.soy/Idris-dev
on 449089d help sign in
Idris-dev/src/Idris/Chaser.hs
198 lines 8.2 kB history raw
1module Idris.Chaser(buildTree, getImports, getModuleFiles, ModuleTree(..)) where
3import Idris.Core.TT
4import Idris.Parser
5import Idris.AbsSyntax
6import Idris.Imports
7import Idris.Unlit
8import Idris.Error
9import Idris.IBC
11import System.FilePath
12import System.Directory
13import Data.Time.Clock
14import Control.Monad.Trans
15import Control.Monad.State
16import Data.List
18import Debug.Trace
19import Util.System (readSource, writeSource)
21data ModuleTree = MTree { mod_path :: IFileType,
22 mod_needsRecheck :: Bool,
23 mod_time :: UTCTime,
24 mod_deps :: [ModuleTree] }
25 deriving Show
27latest :: UTCTime -> [ModuleTree] -> UTCTime
28latest tm [] = tm
29latest tm (m : ms) = latest (max tm (mod_time m)) (ms ++ mod_deps m)
31-- Given a module tree, return the list of files to be loaded. If any
32-- module has a descendent which needs reloading, return its source, otherwise
33-- return the IBC
35getModuleFiles :: [ModuleTree] -> [IFileType]
36getModuleFiles ts = nub $ execState (modList ts) [] where
37 modList :: [ModuleTree] -> State [IFileType] ()
38 modList [] = return ()
39 modList (m : ms) = do modTree [] m; modList ms
41 modTree path (MTree p rechk tm deps)
42 = do let file = chkReload rechk p
43 -- Needs rechecking if 'rechk' is true, or if any of the
44 -- modification times in 'deps' are later than tm
45 let depMod = latest tm deps
46 let needsRechk = rechk || depMod > tm
48 st <- get
49 if needsRechk then put $ nub (getSrc file : updateToSrc path st)
50 else put $ nub (file : st)
51-- when (not (ibc p) || rechk) $
52 mapM_ (modTree (getSrc p : path)) deps
54 ibc (IBC _ _) = True
55 ibc _ = False
57 chkReload False p = p
58 chkReload True (IBC fn src) = chkReload True src
59 chkReload True p = p
61 getSrc (IBC fn src) = getSrc src
62 getSrc f = f
64 updateToSrc path [] = []
65 updateToSrc path (x : xs) = if getSrc x `elem` path
66 then getSrc x : updateToSrc path xs
67 else x : updateToSrc path xs
69-- Strip quotes and the backslash escapes that Haskeline adds
70extractFileName :: String -> String
71extractFileName ('"':xs) = takeWhile (/= '"') xs
72extractFileName ('\'':xs) = takeWhile (/= '\'') xs
73extractFileName x = build x []
74 where
75 build [] acc = reverse $ dropWhile (== ' ') acc
76 build ('\\':' ':xs) acc = build xs (' ':acc)
77 build (x:xs) acc = build xs (x:acc)
79getIModTime (IBC i _) = getModificationTime i
80getIModTime (IDR i) = getModificationTime i
81getIModTime (LIDR i) = getModificationTime i
83getImports :: [(FilePath, [ImportInfo])] -> [FilePath] ->
84 Idris [(FilePath, [ImportInfo])]
85getImports acc [] = return acc
86getImports acc (f : fs) = do
87 i <- getIState
88 let file = extractFileName f
89 ibcsd <- valIBCSubDir i
90 ids <- allImportDirs
91 idrisCatch (do
92 fp <- findImport ["."] ibcsd file
93 let parsef = fname fp
94 case lookup parsef acc of
95 Just _ -> getImports acc fs
96 _ -> do
97 exist <- runIO $ doesFileExist parsef
98 if exist then do
99 src_in <- runIO $ readSource parsef
100 src <- if lit fp then tclift $ unlit parsef src_in
101 else return src_in
102 (_, _, modules, _) <- parseImports parsef src
103 clearParserWarnings
104 getImports ((parsef, modules) : acc)
105 (fs ++ map import_path modules)
106 else getImports ((parsef, []) : acc) fs)
107 (\_ -> getImports acc fs) -- not in current soure tree, ignore
108 where
109 lit (LIDR _) = True
110 lit _ = False
112 fname (IDR fn) = fn
113 fname (LIDR fn) = fn
114 fname (IBC _ src) = fname src
116buildTree :: [FilePath] -> -- already guaranteed built
117 [(FilePath, [ImportInfo])] -> -- import lists (don't reparse)
118 FilePath -> Idris [ModuleTree]
119buildTree built importlists fp = evalStateT (btree [] fp) []
120 where
121 addFile :: FilePath -> [ModuleTree] ->
122 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
123 addFile f m = do fs <- get
124 put ((f, m) : fs)
125 return m
127 btree :: [FilePath] -> FilePath ->
128 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
129 btree stk f =
130 do i <- lift getIState
131 let file = extractFileName f
132 lift $ logLvl 1 $ "CHASING " ++ show file ++ " (" ++ show fp ++ ")"
133 ibcsd <- lift $ valIBCSubDir i
134 ids <- lift $ allImportDirs
135 fp <- lift $ findImport ids ibcsd file
136 lift $ logLvl 1 $ "Found " ++ show fp
137 mt <- lift $ runIO $ getIModTime fp
138 if (file `elem` built)
139 then return [MTree fp False mt []]
140 else if file `elem` stk then
141 do lift $ tclift $ tfail
142 (Msg $ "Cycle detected in imports: "
143 ++ showSep " -> " (reverse (file : stk)))
144 else do donetree <- get
145 case lookup file donetree of
146 Just t -> return t
147 _ -> do ms <- mkChildren file fp
148 addFile file ms
150 where mkChildren file (LIDR fn) = do ms <- children True fn (file : stk)
151 mt <- lift $ runIO $ getModificationTime fn
152 return [MTree (LIDR fn) True mt ms]
153 mkChildren file (IDR fn) = do ms <- children False fn (file : stk)
154 mt <- lift $ runIO $ getModificationTime fn
155 return [MTree (IDR fn) True mt ms]
156 mkChildren file (IBC fn src)
157 = do srcexist <- lift $ runIO $ doesFileExist (getSrcFile src)
158 ms <- if srcexist then
159 do [MTree _ _ _ ms'] <- mkChildren file src
160 return ms'
161 else return []
162 mt <- lift $ idrisCatch (runIO $ getModificationTime fn)
163 (\c -> runIO $ getIModTime src)
164 -- FIXME: It's also not up to date if anything it imports has
165 -- been modified since its own ibc has.
166 --
167 -- Issue #1592 on the issue tracker.
168 --
169 -- https://github.com/idris-lang/Idris-dev/issues/1592
170 ibcOutdated <- lift $ fn `younger` (getSrcFile src)
171 -- FIXME (EB): The below 'hasValidIBCVersion' that's
172 -- commented out appears to be breaking reloading in vim
173 -- mode. Until we know why, I've commented it out.
174 ibcValid <- return True -- hasValidIBCVersion fn
175 return [MTree (IBC fn src) (ibcOutdated || not ibcValid) mt ms]
177 getSrcFile (IBC _ src) = getSrcFile src
178 getSrcFile (LIDR src) = src
179 getSrcFile (IDR src) = src
181 younger ibc src = do exist <- runIO $ doesFileExist src
182 if exist then do
183 ibct <- runIO $ getModificationTime ibc
184 srct <- runIO $ getModificationTime src
185 return (srct > ibct)
186 else return False
188 children :: Bool -> FilePath -> [FilePath] ->
189 StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]
190 children lit f stk = -- idrisCatch
191 do exist <- lift $ runIO $ doesFileExist f
192 if exist then do
193 lift $ logLvl 1 $ "Reading source " ++ show f
194 let modules = maybe [] id (lookup f importlists)
195 ms <- mapM (btree stk . import_path) modules
196 return (concat ms)
197 else return [] -- IBC with no source available
198-- (\c -> return []) -- error, can't chase modules here