Data structure for expression evaluation in Haskell

Question

I've made a data structure for mathematical expressions. I want to parse mathematical expressions like:

• \$x = 3\$
• \$y = 4\$
• \$z = x + y :\$

into an evaluated document like:

• \$x = 3\$
• \$y = 4\$
• \$z = x + y : 7\$

where \$=\$ is assignment and \$:\$ is evaluation.

The data structure must handle errors:

• Invalid input like multiple equals signs
• Invalid expressions like referencing an undefined variable

Smells and comments

Haskell is fantastic for this, but I'm still struggling with algebraic data structures; I'm used to object-oriented design. Because of this, I'd like some feedback!

Smells:

• Structure for output document relates arbitrarily on structure for input documents
• Picking type vs data seems random
• Should I be using records?
• I struggle with finding good names
• evalExp contains much repetition
• Comments on my style in general?
• I suspect that I'm evaluating nested expressions multiple times. Thoughts on how to fix this?

Data structure

The data structure itself is most important. I've included code for serialization and evaluation for reference. These are less important, but I'm thankful for comments on those as well!

module Document where
import Text.Printf(printf)
import Data.List(intercalate)
import qualified Data.Map.Strict as M
-- Source data
data Exp = Num Double
 | Add Exp Exp
 | Sub Exp Exp
 | Mult Exp Exp
 | Div Exp Exp
 | Neg Exp
 | Ref Name
 | Call Name [Exp]
 deriving (Show)
type Name = String
type Evaluation = Bool
data Statement = Statement (Maybe Name) Exp Evaluation | Informative String
 deriving (Show)
data Document = Document [Statement]
 deriving (Show)
instance Monoid Document where
 mempty = Document []
 (Document a) `mappend` (Document b) = Document (a `mappend` b)
-- Result data
type EvalError = String
type EvalRes = Either EvalError Double
data StatementResult = StatementResult Statement EvalRes | JustInformative String
 deriving (Show)
type DocumentResult = [StatementResult]
data EvalState = Success Double -- Value found
 | InProgress -- For terminating cyclic dependencies
 | Error EvalError -- Unable to evaluate
type NameExpressions = M.Map Name Exp
type NameValues = M.Map Name EvalState
-- Serialization
class Serialize a where
 serialize :: a -> String
instance Serialize Exp where
 serialize (Num d) = show d
 serialize (Add x y) = printf "(%s + %s)" (serialize x) (serialize y)
 serialize (Sub x y) = printf "(%s - %s)" (serialize x) (serialize y)
 serialize (Neg x) = "-" ++ serialize x
 serialize (Mult x y) = printf "%s * %s" (serialize x) (serialize y)
 serialize (Div x y) = printf "%s / %s" (serialize x) (serialize y)
 serialize (Ref name) = name
 serialize (Call name exps) = printf "%s(%s)" name (intercalate ", " $ map serialize exps)
instance Serialize Statement where
 serialize (Statement mn exp eval) = prefix mn ++ serialize exp ++ postfix eval
 where prefix (Just n) = n ++ " = "
 prefix Nothing = ""
 postfix True = ":"
 postfix False = ""
 serialize (Informative s) = s
instance Serialize Document where
 serialize (Document ls) = unlines . map serialize $ ls
instance Serialize StatementResult where
 serialize (StatementResult statement evalRes) = serialize statement ++ " = " ++ serializedEval evalRes
 where serializedEval (Left err) = err
 serializedEval (Right d) = show d
 serialize (JustInformative s) = s
serializeResult :: DocumentResult -> String
serializeResult = unlines . map serialize

Evaluation

module Evaluator where
import Document
import qualified Data.Map.Strict as M
import Control.Monad(liftM2, liftM)
getNameExpressions :: Document -> NameExpressions
getNameExpressions (Document statements) =
 let toKVPair (Statement (Just n) exp _) = [(n, exp)]
 toKVPair _ = []
 in M.fromList $ statements >>= toKVPair
evalDocument :: Document -> DocumentResult
evalDocument doc@(Document statements) = map (evalStatement nameMap) statements
 where nameMap = getNameExpressions doc
