{-|
Module      : Idris.Chaser
Description : Module chaser to determine cycles and import modules.
Copyright   :
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.IBC
import Idris.Imports
import Idris.Parser
import Idris.Unlit

import Control.Monad.State
import Control.Monad.Trans
import Data.List
import Data.Time.Clock
import Debug.Trace
import System.Directory
import System.FilePath
import Util.System (readSource, writeSource)

data ModuleTree = MTree { mod_path :: IFileType,
                          mod_needsRecheck :: Bool,
                          mod_time :: UTCTime,
                          mod_deps :: [ModuleTree] }
  deriving Show

latest :: UTCTime -> [ModuleTree] -> UTCTime
latest tm [] = tm
latest tm (m : ms) = latest (max tm (mod_time m)) (ms ++ mod_deps m)

-- | 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)
--                 when (not (ibc p) || rechk) $
                mapM_ (modTree (getSrc p : path)) deps

   ibc (IBC _ _) = True
   ibc _ = False

   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