Expressions...

Expr.hs

{-# Language GADTs,
DataKinds,
KindSignatures,
StandaloneDeriving,
DeriveFunctor,
TypeFamilies
#-}

import Data.Function

data ExprType = Numeric | Boolean

data Expr (a :: ExprType) where
  NumLit :: Integer -> Expr Numeric
  BoolLit :: Bool -> Expr Boolean
  Add :: Expr Numeric -> Expr Numeric -> Expr Numeric
  Mul :: Expr Numeric -> Expr Numeric -> Expr Numeric
  Eq :: Expr a -> Expr a -> Expr Boolean
  And :: Expr Boolean -> Expr Boolean -> Expr Boolean

data ExprF (a :: ExprType) e where
  NumLitF :: Integer -> ExprF Numeric e
  BoolLitF :: Bool -> ExprF Boolean e
  AddF :: e -> e -> ExprF Numeric e
  MulF :: e -> e -> ExprF Numeric e
  EqF :: e -> e -> ExprF Boolean e
  AndF :: e -> e -> ExprF Boolean e

deriving instance Show e => Show (ExprF a e)
deriving instance Functor (ExprF a)

type family Res t where
  Res Numeric = Integer
  Res Boolean = Bool

onEval :: (Res a -> Res a -> c) -> Expr a -> Expr a -> c
onEval f = f `on` eval

normalize :: Expr a -> Expr a
normalize (Add x y) = NumLit $ onEval (+) x y
normalize (Mul x y) = NumLit $ onEval (*) x y
normalize (Eq x y) = BoolLit $
  case (normalize x, normalize y) of
    (NumLit a, NumLit b) -> a == b
    (BoolLit a, BoolLit b) -> a == b
normalize (And x y) = BoolLit $ onEval (&&) x y
normalize x = x

evalNorm :: Expr a -> Res a
evalNorm (NumLit x) = x
evalNorm (BoolLit x) = x

eval :: Expr a -> Res a
eval = evalNorm . normalize

main = print $  eval
       (And
         (Eq
           (NumLit 2)
           (Add
             (NumLit 1)
             (NumLit 1)))
         (BoolLit True))