{-|
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