module Parser.Classic.Warnings(classicWarnings) where

import Control.Monad.Reader
import Control.Monad.Writer
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Set(Set, (\\))

import CFreeVars
import CSyntax
import CSyntaxUtil
import Error
import Id
import Position
import Util(concatMapM, fromJustOrErr)

-- ReaderT (bound variables) $ Writer (used variables)
type ClassicWarnM = ReaderT (Set Id) (Writer (Set Id))

classicWarnings :: CPackage -> [WMsg]
classicWarnings (CPackage _ _ _ _ ds _) = concatMap getWarnings ds
  where getWarnings = fst . runWriter . (flip runReaderT $ topBound) . classicWarnDefn
        topBound = S.fromList $ concatMap getBound ds
        getBound (Ctype {}) = []
        getBound (Cdata {}) = []
        getBound (Cstruct {}) = []
        -- Ignoring shadowing of class methods (for now at least).
        getBound (Cclass {}) = []
        getBound (Cinstance {}) = []
        getBound (CValue i _) = [i]
        getBound (CValueSign (CDef i _ _)) = [i]
        getBound (CValueSign (CDefT i _ _ _)) = [i]
        getBound (Cforeign i _ _ _) = [i]
        getBound (Cprimitive i _) = [i]
        getBound (CprimType {}) = []
        getBound (CPragma {}) = []
        -- Ignore shadowing of imported names.
        getBound (CIinstance {}) = []
        getBound (CItype {}) = []
        getBound (CIclass {}) = []
        getBound (CIValueSign {}) = []

classicWarnDefn :: CDefn -> ClassicWarnM [WMsg]
classicWarnDefn (Ctype {}) = return []
classicWarnDefn (Cdata {}) = return []
classicWarnDefn (Cstruct {}) = return []
-- Could look at default method definitions, but this seems like overkill.
classicWarnDefn (Cclass {}) = return []
-- Instances could also be overkill, but they can get complicated.
classicWarnDefn (Cinstance _ ds) = concatMapM classicWarnDefl ds
classicWarnDefn (CValue _ cs) = concatMapM classicWarnClause cs
classicWarnDefn (CValueSign d) = classicWarnDef d
classicWarnDefn (Cforeign {}) = return []
classicWarnDefn (Cprimitive {}) = return []
classicWarnDefn (CprimType {}) = return []
classicWarnDefn (CPragma {}) = return []
-- Don't warn about imported definitions
classicWarnDefn (CIinstance {}) = return []
classicWarnDefn (CItype {}) = return []
classicWarnDefn (CIclass {}) = return []
classicWarnDefn (CIValueSign {}) = return []

useId :: Id -> ClassicWarnM ()
useId i = tell $ S.singleton i

withBindings :: Set Id -> ClassicWarnM [WMsg] -> ClassicWarnM [WMsg]
withBindings bindings m = do
  bound <- ask
  let shadowed = bound `S.intersection` bindings
      bindPosMap = M.fromSet getPosition bindings
      bindingPosition i = fromJustOrErr ("withBindings not found: " ++ show i) $ M.lookup i bindPosMap
      shadow_ws = [ (bindingPosition i, WShadowDecl (getIdString i) (getPosition i))
                  | i <- S.toList shadowed
                  ]
  local (const $ bindings `S.union` bound) $ censor (\\ bindings) $ do
      (ws, used) <- listen m
      let unused_ws = [ (getPosition i, WUnusedDef (getIdString i))
                      | i <- S.toList (bindings \\ used), take 1 (getIdString i) /= "_"
                      ]
      return $ shadow_ws ++ ws ++ unused_ws

-- Quals add names in sequence, so we need to handle them only-by-one.
withQuals :: [CQual] -> ClassicWarnM [WMsg] -> ClassicWarnM [WMsg]
withQuals [] m = m
withQuals (CQFilter e : qs) m = do
  ws1 <- classicWarnExpr e
  ws2 <- withQuals qs m
  return $ ws1 ++ ws2
withQuals (CQGen _ p e : qs) m = do
  ws1 <- classicWarnExpr e
  ws2 <- withBindings (getPV p) $ withQuals qs m
  return $ ws1 ++ ws2

-- Recursion is handled outside of classicWarnDefl, based on context.
classicWarnDefl :: CDefl -> ClassicWarnM [WMsg]
classicWarnDefl (CLValueSign d qs) =
  withQuals qs $ classicWarnDef d
