--------------------------------------------------------------------------------
--                                                                            --
-- interpreter building block for boolean expressions                         --
--                                                                            --
--------------------------------------------------------------------------------

-- B

data B x = x `Equ` x
         | x `Neq` x
         | Cond x x x
           
instance Functor B where
  map g (x `Equ` y) = g x `Equ` g y
  map g (x `Neq` y) = g x `Neq` g y
  map g (Cond x y z) = Cond (g x) (g y) (g z)
 
-- parse

instance Parser m x => Parser m (B x) where
  parser =   pEqu parser' 
          ++ pNeq parser'
          ++ pCond parser' 
   where 
    parser' = parser :: Parser m x => m x

    pEqu parser 
      = do { pLit "(" ; x <- parser ; pLit "==" ; y <- parser ; pLit ")" ;
             result (x `Equ` y) }
    pNeq parser 
      = do { pLit "(" ; x <- parser ; pLit "/=";  y <- parser ; pLit ")" ;
             result (x `Neq` y) }
    pCond parser 
      = do { pLit "IF" ; w <- parser ; 
             pLit "THEN" ; x <- parser ; pLit "ELSE" ; y <- parser ; 
             result (Cond w x y) } 

-- unparse

instance Algebra B (IO ()) where
  phi (x `Equ` y)    
    = do { uLit "(" ; x ; uLit "==" ; y  ; uLit ")" }
  phi (x `Neq` y)    
    = do { uLit "(" ; x ; uLit "/=" ; y  ; uLit ")" }
  phi (Cond w x y) 
    = do { uLit "IF " ; w ; uLit " THEN " ; x ; uLit " ELSE " ; y }
   
-- interpret

instance (Monad m, SubType Int v, SubType Bool v) 
        => Algebra B (m v) where
  phi (mx `Equ` my) 
    = do { x <- mx ; y <- my ;
           resultInj (prj x `equ` prj y) }
     where
      equ = (==) :: Int -> Int -> Bool
  phi (mx `Neq` my) 
    = do { x <- mx ; y <- my ;
           resultInj (prj x `neq` prj y) }
     where
      neq = (/=) :: Int -> Int -> Bool  
  phi (Cond mb mx my) 
    = do { b <- mb ; 
           if prj b then mx else my } 

--------------------------------------------------------------------------------




