----------------------------------------------------------------------
-- |
-- Module      : ReadFiles
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.26 $
--
-- Decide what files to read as function of dependencies and time stamps.
--
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
--
-- to find all files that have to be read, put them in dependency order, and
-- decide which files need recompilation. Name @file.gf@ is returned for them,
-- and @file.gfo@ otherwise.
-----------------------------------------------------------------------------

module GF.Compile.ReadFiles
           ( getAllFiles,ModName,ModEnv,importsOfModule,
             findFile,gfImports,gfoImports,
             parseSource,getOptionsFromFile,getPragmas) where

import Prelude hiding (catch)
import GF.System.Catch
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Infra.Ident
import GF.Data.Operations
import GF.Grammar.Lexer
import GF.Grammar.Parser
import GF.Grammar.Grammar
import GF.Grammar.Binary(decodeModuleHeader)

import System.IO(mkTextEncoding)
import GF.Text.Coding(decodeUnicodeIO)

import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS

import Control.Monad
import Data.Maybe(isJust)
import Data.Char(isSpace)
import qualified Data.Map as Map
import Data.Time(UTCTime)
import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath)
import System.FilePath
import GF.Text.Pretty

type ModName = String
type ModEnv  = Map.Map ModName (UTCTime,[ModName])


-- | Returns a list of all files to be compiled in topological order i.e.
-- the low level (leaf) modules are first.
--getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath]
getAllFiles opts ps env file = do
  -- read module headers from all files recursively
  ds <- reverse `fmap` get [] [] (justModuleName file)
  putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
  return $ paths ds
  where
    -- construct list of paths to read
    paths ds = concatMap mkFile ds
      where
        mkFile (f,st,time,has_src,imps,p) =
          case st of 
            CSComp             -> [p </> gfFile f]
            CSRead | has_src   -> [gf2gfo opts (p </> gfFile f)]
                   | otherwise -> [p </> gfoFile f]
            CSEnv              -> []

    -- | traverses the dependency graph and returns a topologicaly sorted
    -- list of ModuleInfo. An error is raised if there is circular dependency
 {- get :: [ModName]          -- ^ keeps the current path in the dependency graph to avoid cycles
        -> [ModuleInfo]       -- ^ a list of already traversed modules
        -> ModName            -- ^ the current module
        -> IOE [ModuleInfo]   -- ^ the final -}
    get trc ds name
      | name `elem` trc = raise $ "circular modules" +++ unwords trc
      | (not . null) [n | (n,_,_,_,_,_) <- ds, name == n]     --- file already read
                        = return ds
      | otherwise       = do
           (name,st0,t0,has_src,imps,p) <- findModule name
           ds <- foldM (get (name:trc)) ds imps
           let (st,t) | has_src &&
                        flag optRecomp opts == RecompIfNewer &&
                        (not . null) [f | (f,st,t1,_,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True]
                                  = (CSComp,Nothing)
                      | otherwise = (st0,t0)
           return ((name,st,t,has_src,imps,p):ds)

    gfoDir = flag optGFODir opts

    -- searches for module in the search path and if it is found
    -- returns 'ModuleInfo'. It fails if there is no such module
  --findModule :: ModName -> IOE ModuleInfo
    findModule name = do
      (file,gfTime,gfoTime) <- findFile gfoDir ps name

      let mb_envmod = Map.lookup name env
          (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime

      (st,(mname,imps)) <-
          case st of
            CSEnv  -> return (st, (name, maybe [] snd mb_envmod))
            CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file
                         mb_imps <- gfoImports gfo
                         case mb_imps of
                           Just imps -> return (st,imps)
                           Nothing
                             | isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
                             | otherwise  -> do imps <- gfImports opts file
                                                return (CSComp,imps)
            CSComp -> do imps <- gfImports opts file
                         return (st,imps)
      testErr (mname == name)
              ("module name" +++ mname +++ "differs from file name" +++ name)
      return (name,st,t,isJust gfTime,imps,dropFileName file)
--------------------------------------------------------------------------------

findFile gfoDir ps name =
    maybe noSource haveSource =<< getFilePath ps (gfFile name)
  where
    haveSource gfFile =
      do gfTime  <- getModificationTime gfFile
         mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
         return (gfFile, Just gfTime, mb_gfoTime)

    noSource =
        maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name)
      where
        gfoPath = maybe id (:) gfoDir ps

        haveGFO gfoFile =
          do gfoTime <- getModificationTime gfoFile
             return (gfoFile, Nothing, Just gfoTime)

        noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
                               "searched in:" <+> vcat ps))

gfImports opts file = importsOfModule `fmap` parseModHeader opts file

