module FrontEnd.Warning(
    Warning(..),
    MonadWarn(..),
    WarnType(..),
    processErrors,
    warn,
    err,
    addWarn,
    -- IO monad
    processIOErrors,
    printIOErrors
    ) where

import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.Writer
import Data.IORef
import System.IO.Unsafe

import FrontEnd.SrcLoc
import Name.Name
import Options
import PackedString
import StringTable.Atom
import Util.Gen

data Warning = Warning {
    warnSrcLoc  :: !SrcLoc,
    warnType    :: WarnType,
    warnMessage :: String
    } deriving(Eq,Ord)

class Monad m => MonadWarn m where
    addWarning :: Warning -> m ()
    addWarning w = fail $ show w

addWarn :: (MonadWarn m, MonadSrcLoc m) => WarnType -> String -> m ()
addWarn t m = do
    sl <- getSrcLoc
    warn sl t m

warn :: MonadWarn m => SrcLoc -> WarnType -> String -> m ()
warn s t m = addWarning Warning
    { warnSrcLoc = s, warnType = t, warnMessage = m }

err :: MonadWarn m => WarnType -> String -> m ()
err t m = warn bogusASrcLoc t m

pad n s = case length s of
    x | x >= n -> s
    x -> s ++ replicate (n - x) ' '

processIOErrors :: IO ()
processIOErrors = do
    ws <- readIORef ioWarnings
    processErrors' True ws
    writeIORef ioWarnings []

-- | just show IO errors and return whether it would have died
printIOErrors :: IO Bool
printIOErrors = do
    ws <- readIORef ioWarnings
    b <- processErrors' False ws
    writeIORef ioWarnings []
    return b

processErrors :: [Warning] -> IO ()
processErrors ws = processErrors' True ws >> return ()

processErrors' :: Bool -> [Warning] -> IO Bool
processErrors' _ [] = return False
processErrors' doDie ws = putErrLn "" >> mapM_ s (snub ws) >> when (die && doDie) exitFailure >> return die where
--    ws' = filter ((`notElem` ignore) . warnType ) $ snub ws
    s Warning { warnSrcLoc = sl, warnType = t, warnMessage = m }
        | sl == bogusASrcLoc = putErrLn $ msg t m
    s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = -1 },
                warnType = t ,warnMessage = m } = putErrLn (unpackPS fn ++ ": "  ++ msg t m)
    s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l },
                warnType = t ,warnMessage = m } = putErrLn (unpackPS fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)
    die = (any warnIsFatal (map warnType ws)) && not (optKeepGoing options)

data WarnType
    = AmbiguousExport Module [Name]
    | AmbiguousName Name [Name]
    | DuplicateInstances
    | InvalidDecl
    | MissingDep String
    | MissingModule Module
    | MultiplyDefined Name [SrcLoc]
    | InvalidFFIType
    | OccursCheck
    | PrimitiveBadType
    | PrimitiveUnknown Atom
    | TypeSynonymPartialAp
    | TypeSynonymRecursive
    | UndefinedName Name
    | UnificationError
    | UnknownDeriving [Class]
    | UnknownOption
    | UnknownPragma PackedString
    | UnsupportedFeature
    deriving(Eq,Ord)

warnIsFatal w = f w where
    f AmbiguousExport {} = True
    f AmbiguousName {} = True
    f InvalidDecl {} = True
    f InvalidFFIType {} = True
    f DuplicateInstances {} = True
    f MissingDep {} = True
    f MissingModule {} = True
    f MultiplyDefined {} = True
    f OccursCheck {} = True
    f TypeSynonymPartialAp {} = True
    f TypeSynonymRecursive {} = True
    f UndefinedName {} = True
    f UnificationError {} = True
    f UnknownDeriving {} = True
    f UnsupportedFeature {} = True
    f _ = False

instance Show Warning where
    show  Warning { warnSrcLoc = sl, warnType = t, warnMessage = m }
        | sl == bogusASrcLoc =  msg t m
    show  Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l },
                                          warnType = t ,warnMessage = m } =
         (unpackPS fn ++ ":" ++ pad 3 (show l) ++  " - "  ++ msg t m)
msg t m = (if warnIsFatal t then "Error: " else "Warning: ") ++ m

_warnings = [
    ("deprecations", "warn about uses of functions & types that are deprecated"),
    ("duplicate-exports", "warn when an entity is exported multiple times"),
    ("hi-shadowing", "warn when a .hi file in the current directory shadows a library"),
    ("incomplete-patterns", "warn when a pattern match could fail"),
    ("misc", "enable miscellaneous warnings"),
    ("missing-fields", "warn when fields of a record are uninitialised"),
    ("missing-methods", "warn when class methods are undefined"),
    ("missing-signatures", "warn about top-level functions without signatures"),
    ("name-shadowing", "warn when names are shadowed"),
    ("overlapping-patterns", "warn about overlapping patterns"),
    ("simple-patterns", "warn about lambda-patterns that can fail"),
    ("type-defaults", "warn when defaulting happens"),
    ("unused-binds", "warn about bindings that are unused"),
    ("unused-imports", "warn about unnecessary imports"),
    ("unused-matches", "warn about variables in patterns that aren't used")
    ]

----------------
-- Warning monad
----------------

{-# NOINLINE ioWarnings #-}
ioWarnings :: IORef [Warning]
ioWarnings = unsafePerformIO $ newIORef []

instance MonadWarn IO where
    addWarning w = modifyIORef ioWarnings (w:)
instance MonadWarn (Writer [Warning]) where
    addWarning w = tell [w]
instance MonadWarn Identity
instance MonadWarn m => MonadWarn (ReaderT a m) where
    addWarning w = lift $ addWarning w