haskell_rule_evaluator

haskell_rule_evaluator.hs

data BBool a b = BTrue a | BFalse b deriving (Show)

true :: a -> BBool a b
true a = BTrue a

trueMap :: (a -> b) -> BBool a c -> BBool b c
trueMap f (BTrue x) = BTrue (f x)
trueMap _ (BFalse x) = BFalse x

falseMap :: (a -> b) -> BBool c a -> BBool c b
falseMap f (BFalse x) = BFalse (f x)
falseMap _ (BTrue x) = BTrue x

type Rule = BBool () String

data RuleExpression =
   RuleOr RuleExpression RuleExpression
   | RuleAnd RuleExpression RuleExpression
   | RuleT Rule

-- rule1 || rule2
evalRuleExpression :: RuleExpression -> Rule
evalRuleExpression (RuleT r) = r
evalRuleExpression (RuleOr re1 re2) =
  let
  evalOr :: Rule -> Rule -> Rule
  evalOr (BTrue _) _ = BTrue ()  -- le cas de droite est il evalue ?
  evalOr _ (BTrue _) = BTrue ()
  evalOr (BFalse s1) (BFalse s2) = BFalse (s2)
  in
    evalOr (evalRuleExpression re1) (evalRuleExpression re2)
evalRuleExpression (RuleAnd re1 re2) =
  let
    evalAnd :: Rule -> Rule -> Rule
    evalAnd (BFalse s) _ = BFalse s
    evalAnd _ (BFalse s) = BFalse s
    evalAnd (BTrue _) (BTrue _) = BTrue ()
  in
    evalAnd (evalRuleExpression re1) (evalRuleExpression re2)

rule1 :: Rule
rule1 = BTrue ()

rule2 :: Rule
rule2 = BFalse "gwaa"

(&&&) = RuleAnd
(|||) = RuleOr

ruleEngine1 :: RuleExpression
ruleEngine1 = (RuleT rule1) &&& (RuleT rule2)

ruleEngine2 :: RuleExpression
ruleEngine2 = (RuleT rule1) ||| (RuleT rule2)

ruleEngine =
  (ruleEngine1 &&& ruleEngine2) |||
  ruleEngine2

main :: IO ()
main = do
  putStrLn $ show (evalRuleExpression (ruleEngine1 ||| ruleEngine2))

Reste à faire:

1. Rule doit être générique => supprimer Rule
2. rajouter un type Wrapper sur Rule pour evalRuleExpression qui instancie Monade
3. vérifier que le cas evalOr (BTrue _) _ n'évalue pas le membre de droite