{-# LANGUAGE CPP #-}
module IDropRules (iDropRules) where

import qualified Data.Set as S
import qualified Data.Map.Lazy as M
import Data.List(partition, find)
import Control.Monad(when)

import IntLit
import Position
import Id
import Flags(Flags, removeFalseRules, removeEmptyRules, warnUndetPred)
import Pragma
import Error(internalError, ErrMsg(..), ErrorHandle, bsWarning)
import ISyntax
import Prim
import VModInfo(VFieldInfo(..))
import Util(fromJustOrErr)
import PPrint


-- Handle rules that don't do anything,
-- either because the predicate is False or the body has no actions.
-- Any MethodPred signals associated with the dropped rules are dropped.
--
-- Warn the user about false/empty rules.  If the appropriate flag is set,
-- the rules are dropped.
--
-- False/empty rules that resulted from rule splitting are removed
-- regardless of the flag and no warning is issued.
--
-- Removing a noAction rule can only be done if the rule is not preempting
-- another rule (unless that rule is also noAction).
--
-- we don't drop any method rule bodies here
-- because the backend can't deal with methods
-- that have empty action bodies
--
iDropRules :: ErrorHandle -> Flags -> IModule a -> IO (IModule a)
iDropRules errh flags imod0 = do
  imod1 <- dropFalseRules errh flags imod0
  imod2 <- dropEmptyRules errh flags imod1
  warnUndetPreds errh flags imod2
  return imod2

dropFalseRules :: ErrorHandle -> Flags -> IModule a -> IO (IModule a)
dropFalseRules errh flags imod@(IModule { imod_rules = (IRules sps rs),
                                          imod_local_defs = ds }) = do
    -- identify false rules
    let (falseRules, okRules) = partition isFalseRule rs

    -- we treat the split rules differently, so separate them out
    let (splitFalseRules, nonsplitFalseRules) =
            partition isSplitRule falseRules

    -- warn about the non-split False rules
    let removeFalseRule = removeFalseRules flags
    let warnFalseRule (IRule {
               irule_name = rid , irule_pragmas = pragmas } ) =
           if (RPnoWarn `elem` pragmas)
           then return ()
           else bsWarning errh
                    [(getPosition rid,
                      WRuleAlwaysFalse (dropRulePrefix rid) removeFalseRule)]
    mapM_ warnFalseRule nonsplitFalseRules

    -- the final set of kept rules and dropped rules, depending on the flag
    let (rs', dropped_rules) =
            if removeFalseRule
            then -- all False rules are dropped
                 (okRules, falseRules)
            else -- keep the non-split rules, but always drop the split rules
                 (okRules ++ nonsplitFalseRules, splitFalseRules)

    -- drop the pragmas and defs associated with the dropped rules
    let dropped_rule_ids = map getIRuleId dropped_rules
        sps' = removeSchedPragmaIds dropped_rule_ids sps
        ds' = removeIDefMethodPredsByRuleId dropped_rule_ids ds

    return $ imod { imod_rules       = (IRules sps' rs')
                  , imod_local_defs  = ds'
                  }


dropEmptyRules :: ErrorHandle -> Flags -> IModule a -> IO (IModule a)
dropEmptyRules errh flags imod@(IModule { imod_rules = (IRules sps rs),
                                          imod_local_defs = ds }) = do
    -- identify empty rules which do not preempt other rules (in sps)
    let (emptyNonPreemptRules, okRules) =
            partition (\r -> isNoActionRule r &&
                             not (isRulePreempt (getIRuleId r) sps))
                rs

    -- we treat the split rules differently, so separate them out
    let (splitEmptyRules, nonsplitEmptyRules) =
          partition isSplitRule emptyNonPreemptRules

    -- warn about the empty rules
    let removeEmptyRule = removeEmptyRules flags
    let warnEmptyRule ( IRule {
              irule_name = rid , irule_pragmas = pragmas } )=
           if (RPnoWarn `elem` pragmas)
           then return ()
           else bsWarning errh
                    [(getPosition rid,
                      WRuleNoActions (dropRulePrefix rid) removeEmptyRule)]
    mapM_ warnEmptyRule nonsplitEmptyRules

    -- the final set of kept rules and dropped rules, depending on the flag
    let (rs', dropped_rules) =
            if removeEmptyRule
            then -- all empty rules are dropped
                 (okRules, emptyNonPreemptRules)
            else -- keep the non-split rules, but always drop the split rules
                 (okRules ++ nonsplitEmptyRules, splitEmptyRules)

    -- drop the pragmas and defs associated with the dropped rules
    let dropped_rule_ids = map getIRuleId dropped_rules
        sps' = removeSchedPragmaIds dropped_rule_ids sps
        ds' = removeIDefMethodPredsByRuleId dropped_rule_ids ds

    return $ imod { imod_rules       = (IRules sps' rs')
                  , imod_local_defs  = ds'
                  }


-- will the rule never fire
isFalseRule :: IRule a -> Bool
isFalseRule (IRule { irule_pred =
               (ICon _ (ICInt { iVal = (IntLit { ilValue = 0 }) }))
                   } )
              = True
isFalseRule _ = False

-- is the rule a result of splitting
isSplitRule :: IRule a -> Bool
isSplitRule r = isSplitRuleId (getIRuleId r)

-- is the rule a noAction rule
isNoActionRule :: IRule a -> Bool
isNoActionRule (IRule {
       irule_body = (ICon _ (ICPrim { primOp = PrimNoActions })) } )
    = True
isNoActionRule _ = False


removeIDefMethodPredsByRuleId :: [Id] -> [IDef a] -> [IDef a]
removeIDefMethodPredsByRuleId [] ds = ds
removeIDefMethodPredsByRuleId dropped_rule_ids ds =
    let
        dropped_id_set = S.fromList dropped_rule_ids

        isRuleProp (DefP_Rule {}) = True
        isRuleProp _              = False

        isForDroppedRule ps =
            case (find isRuleProp ps) of
              Just (DefP_Rule r) -> r `S.member` dropped_id_set
              _ -> internalError ("MethodPred with no DefP_Rule")

        dropDef (IDef i _ _ ps) =
            (hasIdProp i IdPMethodPredicate) &&
            (isForDroppedRule ps)
    in
        filter (not . dropDef) ds


warnUndetPreds :: ErrorHandle -> Flags -> IModule a -> IO ()
warnUndetPreds errh flags imod | not (warnUndetPred flags) = return ()
warnUndetPreds errh flags imod@(IModule { imod_rules = (IRules _ rs),
                                          imod_interface = ms,
                                          imod_local_defs = ds }) = do
    let
        hmap = M.fromList [ (i, findUndets e) | (IDef i _ e _) <- ds ]

        -- this returns a list of positions for any undet values found
        findUndets :: IExpr a -> [Position]
        findUndets (IAps f _ as) = findUndets f ++ concatMap findUndets as
        findUndets (ICon i (ICUndet {})) = [getPosition i]
        findUndets (ICon i (ICValue {})) =
            fromJustOrErr ("findUndets: " ++ ppReadable i) $ M.lookup i hmap
        findUndets (ICon _ _) = []
        findUndets e = internalError ("warnUndetCond: " ++ ppReadable e)

{-      -- for trace output of an expression containing an undet
        dmap = M.fromList [ (i, e) | (IDef i _ e _) <- ds ]
        expandExpr (IAps f ts as) = (IAps (expandExpr f) ts (map expandExpr as))
        expandExpr (ICon i (ICValue {})) =
            expandExpr $
                fromJustOrErr ("expandExpr: " ++ ppReadable i) $ M.lookup i dmap
        expandExpr e = e
-}
    let
        (rdy_ms, actual_ms) = partition (isRdyId . ief_name) ms
        rdymap = M.fromList [ (i,e) | (IEFace i _ (Just (e, t)) _ _ _) <- rdy_ms ]
        getRdy i = fromJustOrErr ("getRdy: " ++ ppReadable i) $
                       M.lookup (mkRdyId i) rdymap

        warn i is_meth name poss =
            let keepFn p = (p /= noPosition) && (isUsefulPosition p)
                poss' = filter keepFn poss
            in  bsWarning errh [(getPosition i, WRuleUndetPred is_meth name poss')]

        -- if it's a method, 'rdy_poss' contains any positions from the RDY method
        checkRule is_meth rdy_poss (IRule { irule_name = rid, irule_pred = e }) = do
            let name = if is_meth
                       then (getIdString rid) else (dropRulePrefix rid)
            let undet_poss = rdy_poss ++ findUndets e
            when (not (null undet_poss)) $
                warn rid is_meth name undet_poss

        checkMethod (IEFace i _ _ maybe_rs _ (Method {})) = do
            let rdy_undet_poss = findUndets (getRdy i)
            case maybe_rs of
              Nothing ->
                  when (not (null rdy_undet_poss)) $
                      warn i True (getIdString i) rdy_undet_poss
              Just (IRules _ meth_rs) ->
                  mapM_ (checkRule True rdy_undet_poss) meth_rs
        checkMethod _ = return ()  -- Clock, Reset, Inout are OK

    mapM_ (checkRule False []) rs
    mapM_ checkMethod actual_ms