{-# LANGUAGE CPP #-}
module Depend(chkDeps, parseSrc, chkParse, doCPP, genDepend, genFileDepend) where

import Data.Maybe(isJust)
import Data.List(nub)
import Control.Monad(when)
import System.Process(system)
import System.Exit(ExitCode(..))
import System.Directory(getModificationTime)
import System.Time -- XXX: in old-time package
import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)
import qualified Control.Exception as CE
import qualified Data.Map as DM

import TmpNam(tmpNam, localTmpNam)
import SCC(tsort)
import Flags
import Backend
import Pragma(Pragma(..),PProp(..))
import Position(noPosition)
import Error(internalError, EMsg, ErrMsg(..), ErrorHandle, bsError,
             exitFailWith, bsWarning)
import PFPrint
import FStringCompat
import Lex
import Parse
import FileNameUtil(hasDotSuf, dropSuf, baseName, dirName,
                    bscSrcSuffix, bsvSrcSuffix, binSuffix,
                    mkAName, mkVName, mkVPIHName, mkVPICName)
import FileIOUtil(readFilesPath, readBinFilePath, readFileCatch, writeFileCatch,
                  removeFileCatch)
import Id
import PreIds(idPrelude, idPreludeBSV)
import Parser.Classic(pPackage, errSyntax, classicWarnings)
import Parser.BSV(bsvParseString)
import CSyntax
import GenFuncWrap(makeGenFuncId)
import IOUtil(getEnvDef, progArgs)
import TopUtils
--import Debug.Trace

outlaw_sv_kws_as_classic_ids :: Bool
outlaw_sv_kws_as_classic_ids = "-outlaw-sv-kws-as-classic-ids" `elem` progArgs

type FileName = String
type PkgName = Id
type ModName = Id
type ForeignName = Id

type MClockTime = Maybe ClockTime

data PkgInfo = PkgInfo {
        pkgName :: PkgName,
        fileName :: FileName,
        srcMod :: MClockTime,
        lastMod :: MClockTime,
        imports :: [PkgName],
        includes :: [FileName],
        gens :: [ModName],
        foreigns :: [ForeignName],
        recompile :: Bool,
        isbin :: Bool
        }
    deriving (Show)

getModificationTime' :: FilePath -> IO ClockTime
getModificationTime' file =
  do utcTime <- getModificationTime file
     let s = (floor . utcTimeToPOSIXSeconds) utcTime
     return (TOD s 0)

-- returns a list of Bluespec source files which need recompiling.
-- (This used to also return a list of all generated files which would
-- result from codegen, so that a later stage could link them.  But this
-- feature is no longer supported.)
chkDeps :: ErrorHandle -> Flags -> String -> IO [FileName]
chkDeps errh flags name = do
        let gflags = [ mkId noPosition (mkFString s) | s <- genName flags ]
        pi <- getInfo errh flags gflags name
        (errs,pis) <- transClose errh flags ([],[pi]) (imports pi)
        when (not $ null errs) $ bsError errh errs

        case tsort [ (n, is) | PkgInfo { pkgName = n, imports = is } <- pis ] of
            Left cycle@(firstImport:_) ->
                bsError errh [(getPosition firstImport,
                               ECircularImports (map ppReadable cycle))]
            Right ns -> do
                let -- the pkginfo of all depended modules
                    pis' = [ pi | n <- ns, let Just pi = findInfo n pis ]
                    -- names of files resulting from codegen, if we want
                    -- to return them, for a linking stage to use
                    --genfs = concatMap (getGenFs flags) pis'
                -- the pkginfos with "recompile" marked for any files whose
                -- source is newer than any of its related files
                pis'' <- chkUpd flags [] pis'
                -- just the names of the pkgs to be recompiled,
                -- in dependency order
                let fs = reverse [ f | PkgInfo { fileName = f, recompile = True } <- pis'' ]
                return fs
            Left [] -> internalError "Depend.chkDeps: tsort empty cycle"

-- Get PkgInfo for a package name.  Try to open the corresponding file.
-- Also try the .bo file (for installed libraries).
getPkgInfo :: ErrorHandle -> Flags -> PkgName -> IO (Either EMsg PkgInfo)
getPkgInfo errh flags pname =
    let name = getIdString pname ++ "." ++ bscSrcSuffix
        bsvname = getIdString pname ++ "." ++ bsvSrcSuffix
        bname = getIdString pname ++ "." ++ binSuffix
        path = ifcPath flags
        errPackageMissing = (getIdPosition pname,
                             EMissingPackage (pfpString pname))
        die_nameMismatch fname pname =
            bsError errh [(getIdPosition pname,
                           WFilePackageNameMismatch
                                 (pfpString fname) (pfpString pname))]
        trybsv :: IO (Maybe PkgInfo)
        trybsv = do
          mfile <- readFilesPath errh noPosition False [bsvname, name] path
          case mfile of
            Nothing -> return Nothing
            Just (_, fname) -> do
                pi <- getInfo errh flags [] fname
                -- XXX return the EMsg instead of dying?
                when (pkgName pi /= pname)
                    (die_nameMismatch pname (pkgName pi))
                return (Just pi)
        trybo :: IO (Maybe PkgInfo)
        trybo = do
          mfile <- readBinFilePath errh noPosition False bname path
          case mfile of
            Nothing -> return Nothing
            Just (file, fname) ->
                -- this comparison forces evaluation to force close on the file
                if file /= file then internalError "getPkgInfo" else do
                  t <- getModTime fname
                  return $ Just $
                      PkgInfo { pkgName = pname, fileName = fname,
                                srcMod = Nothing, lastMod = t, imports = [], includes = [],
                                gens = [], foreigns = [], recompile = False,
                                isbin = True }

        -- if a stage returns Nothing, then try the next stage;
        -- once a stage returns something, return it
        contIfNothing :: IO (Maybe a) -> Maybe a -> IO (Maybe a)
        contIfNothing fn Nothing = fn
        contIfNothing fn res     = return res
    in
       -- any IO failure along the way aborts the process
       trybsv >>=
       contIfNothing trybo >>=
       \res -> case res of
                 Nothing -> return (Left errPackageMissing)
                 Just pi -> return (Right pi)

-- Get PkgInfo for a string (from a given file name), fail if not parsable.
getInfo :: ErrorHandle -> Flags -> [ModName] -> FileName -> IO PkgInfo
getInfo errh flags gflags fname = do
    file' <- doCPP errh flags fname
    let isClassic = not $ hasDotSuf bsvSrcSuffix fname
    -- setClassic isClassic
    (CPackage i _ imps _ defs incs, _)
        <- parseSrc isClassic errh flags False fname file'

    -- the mod time of the source file
    tbs <- getModTime fname

    -- function to change fname's path to a new directory
    -- (like TopUtils::putInDir)
    let mkdname dir suf = dir ++ "/" ++ baseName (dropSuf fname) ++ "." ++ suf

    -- find the mod time of the bo file (either in same dir or in the bdir)
    tbo_samedir <- getModTime (dropSuf fname ++ "." ++ binSuffix)
    tbo_bdir <- case (bdir flags) of
                    Nothing -> return Nothing
                    Just dir -> getModTime (mkdname dir binSuffix)
    let tbo = if (isJust tbo_bdir) then tbo_bdir else tbo_samedir

    -- include the prelude to avoid failures when predule was updated.
    let prelude
           | not (usePrelude flags) = []
           | i == idPrelude = []
           | i == idPreludeBSV = [idPrelude]
           | otherwise = [idPrelude, idPreludeBSV]
    return $ PkgInfo {
                      pkgName = i,
                      fileName = fname,
                      srcMod = tbs,
                      lastMod = tbs `max` tbo,
                      imports = [ i | CImpId _ i <- imps] ++ prelude,
                      includes = [i |  CInclude i <- incs],
                      recompile = tbo < tbs,
                      gens = [ i | CPragma (Pproperties i pps) <- defs,
                                   PPverilog `elem` pps ] ++
                             [ i | CValueSign (CDef i _ _) <- defs,
                                   i `elem` gflags ] ++
                             [ makeGenFuncId i
                                 | CPragma (Pnoinline is) <- defs,
                                   i <- is ],
                      foreigns = [ i | CPragma (Pproperties _ pps) <- defs,
                                       (PPforeignImport i) <- pps ],
                      isbin = False }

-- Compute the transitive closure of all imports.
-- The `done' arg are the already visited packages,
-- and the `ns' arg are the names of the remaining ones.
transClose :: ErrorHandle -> Flags -> ([EMsg],[PkgInfo]) -> [PkgName] ->
              IO ([EMsg],[PkgInfo])
transClose errh flags done [] = return done
transClose errh flags (errs,done) (n:ns) = do
        --putStr (ppReadable n)
        case findInfo n done of
             Just _ -> transClose errh flags (errs,done) ns
             Nothing -> do
                epi <- getPkgInfo errh flags n
                case epi of
                  Left  em -> transClose errh flags (em:errs,done) (ns)
                  Right pi -> transClose errh flags (errs,pi:done) (ns ++ imports pi)

