{-| 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 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 ++ mod_deps m) 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 = nub $ execState (modList ts) [] where modList :: [ModuleTree] -> State [IFileType] () modList [] = return () modList (m : ms) = do modTree [] m; modList ms modTree path (MTree p rechk tm deps) = do let file = chkReload rechk p -- Needs rechecking if 'rechk' is true, or if any of the -- modification times in 'deps' are later than tm let depMod = latest tm [] deps let needsRechk = rechk || depMod > tm st <- get if needsRechk then put $ nub (getSrc file : updateToSrc path st) else put $ nub (file : st) st <- get mapM_ (modTree (getSrc p : path)) deps 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 path [] = [] updateToSrc path (x : xs) = if getSrc x `elem` path then getSrc x : updateToSrc path xs else x : updateToSrc path 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 [] mt <- lift $ idrisCatch (runIO $ getModificationTime fn) (\c -> runIO $ getIModTime src) -- 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