Parser.hs

module Calculator.Parser (parseExpr) where

import           Calculator.Primitives

import           Control.Applicative           ((<$>))
import           Control.Monad                 (liftM2)
import           Text.ParserCombinators.Parsec

-- expr -> term ( "+-" term )*

parseExpr :: Parser Expr
parseExpr = do
  term <- parseTerm
  rest <- parseRestExpr
  if null rest
    then return term
    else return $ BinOp (term, rest)

parseRestExpr :: Parser [(Operator, Expr)]
parseRestExpr = many $ do
  oper <- oneOf "+-"
  let (Just op) = lookup oper binaryOps
  expr <- parseTerm
  return (op, expr)

-- term -> fact ( "*/" fact )*

parseTerm :: Parser Expr
parseTerm = do
  fact <- parseFact
  rest <- parseRestTerm
  if null rest
    then return fact
    else return $ BinOp (fact, rest)

parseRestTerm :: Parser [(Operator, Expr)]
parseRestTerm = many $ do
  oper <- oneOf "*/"
  let (Just op) = lookup oper binaryOps
  expr <- parseFact
  return (op, expr)

-- fact -> val ( "^" fact )?
-- Right recursion for right associativity

constEq :: Expr -> Expr -> Bool
constEq (Constant x) (Constant y) = x == y
constEq _ _ = False

parseFact :: Parser Expr
parseFact = do
  val <- parseVal
  pow <- parsePower
  if constEq (Constant 1) (snd pow)
    then return val
    else return $ BinOp (val, [pow])

parsePower :: Parser (Operator, Expr)
parsePower = let (Just op) = lookup '^' binaryOps
             in option (op, Constant 1) $ do
               _ <- char '^'
               fact <- parseFact
               return (op, fact)

-- val -> func? ( expr ) | number
-- Parentheses can be seen as function calls

parseVal :: Parser Expr
parseVal = parseFunction <|> parseNumber

parseFunction :: Parser Expr
parseFunction = do
  fname <- option "" (many letter)
  _ <- char '('
  e <- parseExpr
  _ <- char ')'
  return $ Function fname e

parseNumber :: Parser Expr
parseNumber = Constant . read <$> do
  dec <- many1 digit
  flt <- option "" (liftM2 (:) (char '.') (many1 digit))
  if null flt
    then return dec
    else return $ dec ++ flt