Parser.hs

module Model.CellExpression.Parser (parse)
    where

import Data.List (find,intercalate,nub)
import Control.Applicative ((<$>))
import Text.ParserCombinators.Parsec ((<|>),(<?>),Parser,try)
import qualified Text.ParserCombinators.Parsec as P
import qualified Text.ParserCombinators.Parsec.Error as Error
import qualified Text.ParserCombinators.Parsec.Expr as E
import qualified Text.ParserCombinators.Parsec.Token as T
import qualified Text.ParserCombinators.Parsec.Language as L
import Model.CellContent (CellExpr (..),CellReference(..)
                         ,NamedReference(..),CompileReason(..))
import qualified Model.CellContent as CC
import I18n (__)

program,topLevelFormula,topLevelLiteral :: Parser CellExpr
expression,term,functionCall,constant :: Parser CellExpr
number,stringExpr,subExpression :: Parser CellExpr
list,topLevelList :: Parser CellExpr
ifThenElse,reference,miscRef,cellRangeRef :: Parser CellExpr

program = topLevelFormula <|> topLevelLiteral

topLevelLiteral = (try (    topLevelParser number  
                        <|> topLevelList))
                  <|> (StringExpr <$> (P.many1 P.anyChar))

topLevelParser :: Parser CellExpr -> Parser CellExpr
topLevelParser parser = do
  result <- whitespace >> parser
  P.eof >> return result

topLevelFormula = do
  f <- P.char '=' >> whitespace >> expression
  P.eof >> return f

expression = E.buildExpressionParser table term <?> __ "formula"

table :: E.OperatorTable Char () CellExpr
table = [[ prefix "-" CC.UnaryOp]
        ,[ binary "^" CC.BinaryOp E.AssocRight]
        ,[ binary "*" CC.BinaryOp E.AssocLeft
         , binary "/" CC.BinaryOp E.AssocLeft]
        ,[ binary "+" CC.BinaryOp E.AssocLeft
         , binary "-" CC.BinaryOp E.AssocLeft]
        ,[ binary "==" CC.BinaryOp E.AssocLeft
         , binary "/=" CC.BinaryOp E.AssocLeft
         , binary ">" CC.BinaryOp E.AssocLeft
         , binary ">=" CC.BinaryOp E.AssocLeft
         , binary "<" CC.BinaryOp E.AssocLeft
         , binary "<=" CC.BinaryOp E.AssocLeft]
        ,[ binary "&&" CC.BinaryOp E.AssocLeft]
        ,[ binary "||" CC.BinaryOp E.AssocLeft]
        ]          
    where
      binary sign f = E.Infix $ do {reservedOp sign; return $ f sign}
      prefix sign f = E.Prefix $ do {reservedOp sign; return $ f sign}

term = subExpression <|> ifThenElse <|> try functionCall <|> constant 
       <|> number <|> list <|> stringExpr <|> reference <?> __ "formula"

functionCall = do { name <- identifier
                  ; arg <- number <|> stringExpr <|> list 
                           <|> reference <|> subExpression 
                           <|> constant <?> __ "argument"
                  ; return $ Call name arg
                  } <?> __ "function call"

constant = (Constant <$> identifier) <?> __ "constant"

number = (NumberExpr <$> signedDouble) <?> __ "number"

stringExpr = (StringExpr <$> stringLiteral) <?> __ "string"

listParser :: Parser CellExpr -> Parser CellExpr
listParser parser = 
    do { reservedOp "["
       ; l <- P.sepBy1 parser $ reservedOp ","
       ; reservedOp "]"
       ; return $ ListExpr l
       } <?> "list"

list = listParser expression
topLevelList = listParser $ constant <|> number

reference = try cellRangeRef <|> try miscRef <?> __ "reference"

miscRef = do { string "$"
             ; row <- P.many1 (P.noneOf [','])
             ; string ","
             ; column <- P.many1 (P.noneOf ['$'])
             ; string "$"
             ; whitespace
             ; return $ NamedReference $ 
                      case (row,column) of
                        ("_",c) -> NamedColumn c
                        (r,"_") -> NamedRow r
                        ("=",c) -> NamedCell $ SameRow c
                        (r,"=") -> NamedCell $ SameColumn r
                        _ -> NamedCell $ Named (row,column)
             } <?> __ "cell reference"

cellRangeRef = do { NamedReference (NamedCell from) <- miscRef
                  ; symbol ":"
                  ; NamedReference (NamedCell to) <- miscRef
                  ; return $ NamedReference $ NamedRange (from,to)
                  } <?> __ "cell range reference"

subExpression = do { subExpr <- P.between (symbol "(") (symbol ")") expression
                   ; return $ Sub subExpr
                   } <?> __ "subexpression"

ifThenElse = do { condition <- reserved "if" >> expression
                ; thenBranch <- reserved "then" >> expression
                ; elseBranch <- P.option EmptyExpr
                                $ reserved "else" >> expression
                ; return $ IfThenElse condition thenBranch elseBranch
                } <?> __ "if-then-else expression"

lexer :: T.TokenParser ()
lexer = 
    let def = L.emptyDef 
              { L.opStart  = P.oneOf "+-*/~^:[,]=<>&|"
              , L.opLetter = L.opStart def
              , L.reservedOpNames = ["+","-","*","/","~","^",":","[",",","]"
                                    ,"=","==","/=","<","<=",">",">=","&&","||"]
              , L.reservedNames = ["if","then","else"]}
    in
      T.makeTokenParser def

signedDouble :: Parser Double
signedDouble = 
    let double = do f <- T.naturalOrFloat lexer
                    case f of 
                      Left i -> return $ realToFrac i
                      Right d -> return d
        signed = symbol "-" >> ((*) (-1)) <$> double
    in
      P.choice [signed,double]

reserved :: String -> Parser ()
reserved = T.reserved lexer

reservedOp :: String -> Parser ()
reservedOp = T.reservedOp lexer

whitespace :: Parser ()
whitespace = T.whiteSpace lexer

symbol :: String -> Parser ()
symbol s = T.symbol lexer s >> return ()

identifier :: Parser String
identifier = T.identifier lexer

stringLiteral :: Parser String
stringLiteral = T.stringLiteral lexer

string :: String -> Parser ()
string s = P.string s >> return ()

parse :: String -> CellExpr
parse "" = EmptyExpr
parse input = 
    case (P.parse program "" input) of
      Left e -> CompileErrorExpr $ ParseError $ errorMessage e
      Right x  -> x

errorMessage :: Error.ParseError -> String
errorMessage parseError =
    let errors = Error.errorMessages parseError
        Just unexpected = find (\e -> case e of
                                        Error.SysUnExpect _ -> True
                                        Error.UnExpect _ -> True
                                        _ -> False) errors
        expected = filter (\e -> case e of 
                                   Error.Expect "" -> False
                                   Error.Expect _ -> True
                                   _ -> False
                          ) errors
        message e = 
            case e of
              Error.SysUnExpect "" -> __ "end of input"
              Error.SysUnExpect a -> a
              Error.UnExpect "" -> __ "end of input"
              Error.UnExpect a -> a
              a -> Error.messageString a

        unexpectedMessage = unwords [ (__ "unexpected") ++ ":"
                                    , message unexpected]
        expectedMessage = 
            case expected of
              [] -> ""
              _ -> (__ "expecting") ++ " " ++  
                   (intercalate " or " $ nub $ map message expected)
    in
      case expectedMessage of
        "" -> unexpectedMessage
        _ -> unexpectedMessage ++ ", " ++ expectedMessage
--      ++ "#####" ++ show parseError