{-| Module : Idris.Chaser Description : Module chaser to determine cycles and import modules. License : BSD3 Maintainer : The Idris Community. -} {-# LANGUAGE FlexibleContexts #-} module Idris.Chaser( buildTree, getImports , getModuleFiles , ModuleTree(..) ) where import Idris.AbsSyntax import Idris.Core.TT import Idris.Error import Idris.Imports import Idris.Parser import Idris.Unlit import Control.Monad.State import Data.List import qualified Data.Map as M import qualified Data.Set as S import Data.Time.Clock import System.Directory import Util.System (readSource) data ModuleTree = MTree { mod_path :: IFileType, mod_needsRecheck :: Bool, mod_time :: UTCTime, mod_deps :: [ModuleTree] } deriving Show latest :: UTCTime -> [IFileType] -> [ModuleTree] -> UTCTime latest tm done [] = tm latest tm done (m : ms) | mod_path m `elem` done = latest tm done ms | otherwise = latest (max tm (mod_time m)) (mod_path m : done) ms modName :: IFileType -> String modName (IDR fp) = fp modName (LIDR fp) = fp modName (IBC fp src) = modName src -- | Given a module tree, return the list of files to be loaded. If -- any module has a descendent which needs reloading, return its -- source, otherwise return the IBC getModuleFiles :: [ModuleTree] -> [IFileType] getModuleFiles ts = let (files, (rebuild, _)) = runState (modList ts) (S.empty, M.empty) in updateToSrc rebuild (reverse files) where -- Get the order of building modules. As we go we'll find things that -- need rebuilding, which we keep track of in the Set. -- The order of the list matters - things which get built first appear -- in the list first. We'll remove any repetition later. modList :: [ModuleTree] -> State (S.Set IFileType, M.Map IFileType (Bool, [IFileType])) [IFileType] modList [] = return [] modList (m : ms) = do (_, fs) <- modTree S.empty m fs' <- modList ms pure (fs ++ fs') modTree path m@(MTree p rechk tm deps) = do let file = chkReload rechk p (rebuild, res) <- get case M.lookup file res of Just ms -> pure ms Nothing -> do toBuildsAll <- mapM (modTree (S.insert (getSrc p) path)) deps let (rechkDep_in, toBuilds) = unzip toBuildsAll let rechkDep = or rechkDep_in (rebuild, res) <- get -- Needs rechecking if 'rechk' is true, or if any of the -- modification times in 'deps' are later than tm, or -- if any dependency needed rechecking let depMod = latest tm [] deps let needsRechk = rechkDep || rechk || depMod > tm -- Remove duplicates, but keep the last... let rnub = reverse . nub . reverse let ret = if needsRechk then (needsRechk, rnub (getSrc file : concat toBuilds)) else (needsRechk, rnub (file : concat toBuilds)) -- Cache the result put (if needsRechk then S.union path rebuild else rebuild, M.insert file ret res) pure ret chkReload False p = p chkReload True (IBC fn src) = chkReload True src chkReload True p = p getSrc (IBC fn src) = getSrc src getSrc f = f updateToSrc rebuilds [] = [] updateToSrc rebuilds (x : xs) = if getSrc x `S.member` rebuilds then getSrc x : updateToSrc rebuilds xs else x : updateToSrc rebuilds xs -- | Strip quotes and the backslash escapes that Haskeline adds extractFileName :: String -> String extractFileName ('"':xs) = takeWhile (/= '"') xs extractFileName ('\'':xs) = takeWhile (/= '\'') xs extractFileName x = build x [] where build [] acc = reverse $ dropWhile (== ' ') acc build ('\\':' ':xs) acc = build xs (' ':acc) build (x:xs) acc = build xs (x:acc) getIModTime (IBC i _) = getModificationTime i getIModTime (IDR i) = getModificationTime i getIModTime (LIDR i) = getModificationTime i getImports :: [(FilePath, [ImportInfo])] -> [FilePath] -> Idris [(FilePath, [ImportInfo])] getImports acc [] = return acc getImports acc (f : fs) = do i <- getIState let file = extractFileName f ibcsd <- valIBCSubDir i idrisCatch (do srcds <- allSourceDirs fp <- findImport srcds ibcsd file let parsef = fname fp case lookup parsef acc of Just _ -> getImports acc fs _ -> do exist <- runIO $ doesFileExist parsef if exist then do src_in <- runIO $ readSource parsef src <- if lit fp then tclift $ unlit parsef src_in else return src_in (_, _, modules, _) <- parseImports parsef src clearParserWarnings getImports ((parsef, modules) : acc) (fs ++ map import_path modules) else getImports ((parsef, []) : acc) fs) (\_ -> getImports acc fs) -- not in current soure tree, ignore where lit (LIDR _) = True lit _ = False fname (IDR fn) = fn fname (LIDR fn) = fn fname (IBC _ src) = fname src buildTree :: [FilePath] -- ^ already guaranteed built -> [(FilePath, [ImportInfo])] -- ^ import lists (don't reparse) -> FilePath -> Idris [ModuleTree] buildTree built importlists fp = evalStateT (btree [] fp) [] where addFile :: FilePath -> [ModuleTree] -> StateT [(FilePath, [ModuleTree])] Idris [ModuleTree] addFile f m = do fs <- get put ((f, m) : fs) return m btree :: [FilePath] -> FilePath -> StateT [(FilePath, [ModuleTree])] Idris [ModuleTree] btree stk f = do i <- lift getIState let file = extractFileName f lift $ logLvl 1 $ "CHASING " ++ show file ++ " (" ++ show fp ++ ")" ibcsd <- lift $ valIBCSubDir i ids <- lift allImportDirs fp <- lift $ findImport ids ibcsd file lift $ logLvl 1 $ "Found " ++ show fp mt <- lift $ runIO $ getIModTime fp if (file `elem` built) then return [MTree fp False mt []] else if file `elem` stk then do lift $ tclift $ tfail (Msg $ "Cycle detected in imports: " ++ showSep " -> " (reverse (file : stk))) else do donetree <- get case lookup file donetree of Just t -> return t _ -> do ms <- mkChildren file fp addFile file ms where mkChildren file (LIDR fn) = do ms <- children True fn (file : stk) mt <- lift $ runIO $ getModificationTime fn return [MTree (LIDR fn) True mt ms] mkChildren file (IDR fn) = do ms <- children False fn (file : stk) mt <- lift $ runIO $ getModificationTime fn return [MTree (IDR fn) True mt ms] mkChildren file (IBC fn src) = do srcexist <- lift $ runIO $ doesFileExist (getSrcFile src) ms <- if srcexist then do [MTree _ _ _ ms'] <- mkChildren file src return ms' else return [] -- Modification time is the later of the source/ibc modification time smt <- lift $ idrisCatch (runIO $ getIModTime src) (\c -> runIO $ getModificationTime fn) mt <- lift $ idrisCatch (do t <- runIO $ getModificationTime fn return (max smt t)) (\c -> return smt) -- FIXME: It's also not up to date if anything it imports has -- been modified since its own ibc has. -- -- Issue #1592 on the issue tracker. -- -- https://github.com/idris-lang/Idris-dev/issues/1592 ibcOutdated <- lift $ fn `younger` (getSrcFile src) -- FIXME (EB): The below 'hasValidIBCVersion' that's -- commented out appears to be breaking reloading in vim -- mode. Until we know why, I've commented it out. ibcValid <- return True -- hasValidIBCVersion fn return [MTree (IBC fn src) (ibcOutdated || not ibcValid) mt ms] getSrcFile (IBC _ src) = getSrcFile src getSrcFile (LIDR src) = src getSrcFile (IDR src) = src younger ibc src = do exist <- runIO $ doesFileExist src if exist then do ibct <- runIO $ getModificationTime ibc srct <- runIO $ getModificationTime src return (srct > ibct) else return False children :: Bool -> FilePath -> [FilePath] -> StateT [(FilePath, [ModuleTree])] Idris [ModuleTree] children lit f stk = -- idrisCatch do exist <- lift $ runIO $ doesFileExist f if exist then do lift $ logLvl 1 $ "Reading source " ++ show f let modules = maybe [] id (lookup f importlists) ms <- mapM (btree stk . import_path) modules return (concat ms) else return [] -- IBC with no source available -- (\c -> return []) -- error, can't chase modules here