findInfo :: PkgName -> [PkgInfo] -> Maybe PkgInfo
findInfo _ [] = Nothing
findInfo n (pi@(PkgInfo { pkgName = n' }):_) | n == n' = Just pi
findInfo n (_:pis) = findInfo n pis

-- This tries to return a list of all files that will be generated from
-- this file after codegen.
-- XXX This needs to be kept in sync with what the backend actually does!
getGenFs :: Flags -> PkgInfo -> [String]
getGenFs flags pi =
    let prefix = dirName (fileName pi) ++ "/"
        getName = getIdString . unQualId
        mkABinFileName i = mkAName (bdir flags) prefix (getName i)
        mkVerFileName i = mkVName (vdir flags) prefix (getName i)
        mkVPIFileNames i = [ mkVPIHName (vdir flags) prefix (getName i),
                             mkVPICName (vdir flags) prefix (getName i) ]
        -- files common to all backends
        foreign_abin_files = map mkABinFileName (foreigns pi)
    in case backend flags of
         Just Bluesim ->
            let mod_abin_files = map mkABinFileName (gens pi)
            in  foreign_abin_files ++ mod_abin_files
         Just Verilog ->
            let mod_ver_files = map mkVerFileName (gens pi)
                foreign_vpi_files = if (useDPI flags)
                                    then []
                                    else concatMap mkVPIFileNames (foreigns pi)
                mod_abin_files =
                    if (genABin flags)
                    then map mkABinFileName (gens pi)
                    else []
            in  foreign_abin_files ++ foreign_vpi_files ++
                mod_ver_files ++ mod_abin_files
         Nothing ->
            foreign_abin_files

-- Update the `recompile' flag in all the PkgInfo.
chkUpd :: Flags -> [PkgInfo] -> [PkgInfo] -> IO [PkgInfo]
chkUpd flags done [] = return done
chkUpd flags done (pi:pis) = do
    --putStrLn ("chkUpd " ++ show pi)
    let genfs = getGenFs flags pi
    let incfs = includes pi
    --putStrLn (show genfs)
    genfsClks <- mapM getModTime genfs
    incfsClks <- mapM getModTime incfs
    let needGenUpd = any (srcMod pi >) genfsClks
    let needIncUpd = any (lastMod pi <) incfsClks
    --putStrLn (show (fileName pi, genfs, map (srcMod pi >) genfsClks))
    --putStr (ppReadable (pkgName pi, imports pi, map pkgName done))
    let pi' = pi { recompile = True }
    if isPreludePkg flags (fileName pi) || isbin pi then
       -- Never update Prelude files
       chkUpd flags (pi : done) pis
     else do
       -- Update if the package (i.e. .bo) or any generated files (i.e. .ba/.v)
       -- are out-of-date with respect to any import
       -- or the generated files are out-of-date with respect to the source.
       let lastCompTime = minimum ((lastMod pi) : genfsClks)
       if any (needsUpd lastCompTime done) (imports pi) || needGenUpd || needIncUpd then
           chkUpd flags (pi' : done) pis
        else
           chkUpd flags (pi : done) pis

-- Is this an installed library?
isPreludePkg :: Flags -> FileName -> Bool
isPreludePkg flags n =
    let sl = bluespecDir flags ++ "/Libraries/"
    in  take (length sl) n == sl

-- Check if out-of-date with respect to an imported module.
-- Recompilation is needed if the imported file will be
-- recompiled or if it has a later date stamp.
needsUpd :: MClockTime -> [PkgInfo] -> PkgName -> Bool
needsUpd myMod pis n =
    case findInfo n pis of
    Nothing -> internalError ("needsUpd " ++ pfpString n)
    Just pi -> recompile pi || lastMod pi > myMod

getModTime :: String -> IO MClockTime
getModTime f = CE.catch (getModificationTime' f >>= return . Just) handler
  where handler :: CE.SomeException -> IO MClockTime
        handler _ = return Nothing

-----

doCPP :: ErrorHandle -> Flags -> String -> IO String
doCPP errh flags name =
    if cpp flags
    then do
        tempName <- tmpNam
        topNameRoot <- localTmpNam
        let topName = topNameRoot ++ ".c"
            tmpNameOut = tempName ++ ".out"
        writeFileCatch errh topName ("#include \""++name++"\"\n")
        comp <- getEnvDef "CC" dfltCCompile

{- If the compiler specified in the CC environment variable has a
spaces in its name, for example CC="/usr/local/my c compiler/bin/cc",
then this will fail.  You need to properly quote the spaces.  As a
side effect, (and in fact, this was the reason why), if you include
flags in the CC variable, for example CC="cc -g", then it will work.
-}

        let backend_def = case backend flags of
                            Just Bluesim -> ["-D__GENC__"]
                            Just Verilog -> ["-D__GENVERILOG__"]
                            Nothing -> []
            cmd = unwords ([comp] ++ backend_def ++
                           ["-D__BSC__", "-E", "-nostdinc", "-traditional"] ++
                           -- the show function quotes things
                           (map show (cppFlags flags))
                           ++ [ topName, ">", tmpNameOut])
        when (verbose flags) $ putStrLn ("exec: " ++ cmd)
        rc <- system cmd
        case rc of
         ExitSuccess -> do
                file <- readFileCatch errh noPosition tmpNameOut
                removeFileCatch errh topName
                removeFileCatch errh tmpNameOut
                return file
         ExitFailure n -> do
                removeFileCatch errh topName
                removeFileCatch errh tmpNameOut
                exitFailWith errh n
    else readFileCatch errh noPosition name

parseSrc :: Bool -> ErrorHandle -> Flags -> Bool -> String -> String ->
            IO (CPackage, TimeInfo)
parseSrc True errh flags show_warns filename inp = do
  -- Classic parser
  t <- getNow
  let dumpnames = (baseName (dropSuf filename), "", "")
  start flags DFparsed
  let lflags = LFlags { lf_is_stdlib = stdlibNames flags,
                        lf_allow_sv_kws = not outlaw_sv_kws_as_classic_ids }
  case chkParse pPackage (lexStart lflags (mkFString filename) inp) of
      Right pkg -> do t <- dump errh flags t DFparsed dumpnames pkg
                      let ws = classicWarnings pkg
                      when (show_warns && (not $ null ws)) $ bsWarning errh ws
                      return (pkg, t)
      Left errs -> bsError errh errs
parseSrc False errh flags show_warns filename inp =
  -- BSV parser
  bsvParseString errh flags show_warns filename (baseName $ dropSuf filename) inp

chkParse :: Parser [Token] a -> [Token] -> Either [EMsg] a
chkParse p ts =
    case parse p ts of
        Right ((m,_):_) -> Right m
        Left  (ss,ts)   -> Left [errSyntax (filter (not . null ) ss) ts]
        Right []        -> internalError "Depend.chkParse: Right []"

----
findPackages :: ErrorHandle -> Flags -> FileName -> IO ([EMsg],[PkgInfo])
findPackages errh flags name = do
  let gflags = [ mkId noPosition (mkFString s) | s <- genName flags ]
  pi <- getInfo errh flags gflags name
  transClose errh flags ([],[pi]) (imports pi)

-- generate the file name dependencies for filename
-- A package depends on its own source file name
-- plus the imported packages (.bo)
-- plus the included files
genDepend :: ErrorHandle -> Flags -> FileName ->
             IO ([EMsg],[(FileName, [FileName])])
genDepend errh flags name = do
  (errs,pis) <- findPackages errh flags name
  let pmap :: DM.Map PkgName PkgInfo
      pmap = DM.fromList [(pkgName pki, pki) | pki <- pis]
      lookupP p =
            case (DM.lookup p pmap) of
              Just pinfo -> [pinfo]
              Nothing    -> [] -- internalError $ "Depend:genDepend " ++ show p
      --
      -- bo name and location
      boName p  = putInDir (bdir flags) (fileName p) binSuffix
      -- bsv source file (if it exists)
      getSelf p | isbin p = []
                | otherwise = [fileName p]
      --
      getImports p = -- package name .bo
          let fnp p | isbin p = fileName p
                    | otherwise = boName p
          in map fnp (concatMap lookupP (imports p))
      --
      extr :: PkgInfo -> [(FileName, [FileName])]
      extr pki | isbin pki = []
      extr pki = [(boName pki, getSelf pki ++ getImports pki ++ includes pki)]
  return (errs,concatMap extr pis)

genFileDepend :: ErrorHandle -> Flags -> FileName -> IO ([EMsg],[FileName])
genFileDepend errh flags name = do
    (errs,pis) <- findPackages errh flags name
    let extrFiles :: PkgInfo -> [FileName]
        extrFiles p | isbin p   = []
                    | otherwise = fileName p : includes p
    return (errs, nub $ concatMap extrFiles pis)