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 (..),NamedReference(..),CompileReason(..))
import qualified Model.CellContent as CC
import I18n (__)

program,topLevelFormula,topLevelLiteral :: Parser CellExpr
expression,term,functionCall :: Parser CellExpr
number,stringExpr,list,subExpression :: Parser CellExpr
reference,cellRef,cellRangeRef :: Parser CellExpr

program = topLevelFormula <|> topLevelLiteral

topLevelLiteral = (try topLevelNumber) 
                  <|> (StringExpr <$> (P.many1 P.anyChar))

topLevelNumber = do
  whitespace
  n <- NumberExpr <$> signedDouble
  P.eof >> return n

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]
        ]          
    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 <|> functionCall <|> number <|> list 
       <|> stringExpr <|> reference <?> __ "formula"

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

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

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

list = do { symbol "["
          ; l <- P.sepBy1 expression $ symbol ","
          ; symbol "]"
          ; return $ ListExpr l
          } <?> "list"

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

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

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

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

lexer :: T.TokenParser ()
lexer = T.makeTokenParser $ L.emptyDef 
        { L.opStart  = P.oneOf "+-*/~^:"
        , L.opLetter = P.oneOf "+-*/~^:"
        , L.reservedOpNames = ["+","-","*","/","~","^",":"]
        , L.reservedNames = []}

double :: Parser Double
double = do
  f <- T.naturalOrFloat lexer
  case f of 
    Left i -> return $ realToFrac i
    Right d -> return d

signedDouble :: Parser Double
signedDouble = 
    let signed = do symbol "-"
                    ((*) (-1)) <$> double
    in
      P.choice [signed,double]

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