hpaco-lib-0.18.0.0: Text/HPaco/Readers/Paco/Expressions.hs

module Text.HPaco.Readers.Paco.Expressions
    ( expression
    )
where

import Control.Monad
import Text.HPaco.Readers.Common
import Text.HPaco.AST.Expression

expression = booleanExpression

booleanExpression =
    binaryExpression
        [("&&", OpBooleanAnd),
         ("||", OpBooleanOr),
         ("^^", OpBooleanXor)]
        setOperationExpression

setOperationExpression =
    binaryExpression
        [("in", OpInList),
         ("contains", Flipped OpInList)]
        comparativeExpression

comparativeExpression =
    binaryExpression
        [("==", OpEquals),
         ("!==", OpNotEquals),
         ("=", OpLooseEquals),
         ("!=", OpLooseNotEquals),
         (">=", OpNotLess),
         (">", OpGreater),
         ("<=", OpNotGreater),
         ("<", OpLess)]
        additiveExpression

additiveExpression =
    binaryExpression
        [("+", OpPlus), ("-", OpMinus)]
        multiplicativeExpression

multiplicativeExpression =
    binaryExpression
        [("*", OpMul), ("/", OpDiv), ("%", OpMod)]
        (try traditionalFunctionCallExpression <|> postfixExpression)

binaryExpression :: [(String, BinaryOperator)] -> Parser s Expression -> Parser s Expression
binaryExpression opMap innerParser = do
    let rem = do
            ss_
            opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
            ss_
            let Just op = lookup opStr opMap
            e <- innerParser
            return (op, e)
    left <- innerParser
    right <- many $ try rem
    return $ foldl combine left right
    where
        combine :: Expression -> (BinaryOperator, Expression) -> Expression
        combine lhs (op, rhs) = BinaryExpression op lhs rhs

traditionalFunctionCallExpression = do
    char '$'
    args <- manySepBy (try expression) ss_
    return $ FunctionCallExpression (head args) (tail args)

postfixExpression = do
    left <- (try prefixExpression <|> simpleExpression)
    postfixes <- many postfix
    return $ foldl combine left postfixes
    where
        combine :: Expression -> (Expression -> Expression) -> Expression
        combine l f = f l

prefixExpression = do
    ss_
    operator <- unaryOperator
    ss_
    expr <- (try prefixExpression <|> simpleExpression)
    return $ UnaryExpression operator expr

unaryOperator = do
    let opMap = [("not", OpNot)]
    opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
    let Just op = lookup opStr opMap
    return op
    
postfix = try memberAccessPostfix
        <|> try indexPostfix
        <|> try functionCallPostfix

memberAccessPostfix :: Parser s (Expression -> Expression)
memberAccessPostfix = do
    char '.'
    expr <- StringLiteral `liftM` identifier
    return $ \l -> BinaryExpression OpMember l expr

indexPostfix :: Parser s (Expression -> Expression)
indexPostfix = do
    ss_
    char '['
    e <- expression
    char ']'
    ss_
    return $ \l -> BinaryExpression OpMember l e

functionCallPostfix :: Parser s (Expression -> Expression)
functionCallPostfix = do
    char '('
    args <- manySepBy (try expression) (try $ ss_ >> char ',' >> ss_)
    ss_
    char ')'
    return $ \l -> FunctionCallExpression l args

simpleExpression :: Parser s Expression
simpleExpression  =  floatLiteral
                 <|> intLiteral
                 <|> stringLiteral
                 <|> listExpression
                 <|> alistExpression
                 <|> varRefExpr
                 <|> bracedExpression

bracedExpression :: Parser s Expression
bracedExpression = do
    char '('
    ss_
    inner <- expression
    ss_
    char ')'
    return inner

listExpression :: Parser s Expression
listExpression = do
    char '['
    ss_
    items <- manySepBy expression (ss_ >> char ',' >> ss_)
    ss_
    optional $ char ',' >> ss_
    char ']'
    return $ ListExpression items

alistExpression :: Parser s Expression
alistExpression = do
    char '{'
    ss_
    items <- option [] $ try $ manySepBy elem $ char ','
    ss_
    optional $ char ',' >> ss_
    char '}'
    return $ AListExpression items
    where
        elem :: Parser s (Expression, Expression)
        elem = do
            ss_
            key <- expression
            ss_ >> char ':' >> ss_
            value <- expression
            ss_
            return (key, value)

intLiteral :: Parser s Expression
intLiteral = do
    sign <- option '+' $ oneOf "+-"
    str <- many1 digit
    let str' = if sign == '-' then sign:str else str
    return . IntLiteral . read $ str'

floatLiteral :: Parser s Expression
floatLiteral = do
    str <- (try dpd <|> try pd)
    return . FloatLiteral . read $ str
    where
        dpd = do
            sign <- option '+' $ oneOf "+-"
            intpart <- many1 digit
            char '.'
            fracpart <- many digit
            let str = intpart ++ "." ++ fracpart
            return $ if sign == '-' then sign:str else str
        pd = do
            sign <- option '+' $ oneOf "+-"
            char '.'
            fracpart <- many1 digit
            let str = "0." ++ fracpart
            return $ if sign == '-' then sign:str else str

stringLiteral :: Parser s Expression
stringLiteral = do
    str <- anyQuotedString
    return . StringLiteral $ str

varRefExpr :: Parser s Expression
varRefExpr = do
    id <- (string "." <|> identifier)
    return $ VariableReference id