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