6
\$\begingroup\$

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"
\$\endgroup\$
0
2
\$\begingroup\$

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
\$\endgroup\$
2
  • \$\begingroup\$ Interesting job on evalExp. Any thoughts on the data structure? Why the bit with type Exp = Fix ExpF? \$\endgroup\$ – Teodor Apr 3 '16 at 20:13
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ – Teodor Apr 3 '16 at 20:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.