evalStatement :: NameExpressions -> Statement -> StatementResult
evalStatement nameMap s@(Statement _ exp _) = StatementResult s $ evalExp nameMap exp
evalStatement _ (Informative s) = JustInformative s
-- Expression interpretation without caching
evalExp :: NameExpressions -> Exp -> EvalRes
evalExp d (Num n) = Right n
evalExp d (Add x y) = liftM2 (+) (evalExp d x) (evalExp d y)
evalExp d (Sub x y) = liftM2 (-) (evalExp d x) (evalExp d y)
evalExp d (Mult x y) = liftM2 (*) (evalExp d x) (evalExp d y)
evalExp d (Div x y) = liftM2 (/) (evalExp d x) (evalExp d y)
evalExp d (Call "sin" (arg1:_)) = liftM sin (evalExp d arg1)
evalExp d (Call "cos" (arg1:_)) = liftM cos (evalExp d arg1)
evalExp d (Call "tan" (arg1:_)) = liftM tan (evalExp d arg1)
evalExp d (Call "asin" (arg1:_)) = liftM asin (evalExp d arg1)
evalExp d (Call "acos" (arg1:_)) = liftM acos (evalExp d arg1)
evalExp d (Call "atan" (arg1:_)) = liftM atan (evalExp d arg1)
evalExp d (Call "sinh" (arg1:_)) = liftM sinh (evalExp d arg1)
evalExp d (Call "cosh" (arg1:_)) = liftM cosh (evalExp d arg1)
evalExp d (Call "tanh" (arg1:_)) = liftM tanh (evalExp d arg1)
evalExp d (Call "asinh" (arg1:_)) = liftM asinh (evalExp d arg1)
evalExp d (Call "acosh" (arg1:_)) = liftM acosh (evalExp d arg1)
evalExp d (Call "atanh" (arg1:_)) = liftM atanh (evalExp d arg1)
evalExp d (Call "log" (arg1:_)) = liftM log (evalExp d arg1)
evalExp d (Call "exp" (arg1:_)) = liftM exp (evalExp d arg1)
evalExp d (Call "abs" (arg1:_)) = liftM abs (evalExp d arg1)
evalExp d (Call "sqrt" (arg1:_)) = liftM sqrt (evalExp d arg1)
evalExp d (Call "pow" (arg1:arg2:_)) = liftM2 (**) (evalExp d arg1) (evalExp d arg2)
evalExp d (Neg x) = liftM negate (evalExp d x)
evalExp d (Ref name) = case M.lookup name d of
 Just exp -> evalExp d exp
 Nothing -> Left $ "No match for name: " ++ name
evalExp _ _ = Left "Not implemented"

Answer 1

Data.Functor.Foldable can take some boilerplate out of your code. Also I tried to make the recursion in evalExp's references as tight-looped as possible.

import Data.Functor.Foldable
-- Source data
data ExpF t
 = Num Double
 | Add t t
 | Sub t t
 | Mult t t
 | Div t t
 | Neg t
 | Ref Name
 | Call Name [t]
 deriving (Show, Functor, Foldable, Traversable)
type Exp = Fix ExpF
instance Serialize Exp where
 serialize = cata $ \case
 Num d -> show d
 Add x y -> printf "(%s + %s)" x y
 Sub x y -> printf "(%s - %s)" x y
 Neg x -> "-" ++ x
 Mult x y -> printf "%s * %s" x y
 Div x y -> printf "%s / %s" x y
 Ref name -> name
 Call name exps -> printf "%s(%s)" name (intercalate ", " exps)
evalExp :: NameExpressions -> Exp -> EvalRes
evalExp d = evalExp' d' where
 d' = evalExp' d' <$> d
 evalExp' d' = cata $ sequenceA >=> \case
 Ref name -> fromMaybe
 (Left $ "No match for name: " ++ name)
 (M.lookup name d')
 x -> first (const "Not implemented") $ do Right $ case x of
 Num n -> n
 Add x y -> x + y
 Sub x y -> x - y
 Mult x y -> x * y
 Div x y -> x / y
 Call "sin" (arg1:_) -> sin arg1
 Call "cos" (arg1:_) -> cos arg1
 Call "tan" (arg1:_) -> tan arg1
 Call "asin" (arg1:_) -> asin arg1
 Call "acos" (arg1:_) -> acos arg1
 Call "atan" (arg1:_) -> atan arg1
 Call "sinh" (arg1:_) -> sinh arg1
 Call "cosh" (arg1:_) -> cosh arg1
 Call "tanh" (arg1:_) -> tanh arg1
 Call "asinh" (arg1:_) -> asinh arg1
 Call "acosh" (arg1:_) -> acosh arg1
 Call "atanh" (arg1:_) -> atanh arg1
 Call "log" (arg1:_) -> log arg1
 Call "exp" (arg1:_) -> exp arg1
 Call "abs" (arg1:_) -> abs arg1
 Call "sqrt" (arg1:_) -> sqrt arg1
 Call "pow" (arg1:arg2:_)) -> arg1 ** arg2
 Neg x -> negate x

• Teodor: Interesting job on evalExp. Any thoughts on the data structure? Why the bit with type Exp = Fix ExpF?
• Teodor: I was hoping for comments on how I've built the data structure or possible alternatives representing the same concept. Simply inserting the input data structure into the output data structure seems weird. If I don't get any comments on this, I'll accept your answer.