module UHC.Util.CHR.Rule
( CHRRule(..)
, Rule(..)
, (<==>), (==>), (|>)
, MkSolverConstraint(..)
, MkSolverGuard(..)
, MkSolverPrio(..)
)
where
import qualified UHC.Util.TreeTrie as TreeTrie
import UHC.Util.CHR.Base
import UHC.Util.VarMp
import UHC.Util.Utils
import Data.Monoid
import Data.Typeable
import qualified Data.Set as Set
import UHC.Util.Pretty
import UHC.Util.CHR.Key
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize
import UHC.Util.Substitutable
data CHRRule env subst
= CHRRule
{ chrRule :: Rule (CHRConstraint env subst) (CHRGuard env subst) ()
}
deriving (Typeable)
type instance TTKey (CHRRule env subst) = TTKey (CHRConstraint env subst)
deriving instance Typeable (CHRRule env subst)
instance Show (CHRRule env subst) where
show _ = "CHRRule"
instance PP (CHRRule env subst) where
pp (CHRRule r) = pp r
data Rule cnstr guard prio
= Rule
{ ruleHead :: ![cnstr]
, ruleSimpSz :: !Int
, ruleGuard :: ![guard]
, ruleBody :: ![cnstr]
, rulePrio :: !(Maybe prio)
}
deriving (Typeable)
emptyCHRGuard :: [a]
emptyCHRGuard = []
instance Show (Rule c g p) where
show _ = "Rule"
instance (PP c, PP g, PP p) => PP (Rule c g p) where
pp chr
= case chr of
(Rule h@(_:_) sz g b p) | sz == 0 -> ppChr ([ppL h, pp "==>"] ++ ppGB g b)
(Rule h@(_:_) sz g b p) | sz == length h -> ppChr ([ppL h, pp "<==>"] ++ ppGB g b)
(Rule h@(_:_) sz g b p) -> ppChr ([ppL (take sz h), pp "|", ppL (drop sz h), pp "<==>"] ++ ppGB g b)
(Rule [] _ g b p) -> ppChr (ppGB g b)
where ppGB g@(_:_) b@(_:_) = [ppL g, "|" >#< ppL b]
ppGB g@(_:_) [] = [ppL g >#< "|"]
ppGB [] b@(_:_) = [ppL b]
ppGB [] [] = []
ppL [x] = pp x
ppL xs = ppBracketsCommasBlock xs
ppChr l = vlist l
type instance TTKey (Rule cnstr guard prio) = TTKey cnstr
instance (TTKeyable cnstr) => TTKeyable (Rule cnstr guard prio) where
toTTKey' o chr = toTTKey' o $ head $ ruleHead chr
type instance ExtrValVarKey (Rule c g p) = ExtrValVarKey c
instance (VarExtractable c, VarExtractable g, ExtrValVarKey c ~ ExtrValVarKey g) => VarExtractable (Rule c g p) where
varFreeSet (Rule {ruleHead=h, ruleGuard=g, ruleBody=b})
= Set.unions $ concat [map varFreeSet h, map varFreeSet g, map varFreeSet b]
instance (VarUpdatable c s, VarUpdatable g s) => VarUpdatable (Rule c g p) s where
varUpd s r@(Rule {ruleHead=h, ruleGuard=g, ruleBody=b})
= r {ruleHead = map (varUpd s) h, ruleGuard = map (varUpd s) g, ruleBody = map (varUpd s) b}
class MkSolverConstraint c c' where
toSolverConstraint :: c' -> c
fromSolverConstraint :: c -> Maybe c'
instance MkSolverConstraint c c where
toSolverConstraint = id
fromSolverConstraint = Just
instance
( IsCHRConstraint e c s
, TTKey (CHRConstraint e s) ~ TTKey c
, ExtrValVarKey (CHRConstraint e s) ~ ExtrValVarKey c
) => MkSolverConstraint (CHRConstraint e s) c where
toSolverConstraint = CHRConstraint
fromSolverConstraint (CHRConstraint c) = cast c
class MkSolverGuard g g' where
toSolverGuard :: g' -> g
fromSolverGuard :: g -> Maybe g'
instance MkSolverGuard g g where
toSolverGuard = id
fromSolverGuard = Just
instance
( IsCHRGuard e g s
, ExtrValVarKey (CHRGuard e s) ~ ExtrValVarKey g
) => MkSolverGuard (CHRGuard e s) g where
toSolverGuard = CHRGuard
fromSolverGuard (CHRGuard g) = cast g
class MkSolverPrio p p' where
toSolverPrio :: p' -> p
fromSolverPrio :: p -> Maybe p'
instance MkSolverPrio p p where
toSolverPrio = id
fromSolverPrio = Just
instance
( IsCHRPrio e p s
) => MkSolverPrio (CHRPrio e s) p where
toSolverPrio = CHRPrio
fromSolverPrio (CHRPrio p) = cast p
class MkRule r where
type SolverConstraint r :: *
type SolverGuard r :: *
type SolverPrio r :: *
mkRule :: [SolverConstraint r] -> Int -> [SolverGuard r] -> [SolverConstraint r] -> Maybe (SolverPrio r) -> r
guardRule :: [SolverGuard r] -> r -> r
prioritizeRule :: SolverPrio r -> r -> r
instance MkRule (Rule c g p) where
type SolverConstraint (Rule c g p) = c
type SolverGuard (Rule c g p) = g
type SolverPrio (Rule c g p) = p
mkRule = Rule
guardRule g r = r {ruleGuard = ruleGuard r ++ g}
prioritizeRule p r = r {rulePrio = Just p}
instance MkRule (CHRRule e s) where
type SolverConstraint (CHRRule e s) = (CHRConstraint e s)
type SolverGuard (CHRRule e s) = (CHRGuard e s)
type SolverPrio (CHRRule e s) = ()
mkRule h1 h2 l b p = CHRRule $ mkRule h1 h2 l b p
guardRule g (CHRRule r) = CHRRule $ guardRule g r
prioritizeRule p (CHRRule r) = CHRRule $ prioritizeRule p r
infix 1 <==>, ==>
infixr 0 |>
(<==>), (==>) :: forall r c1 c2 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2) => [c1] -> [c2] -> r
hs <==> bs = mkRule (map toSolverConstraint hs) (length hs) [] (map toSolverConstraint bs) Nothing
hs ==> bs = mkRule (map toSolverConstraint hs) 0 [] (map toSolverConstraint bs) Nothing
(|>) :: (MkRule r, MkSolverGuard (SolverGuard r) g') => r -> [g'] -> r
r |> g = guardRule (map toSolverGuard g) r
instance (Serialize c,Serialize g,Serialize p) => Serialize (Rule c g p) where
sput (Rule a b c d e) = sput a >> sput b >> sput c >> sput d >> sput e
sget = liftM5 Rule sget sget sget sget sget