SO25311781.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module SO25311781 where
import Data.Generics.Uniplate.Direct

data Expression a where
    I :: Int -> Expression Int
    B :: Bool -> Expression Bool
    Add :: Expression Int  -> Expression Int  -> Expression Int
    Mul :: Expression Int  -> Expression Int  -> Expression Int
    Eq  :: Expression Int  -> Expression Int  -> Expression Bool
    And :: Expression Bool -> Expression Bool -> Expression Bool
    Or  :: Expression Bool -> Expression Bool -> Expression Bool
    If  :: Expression Bool -> Expression a    -> Expression a -> Expression a

instance Show a => Show (Expression a) where
  showsPrec p x =  showParen (p > 4) $ case x of
    (I i)       -> showString "I " . showsPrec 5 i
    (B b)       -> showString "B " . showsPrec 5 b
    (Add x y)   -> showString "Add " . showsPrec 5 x . showString " " . showsPrec 5 y
    (Mul x y)   -> showString "Mul " . showsPrec 5 x . showString " " . showsPrec 5 y
    (Eq  x y)   -> showString "Eq " . showsPrec 5 x . showString " " . showsPrec 5 y
    (And x y)   -> showString "And " . showsPrec 5 x . showString " " . showsPrec 5 y
    (Or  x y)   -> showString "Or " . showsPrec 5 x . showString " " . showsPrec 5 y
    (If  b x y) -> showString "If " . showsPrec 5 b . showString " " . showsPrec 5 x . showString " " . showsPrec 5 y

example1 :: Expression Int
example1 = If (I 0 `Eq` (I 0 `Add` I 0)) (I 1) (I 2)

example2 :: Expression Bool
example2 = If (I 0 `Eq` (I 0 `Add` I 0)) (B True) (B False)

step :: Expression a -> Expression a
step = \case
  Add (I x) (I y)   -> I $ x + y
  Mul (I x) (I y)   -> I $ x * y
  Eq (I x) (I y)    -> B $ x == y
  And (B x) (B y)   -> B $ x && y
  Or (B x) (B y)    -> B $ x || y
  If (B b) x y      -> if b then x else y
  z                 -> z

instance Uniplate (Expression Int) where
  uniplate (Add x y)  = plate Add |* x |* y
  uniplate (Mul x y)  = plate Mul |* x |* y
  uniplate (If b x y) = plate If |+ b |* x |* y
  uniplate x          = plate x

instance Uniplate (Expression Bool) where
  uniplate (Eq x y)   = plate Eq |+ x |+ y
  uniplate (And x y)  = plate And |* x |* y
  uniplate (Or x y)   = plate Or |* x |* y
  uniplate (If b x y) = plate If |* b |* x |* y
  uniplate x          = plate x

instance Uniplate (Expression a) => Biplate (Expression a) (Expression a) where
  biplate = plateSelf

instance Biplate (Expression Bool) (Expression Int) where
  biplate (Eq x y)   = plate Eq |+ x |+ y
  biplate (And x y)  = plate And |+ x |+ y
  biplate (Or x y)   = plate Or |+ x |+ y
  biplate (If b x y) = plate If |+ b |+ x |+ y
  biplate x          = plate x

instance Biplate (Expression Int) (Expression Bool) where
  biplate (Add x y)  = plate Add |+ x |+ y
  biplate (Mul x y)  = plate Mul |+ x |+ y
  biplate (If b x y) = plate If |* b |+ x |+ y
  biplate x          = plate x

evalInt :: Expression Int -> Expression Int
evalInt = transform step

evalIntBi :: Expression Bool -> Expression Bool
evalIntBi = transformBi (step :: Expression Int -> Expression Int)

evalBool :: Expression Bool -> Expression Bool
evalBool = transform step

evalBoolBi :: Expression Int -> Expression Int
evalBoolBi = transformBi (step :: Expression Bool -> Expression Bool)

type  WExp = Either (Expression Int) (Expression Bool)

instance Uniplate WExp where
  uniplate = \case
      Left (Add x y)    -> plate (i2 Left Add)  |* Left x  |* Left y
      Left (Mul x y)    -> plate (i2 Left Mul)  |* Left x  |* Left y
      Left (If b x y)   -> plate (bi2 Left If)  |* Right b |* Left x  |* Left y
      Right (Eq x y)    -> plate (i2 Right Eq)  |* Left x  |* Left y
      Right (And x y)   -> plate (b2 Right And) |* Right x |* Right y
      Right (Or x y)    -> plate (b2 Right Or)  |* Right x |* Right y
      Right (If b x y)  -> plate (b3 Right If)  |* Right b |* Right x |* Right y
      e                 -> plate e
    where i2 side op (Left x) (Left y) = side (op x y)
          i2 _ _ _ _ = error "type mismatch"
          b2 side op (Right x) (Right y) = side (op x y)
          b2 _ _ _ _ = error "type mismatch"
          bi2 side op (Right x) (Left y) (Left z) = side (op x y z)
          bi2 _ _ _ _ _ = error "type mismatch"
          b3 side op (Right x) (Right y) (Right z) = side (op x y z)
          b3 _ _ _ _ _ = error "type mismatch"
    
evalWExp :: WExp -> WExp
evalWExp = transform (either (Left . step) (Right . step))