classicWarnDefl (CLValue i cs qs) =
  withQuals qs $ concatMapM classicWarnClause cs
classicWarnDefl (CLMatch p e) =
  -- CLMatch binds variables based on the value of e, so they aren't
  -- in scope when checking the expression.
  classicWarnExpr e

-- Recursion is handled outside of classicWarnDef, based on context.
classicWarnDef :: CDef -> ClassicWarnM [WMsg]
classicWarnDef (CDef i _ cs) = concatMapM classicWarnClause cs
classicWarnDef (CDefT i _ _ cs) = concatMapM classicWarnClause cs

classicWarnClause :: CClause -> ClassicWarnM [WMsg]
classicWarnClause (CClause ps qs e) =
  withBindings (S.unions $ map getPV ps) $
    withQuals qs $ classicWarnExpr e

classicWarnArm :: CCaseArm -> ClassicWarnM [WMsg]
classicWarnArm arm =
  withBindings (getPV $ cca_pattern arm) $
    withQuals (cca_filters arm) $
     classicWarnExpr $ cca_consequent arm

classicWarnExpr :: CExpr -> ClassicWarnM [WMsg]
classicWarnExpr (CLam (Right i) e) = withBindings (S.singleton i) $ classicWarnExpr e
classicWarnExpr (CLam (Left  _) e) = classicWarnExpr e
classicWarnExpr (CLamT (Right i) _ e) = withBindings (S.singleton i) $ classicWarnExpr e
classicWarnExpr (CLamT (Left _) _ e) = classicWarnExpr e
classicWarnExpr (Cletseq [] e) = classicWarnExpr e
classicWarnExpr (Cletseq (d:ds) e) = do
  ws1 <- classicWarnDefl d
  ws2 <- withBindings (S.fromList $ getLDefs d) $ classicWarnExpr (Cletseq ds e)
  return $ ws1 ++ ws2
classicWarnExpr (Cletrec ds e) =
  withBindings (S.fromList $ concatMap getLDefs ds) $ do
    ws1 <- concatMapM classicWarnDefl ds
    ws2 <- classicWarnExpr e
    return $ ws1 ++ ws2
-- _i is a field selector, not a variable
classicWarnExpr (CSelect e _i) = classicWarnExpr e
classicWarnExpr (CCon _c es) = concatMapM classicWarnExpr es
classicWarnExpr (Ccase _ e as) = do
  ws1 <- classicWarnExpr e
  ws2 <- concatMapM classicWarnArm as
  return $ ws1 ++ ws2
classicWarnExpr (CStruct _ _ ies) = concatMapM (classicWarnExpr . snd) ies
classicWarnExpr (CStructUpd e ies) = concatMapM classicWarnExpr (e : map snd ies)
classicWarnExpr (Cwrite _ lhs rhs) = do
  ws1 <- classicWarnExpr lhs
  ws2 <- classicWarnExpr rhs
  return $ ws1 ++ ws2
classicWarnExpr (CAny _ _) = return []
classicWarnExpr (CVar i) = do useId i; return []
classicWarnExpr (CApply f es) = concatMapM classicWarnExpr (f:es)
classicWarnExpr (CTaskApply f es) = concatMapM classicWarnExpr (f:es)
classicWarnExpr (CTaskApplyT f _ es) = concatMapM classicWarnExpr (f:es)
classicWarnExpr (CLit _) = return []
classicWarnExpr (CBinOp l i r) = do
  useId i
  ws1 <- classicWarnExpr l
  ws2 <- classicWarnExpr r
  return $ ws1 ++ ws2
classicWarnExpr (CHasType e _) = classicWarnExpr e
classicWarnExpr (Cif _ c t e) = concatMapM classicWarnExpr [c,t,e]
classicWarnExpr (CSub _ x a) = do
  ws1 <- classicWarnExpr x
  ws2 <- classicWarnExpr a
  return $ ws1 ++ ws2
