module UHC.Light.Compiler.Pred.CtxtRedOnly.RedGraph
( module UHC.Util.AGraph
, RedNode (..)
, RedGraph', RedGraph, emptyRedGraph
, mkRedGraphFromReductions, addToRedGraphFromReductions
, addToRedGraphFromAssumes, mkRedGraphFromAssumes
, ppRedGraph
, addAssumption
, addReduction
, redPruneReductionsUntil
, redAlternatives )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.VarMp
import Data.Maybe
import UHC.Light.Compiler.CHR.CtxtRedOnly.Constraint
import UHC.Light.Compiler.CHR.CtxtRedOnly.Constraint
import UHC.Light.Compiler.Pred.CtxtRedOnly.Heuristics
import qualified Data.Map as Map
import qualified Data.Set as Set
import UHC.Util.AGraph
import UHC.Util.Pretty
import Data.Graph.Inductive.Graph
import UHC.Util.Utils

{-# LINE 34 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
data RedNode p
  =  Red_Pred { rednodePred 	::  !p	 	}
  |  Red_And  { rednodePreds 	::  ![p] 	}
  deriving (Eq, Ord)

mkRedNode :: [p] -> RedNode p
mkRedNode [p] = Red_Pred p
mkRedNode ps  = Red_And ps

redNodePreds :: RedNode p -> [p]
redNodePreds (Red_Pred  q) = [q]
redNodePreds (Red_And  qs) = qs

true  ::  RedNode p
true  =   mkRedNode []

{-# LINE 52 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
type RedGraph' p info = AGraph (RedNode p) info

type RedGraph = RedGraph' CHRPredOcc RedHowAnnotation

emptyRedGraph :: Ord p => RedGraph' p i
emptyRedGraph = emptyAGraph

{-# LINE 61 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
addToRedGraphFromReductions :: [Constraint] -> RedGraph -> RedGraph
addToRedGraphFromReductions cs g = foldr addReduction g cs

mkRedGraphFromReductions :: [Constraint] -> RedGraph
mkRedGraphFromReductions cs = addToRedGraphFromReductions cs emptyRedGraph

{-# LINE 69 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
addToRedGraphFromAssumes :: ConstraintToInfoMap -> RedGraph -> RedGraph
addToRedGraphFromAssumes cm g = Map.foldrWithKey addAssumption g cm

mkRedGraphFromAssumes :: ConstraintToInfoMap -> RedGraph
mkRedGraphFromAssumes cm = addToRedGraphFromAssumes cm emptyRedGraph

{-# LINE 77 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
instance PP p => Show (RedNode p) where
  show = showPP . pp

instance PP p => PP (RedNode p) where
  pp (Red_Pred p)    = pp p
  pp (Red_And [])    = pp "True"
  pp (Red_And _ )    = pp "And"

{-# LINE 87 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
ppRedGraph :: (PP p, PP i) => RedGraph' p i -> PP_Doc
ppRedGraph ag = "RedGraph" >-< indent 2 ((ppBracketsCommasBlock $ nodes g) >-< (ppBracketsCommasBlock $ edges g) >-< pp (show g))
  where g = agraphGraph ag

{-# LINE 97 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
addAssumption :: Constraint -> [RedHowAnnotation] -> RedGraph -> RedGraph
addAssumption (Assume  p)  is  = insertEdges (zip3 (repeat (Red_Pred p)) (repeat true) is)
addAssumption _            _   = id

{-# LINE 103 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
addReduction :: Constraint -> RedGraph -> RedGraph
addReduction (Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=[q]})
                                    =  insertEdge (Red_Pred p, Red_Pred q  , i)
addReduction (Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})
                                    =  let  andNd  = Red_And ps
                                            edges  = map (\q -> (andNd, Red_Pred q, i)) ps
                                       in   insertEdges ((Red_Pred p, andNd, i) : edges)
addReduction _                      =  id

{-# LINE 121 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
redPruneReductionsUntil :: [CHRPredOcc] -> (CHRPredOcc -> Bool) -> RedGraph -> RedGraph
redPruneReductionsUntil leaves stop gr
  = dels (map Red_Pred leaves) gr
  where dels leaves g = foldr del g leaves
        del  leaf   g | all (not . stop)
                        $ redNodePreds leaf = dels (map snd pres)
                                              $ deleteNode leaf
                                              $ foldr (\(_,from) g -> deleteEdge (from,leaf) g) g pres
                      | otherwise           = g
          where pres = predecessors g leaf

{-# LINE 138 "src/ehc/Pred/CtxtRedOnly/RedGraph.chs" #-}
redAlternatives :: RedGraph -> CHRPredOcc -> HeurAlts
redAlternatives gr
  = recOr Set.empty
  where  recOr visited p = HeurAlts p (map (recAnd visited') (successors gr (Red_Pred p)))
           where visited' = Set.insert p visited

         recAnd visited (i, n)
           = HeurRed i (map mk qs)
           where qs = redNodePreds n
                 mk q | Set.member q visited = HeurAlts q [HeurRed_Rec q]
                      | otherwise            = recOr visited q