gfoImports gfo = fmap importsOfModule `fmap` liftIO (decodeModuleHeader gfo)

--------------------------------------------------------------------------------

-- From the given Options and the time stamps computes
-- whether the module have to be computed, read from .gfo or
-- the environment version have to be used
selectFormat :: Options -> Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime -> (CompStatus,Maybe UTCTime)
selectFormat opts mtenv mtgf mtgfo =
  case (mtenv,mtgfo,mtgf) of
    (_,_,Just tgf)         | fromSrc  -> (CSComp,Nothing)
    (Just tenv,_,_)        | fromComp -> (CSEnv, Just tenv)
    (_,Just tgfo,_)        | fromComp -> (CSRead,Just tgfo)
    (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
    (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
    (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
    (_,Just tgfo,Nothing) -> (CSRead,Just tgfo)  -- source does not exist
    _ -> (CSComp,Nothing)
  where
    fromComp = flag optRecomp opts == NeverRecomp
    fromSrc  = flag optRecomp opts == AlwaysRecomp


-- internal module dep information


data CompStatus =
   CSComp -- compile: read gf
 | CSRead -- read gfo
 | CSEnv  -- gfo is in env
  deriving Eq

type ModuleInfo = (ModName,CompStatus,Maybe UTCTime,Bool,[ModName],InitPath)

importsOfModule :: SourceModule -> (ModName,[ModName])
importsOfModule (m,mi) = (modName m,depModInfo mi [])
  where
    depModInfo mi =
      depModType (mtype mi)  .
      depExtends (mextend mi) .
      depWith    (mwith mi)  .
      depExDeps  (mexdeps mi).
      depOpens   (mopens mi)

    depModType (MTAbstract)       xs = xs
    depModType (MTResource)       xs = xs
    depModType (MTInterface)      xs = xs
    depModType (MTConcrete m2)    xs = modName m2:xs
    depModType (MTInstance (m2,_))    xs = modName m2:xs

    depExtends es xs = foldr depInclude xs es

    depWith (Just (m,_,is)) xs = modName m : depInsts is xs
    depWith Nothing         xs = xs

    depExDeps eds xs = map modName eds ++ xs

    depOpens os xs = foldr depOpen xs os

    depInsts is xs = foldr depInst xs is

    depInclude (m,_) xs = modName m:xs

    depOpen (OSimple n  ) xs = modName n:xs
    depOpen (OQualif _ n) xs = modName n:xs

    depInst (m,n) xs = modName m:modName n:xs

    modName = showIdent


parseModHeader opts file =
  do --ePutStrLn file
     (_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file)
     case parsed of
       Right mo          -> return mo
       Left (Pn l c,msg) ->
                  raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)

parseSource opts p raw =
  do (coding,utf8) <- toUTF8 opts raw
     return (coding,runP p utf8)

toUTF8 opts0 raw =
  do opts <- getPragmas raw
     let given = flag optEncoding opts -- explicitly given encoding
         coding = getEncoding $ opts0 `addOptions` opts
     utf8 <- if coding=="UTF-8"
             then return raw
             else if coding=="CP1252" -- Latin1
                  then return . UTF8.fromString $ BS.unpack raw -- faster
                  else do --ePutStrLn $ "toUTF8 from "++coding
                          recodeToUTF8 coding raw
     return (given,utf8)

recodeToUTF8 coding raw =
  liftIO $
  do enc <- mkTextEncoding coding
     -- decodeUnicodeIO uses a lot of stack space,
     -- so we need to split the file into smaller pieces
     ls <- mapM (decodeUnicodeIO enc) (BS.lines raw)
     return $ UTF8.fromString (unlines ls)

-- | options can be passed to the compiler by comments in @--#@, in the main file
--getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
getOptionsFromFile file = do
  opts <- either failed getPragmas =<< (liftIO $ try $ BS.readFile file)
  -- The coding flag should not be inherited by other files
  return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing}))
  where
    failed _ = raise $ "File " ++ file ++ " does not exist"


getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options
getPragmas = parseModuleOptions . 
             map (BS.unpack . BS.unwords . BS.words . BS.drop 3) .
             filter (BS.isPrefixOf (BS.pack "--#")) .
--           takeWhile (BS.isPrefixOf (BS.pack "--")) .
--           filter (not . BS.null) .
             map (BS.dropWhile isSpace) .
             BS.lines

getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
getFilePath paths file = get paths
  where
    get []     = return Nothing
    get (p:ps) = do let pfile = p </> file
                    exist <- doesFileExist pfile
                    if not exist
                      then get ps
                      else do pfile <- canonicalizePath pfile
                              return (Just pfile)
