Polymorphism scenario in Haskell

Question

I have written the following Haskell program to interpret basic math. I would like to add comparison and boolean operators in addition to mathematical operators. My question is how I should go about replacing the occurrences of Int with something that can handle either Int or Bool .

I considered expanding the Token type to have three types of operators, which would differ only in the type of the function ( (Int -> Int -> Int) , (Int -> Int -> Bool) , and (Bool -> Bool -> Bool) , but this seems like it would result in quite a bit of duplication, both in the type declaration, and in the pattern matching. Is there a way to do this with a type class?

type Precedence = Int
data Associativity = AssocL | AssocR
data Token = Operand Int | Operator String (Int -> Int -> Int) Associativity Precedence | ParenL | ParenR

instance Eq Token where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

evalMath :: String -> Int
evalMath = rpn . shuntingYard . tokenize

tokenize :: String -> [Token]
tokenize = map token . words
  where token s@"+" = Operator s (+) AssocL 2
        token s@"-" = Operator s (-) AssocL 2
        token s@"*" = Operator s (*) AssocL 3
        token s@"/" = Operator s div AssocL 3
        token s@"^" = Operator s (^) AssocR 4
        token "("   = ParenL
        token ")"   = ParenR
        token x     = Operand $ read x

shuntingYard :: [Token] -> [Token]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token] -> Int
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs

Answer 1

It's definitely an advanced technique, but you can use typeclasses and GADTs to lift ad hoc polymorphism to your DSL, and get a typed token as result (ie you can't construct type-incorrect tokens).

{-# LANGUAGE GADTs #-}

(.<) :: IsScalar a => Token ((a, a) -> Bool)
(.<) = Operator (Lt scalarType)

(.+) :: IsNum a => Token ((a, a) -> a)
(.+) = Operator (Add numType)

(.==) :: IsScalar a => Token ((a, a) -> Bool)
(.==) = Operator (Eq scalarType)


lit7  :: Token Int
lit7  =  Operand 7

data Token a where
    Operand  :: (IsScalar a, Show a) => a -> Token a
    Operator :: Fun (a -> r) -> Token (a -> r)
    ParenL   :: Token ()
    ParenR   :: Token ()

-- The types of primitive functions
data Fun s where
    Lt   :: ScalarType a -> Fun ((a, a) -> Bool)
    Gt   :: ScalarType a -> Fun ((a, a) -> Bool)

    Eq   :: ScalarType a -> Fun ((a, a) -> Bool)
    NEq  :: ScalarType a -> Fun ((a, a) -> Bool)

    Add  :: NumType a -> Fun ((a, a) -> a)
    Mul  :: NumType a -> Fun ((a, a) -> a)

and now all the lifting gunk for type classes:

-- Polymorphism. Use dictionaries in Haskell, in the DSL.

class IsScalar a where
  scalarType    :: ScalarType a

class (Num a, IsScalar a) => IsNum a where
  numType       :: NumType a

class (IsScalar a, IsNum a) => IsIntegral a where
  integralType  :: IntegralType a

instance IsIntegral Int where
  integralType = TypeInt IntegralDict

instance IsNum Int where
  numType = IntegralNumType integralType

instance IsScalar Int where
  scalarType = NumScalarType numType

data ScalarType a where
  NumScalarType    :: NumType a    -> ScalarType a
  NonNumScalarType :: NonNumType a -> ScalarType a

data NumType a where
  IntegralNumType :: IntegralType a -> NumType a

data IntegralType a where
  TypeInt     :: IntegralDict Int     -> IntegralType Int

data NonNumType a where
  TypeBool    :: NonNumDict Bool      -> NonNumType Bool

-- Reified dictionaries: lift our dictionaries to the DSL
data IntegralDict a where
  IntegralDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a
                  , Integral a, Num a, Real a)
               => IntegralDict a

data NonNumDict a where
  NonNumDict :: (Eq a, Ord a, Show a)
             => NonNumDict a

This idea is from the UNSW accelerate library.

Answer 2

You can make the actual function a separate type.

data Fcn = III (Int -> Int -> Int) | IIB (Int -> Int -> Bool) | BBB (Bool -> Bool -> Bool)
data Token = ... | Operator String Fcn Associativity Precedence | ...

This will give less code duplication, but you will have to pattern match on the Fcn constructor to perform the arithmetic.

Answer 3

This ended up being far simpler than I thought. Both of the answers I received helped, but neither pointed me directly to the solution. The GADT thing is overkill for what I was trying to do.

All you really need to do in this kind of situation is to wrap the operand in an option type and make a simple way to lift your functions to operate on that type. By making the Token type parameterized by the operand type ( Result below) I was able to generalize the algorithm quite pleasingly.

import ShuntingYard

data Result = I Int | B Bool deriving (Eq)

instance Show Result where
  show (I x) = show x
  show (B x) = show x

evalMath :: String -> Result
evalMath = rpn . shuntingYard . tokenize

liftIII f (I x) (I y) = I $ f x y
liftIIB f (I x) (I y) = B $ f x y
liftBBB f (B x) (B y) = B $ f x y

tokenize :: String -> [Token Result]
tokenize = map token . words
  where token s@"&&" = Operator s (liftBBB (&&)) AssocL 0
        token s@"||" = Operator s (liftBBB (||)) AssocL 0
        token s@"="  = Operator s (liftIIB (==)) AssocL 1
        token s@"!=" = Operator s (liftIIB (/=)) AssocL 1
        token s@">"  = Operator s (liftIIB (<))  AssocL 1
        token s@"<"  = Operator s (liftIIB (>))  AssocL 1
        token s@"<=" = Operator s (liftIIB (>=)) AssocL 1
        token s@">=" = Operator s (liftIIB (<=)) AssocL 1
        token s@"+"  = Operator s (liftIII (+))  AssocL 2
        token s@"-"  = Operator s (liftIII (-))  AssocL 2
        token s@"*"  = Operator s (liftIII (*))  AssocL 3
        token s@"/"  = Operator s (liftIII div)  AssocL 3
        token s@"^"  = Operator s (liftIII (^))  AssocR 4
        token "("    = ParenL
        token ")"    = ParenR
        token "f"    = Operand $ B False
        token "t"    = Operand $ B True
        token x      = Operand $ I $ read x

Where the ShuntingYard module is defined as:

module ShuntingYard ( Associativity(AssocL, AssocR)
                    , Token(Operand, Operator, ParenL, ParenR)
                    , shuntingYard
                    , rpn) where 

type Precedence = Int
data Associativity = AssocL | AssocR
data Token a = Operand a | Operator String (a -> a -> a) Associativity Precedence | ParenL | ParenR

instance (Show a) => Show (Token a) where
  show (Operator s _ _ _) = s
  show (Operand x)        = show x
  show ParenL             = "("
  show ParenR             = ")"

instance (Eq a) => Eq (Token a) where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

shuntingYard :: (Eq a) => [Token a] -> [Token a]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token a] -> a
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs