Expr.hs

module Calculator.Parser.Expr (parseExpr) where

--------------------------------------------------------------------------------

import           Calculator.Parser.Base        (parseId, parseNumber)
import           Calculator.Prim.Definitions   (binaryOps, unaryOps)
import           Calculator.Prim.Expr          (Expr (..), Operator, constEq)

--------------------------------------------------------------------------------

import           Control.Applicative           ((<$>), (<*))
import           Data.Maybe                    (isNothing)
import           Text.ParserCombinators.Parsec

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

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

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

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

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

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

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

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

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

--------------------------------------------------------------------------------
-- Unary operators
-- val  -> $? val'

parseVal :: Parser Expr
parseVal = do
  ch <- optionMaybe $ oneOf (map fst unaryOps) <* spaces
  v  <- parseVal'
  return $ if isNothing ch
           then v
           else let Just c  = ch
                    Just op = lookup c unaryOps
                in UnOp op v

--------------------------------------------------------------------------------
-- val' -> ( expr ) | func ( expr ) | var | number

parseVal' :: Parser Expr
parseVal' = parseBrackets <|> parseCall <|> parseVariable <|> parseConstant

parseBrackets :: Parser Expr
parseBrackets = do
  _ <- try (spaces >> char '(')
  e <- parseExpr
  _ <- spaces
  _ <- char ')'
  return e

parseVariable :: Parser Expr
parseVariable = Variable <$> parseId

parseConstant :: Parser Expr
parseConstant = Constant <$> parseNumber

parseCall :: Parser Expr
parseCall = do
  ident <- try (parseId <* (spaces >> char '(' >> spaces))
  args  <- parseExpr `sepBy` (char ',' <* spaces) <* (spaces >> char ')')
  return $ Call ident args

--------------------------------------------------------------------------------