classicWarnExpr (CSub2 x a b) = concatMapM classicWarnExpr [x, a, b]
classicWarnExpr (CSubUpdate _ x (a, b) y) = concatMapM classicWarnExpr [x, a, b, y]
classicWarnExpr (Cmodule pos ms) = classicWarnMStmts pos ms
classicWarnExpr (Cinterface _ _ ds) = concatMapM classicWarnDefl ds
classicWarnExpr (CmoduleVerilog n _ _ _ vargs _ _ _) = concatMapM classicWarnExpr (n : map snd vargs)
classicWarnExpr (CForeignFuncC _ _) = return []
classicWarnExpr (Cdo _ stmts) = classicWarnStmts Nothing stmts
classicWarnExpr (Caction _ stmts) = classicWarnStmts Nothing stmts
classicWarnExpr (Crules _ rs) = concatMapM classicWarnRule rs
classicWarnExpr (COper ops) = concatMapM classicWarnOp ops
classicWarnExpr (CCon1 _ _ e) = classicWarnExpr e
classicWarnExpr (CSelectTT _ e _) = classicWarnExpr e
classicWarnExpr (CCon0 _ _) = return []
classicWarnExpr (CConT _ _ es) = concatMapM classicWarnExpr es
classicWarnExpr (CStructT _ ies) = concatMapM (classicWarnExpr . snd) ies
classicWarnExpr (CSelectT _ _) = return []
classicWarnExpr (CLitT _ _) = return []
classicWarnExpr (CAnyT _ _ _) = return []
classicWarnExpr (CmoduleVerilogT _ n _ _ _ vargs _ _ _) = concatMapM classicWarnExpr (n : map snd vargs)
classicWarnExpr (CForeignFuncCT _ _) = return []
classicWarnExpr (CTApply e _) = classicWarnExpr e
classicWarnExpr (Cattributes _) = return []

classicWarnMStmts :: Position -> [CMStmt] -> ClassicWarnM [WMsg]
classicWarnMStmts pos = classicWarnStmts (Just pos) . map toStmt
  where toStmt (CMStmt s) = s
        toStmt (CMrules e) = CSExpr Nothing e
        toStmt (CMinterface e) = CSExpr Nothing e
        toStmt (CMTupleInterface pos es) = CSExpr Nothing (mkTuple pos es)

rebuildBody :: Maybe Position -> [CStmt] -> CExpr
-- Cdo False might not be right, but we ignore this argument of Cdo anyway.
rebuildBody Nothing stmts = Cdo False stmts
rebuildBody (Just modPos) stmts = Cmodule modPos $ map CMStmt stmts

-- The Maybe Position is Just pos for statements that came from a module context.
classicWarnStmts :: Maybe Position -> [CStmt] -> ClassicWarnM [WMsg]
classicWarnStmts _ [] = return []
classicWarnStmts modPos (CSBindT p _ _ _ e : stmts) = do
  ws1 <- classicWarnExpr e
  let bvs = getPV p
  ws2 <- withBindings bvs $ do
           -- In module context, monadically bound names are always "used".
           -- (via their side effect on instance names)
           when (isJust modPos) (mapM_ useId $ S.toList bvs)
           classicWarnStmts modPos stmts
  return $ ws1 ++ ws2
classicWarnStmts modPos (CSBind p _ _ e : stmts) = do
  ws1 <- classicWarnExpr e
  let bvs = getPV p
  ws2 <- withBindings bvs $ do
           -- In module context, monadically bound names are always "used".
           -- (via their side effect on instance names)
           when (isJust modPos) (mapM_ useId $ S.toList bvs)
           classicWarnStmts modPos stmts
  return $ ws1 ++ ws2
classicWarnStmts modPos (CSletseq ds : stmts)
  = classicWarnExpr (Cletseq ds $ rebuildBody modPos stmts)
classicWarnStmts modPos (CSletrec ds : stmts)
  = classicWarnExpr (Cletrec ds $ rebuildBody modPos stmts)
classicWarnStmts modPos (CSExpr _ e  : stmts) = do
  ws1 <- classicWarnExpr e
  ws2 <- classicWarnStmts modPos stmts
  return $ ws1 ++ ws2

classicWarnRule :: CRule -> ClassicWarnM [WMsg]
classicWarnRule (CRule _ mname qs e) = do
  ws1 <- maybe (return []) classicWarnExpr $ mname
  ws2 <- withQuals qs $ classicWarnExpr e
  return $ ws1 ++ ws2
classicWarnRule (CRuleNest _ mname qs rs) = do
  ws1 <- maybe (return []) classicWarnExpr $ mname
  ws2 <- withQuals qs $ concatMapM classicWarnRule rs
  return $ ws1 ++ ws2

classicWarnOp :: COp -> ClassicWarnM [WMsg]
classicWarnOp (CRand e) = classicWarnExpr e
classicWarnOp (CRator _ i) = do useId i; return []