CalculatorParser

module CalculatorParser
    (
        calculateExpression,
        parseExpression
    ) where

import Text.Parsec.String (Parser)
import Text.Parsec (parse)
import Text.Parsec.Language (emptyDef)
import Text.Parsec.Char (char, string)

import Control.Applicative ((<$>), (<*), many, (<$), (<|>))
import Control.Monad (void)

import qualified Text.Parsec.Expr as E
import qualified Text.Parsec.Token as P

data Expr = Num Double
          | Parens Expr
          | PrefixOp String (Double -> Double) Expr
          | BinaryOp String Expr (Double -> Double -> Double) Expr

instance Show Expr where
    show (Num d) = show d
    show (Parens e) = "( " ++ (show e) ++ " )"
    show (PrefixOp op _ e) = "( " ++ op ++ " " ++ (show e) ++ " )"
    show (BinaryOp op e1 _ e2) = "( " ++ (show e1) ++ " " ++ op ++ " " ++ (show e2) ++ " )"

calculateExpression :: Expr -> Double
calculateExpression ex = case ex of
    Num d -> d
    Parens e -> calculateExpression e
    PrefixOp n f e -> f (calculateExpression e)
    BinaryOp n e1 f e2 -> calculateExpression(e1) `f` calculateExpression(e2)

parseExpression :: String -> Either String Expr
parseExpression input = case (parse expr "" input) of
    Left err -> Left ("Failed to parse expression: " ++ input ++ "\n" ++ show err)
    Right expr -> Right expr

expr :: Parser Expr
expr = E.buildExpressionParser table term

table = [[prefix "-" negate, prefix "+" id]
        ,[prefix "sin" sin, prefix "cos" cos]
        ,[binary "^" (**) E.AssocLeft]
        ,[binary "*" (*) E.AssocLeft, binary "/" (/) E.AssocLeft]
        ,[binary "+" (+) E.AssocLeft, binary "-" (-) E.AssocLeft]
        ]
  where
    binary name fun assoc = E.Infix (mkBinOp fun name <$ symbol name) assoc
    prefix name fun = E.Prefix (PrefixOp name fun <$ symbol name)
    mkBinOp fun name a b = BinaryOp name a fun b

symbol :: String -> Parser String
symbol s = lexeme $ string s

lexeme :: Parser a -> Parser a
lexeme p = p <* whitespace

whitespace :: Parser ()
whitespace = void $ many $ char ' '

term :: Parser Expr
term = num <|> parens

num :: Parser Expr
num = Num <$> double

double :: Parser Double
double = do res <- P.naturalOrFloat lexer
            case res of
                Left n -> return $ fromInteger n
                Right f -> return f

parens :: Parser Expr
parens = Parens <$> (P.parens lexer expr)

lexer = P.makeTokenParser emptyDef