-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

-- a parser for a numeric expression.
module Graphics.Implicit.ExtOpenScad.Parser.Expr(expr0) where

import Prelude (Char, Maybe(Nothing, Just), fmap, ($), (.), (>>), return, Bool(True, False), read, (++), (*), (**), (/), id, foldl, map, foldl1, unzip, tail, zipWith3)

-- the datatype representing the graininess of our world.
import Graphics.Implicit.Definitions (ℝ)

-- The parsec parsing library.
import Text.ParserCombinators.Parsec (GenParser, string, many1, digit, char, many, noneOf, sepBy, sepBy1, optionMaybe, try)

import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector) 

import Graphics.Implicit.ExtOpenScad.Parser.Util (variableSymb, (?:), (*<|>), genSpace, padString)

variable :: GenParser Char st Expr
variable = fmap Var variableSymb

literal :: GenParser Char st Expr
literal = ("literal" ?:) $
    "boolean" ?: do
        b  <-      (string "true"  >> return True )
              *<|> (string "false" >> return False)
        return . LitE $ OBool b
    -- FIXME: this is a hack, implement something like exprN to replace this?
    *<|> "number" ?: (
         do
            a <- many1 digit
            _ <- char 'e'
            b <- many1 digit
            return . LitE $ ONum (((read a) * (10 ** (read b))) :: ℝ)
        *<|>  do
            a <- many1 digit
            _ <- char '.'
            b <- many digit
            _ <- char 'e'
            c <- many1 digit
            return . LitE $ ONum ((read (a ++ "." ++ b) * (10 ** (read c))) :: ℝ)
        *<|>  do
            a <- many1 digit
            _ <- char '.'
            b <- many digit
            _ <- char 'e'
            _ <- char '+'
            c <- many1 digit
            return . LitE $ ONum ((read (a ++ "." ++ b) * (10 ** (read c))) :: ℝ)
        *<|>  do
            a <- many1 digit
            _ <- char '.'
            b <- many digit
            _ <- char 'e'
            _ <- char '-'
            c <- many1 digit
            return . LitE $ ONum ((read (a ++ "." ++ b) / (10 ** (read c))) :: ℝ)
        *<|>  do
            a <- many1 digit
            _ <- char 'e'
            _ <- char '-'
            b <- many1 digit
            return . LitE $ ONum (((read a) / (10 ** (read b))) :: ℝ)
        *<|>  do
            a <- many1 digit
            _ <- char '.'
            b <- many digit
            return . LitE $ ONum (read (a ++ "." ++ b) :: ℝ)
        *<|>  do
            a <- many1 digit
            return . LitE $ ONum (read a :: ℝ)
        )
     *<|> "string" ?: do
        _ <- string "\""
        strlit <-  many $ (string "\\\"" >> return '\"')
                     *<|> (string "\\n" >> return '\n')
                     *<|> (string "\\r" >> return '\r')
                     *<|> (string "\\t" >> return '\t')
                     *<|> (string "\\\\" >> return '\\')
                      -- FIXME: no \u unicode support?
                     *<|> noneOf "\"\n"
        _ <- string "\""
        return . LitE $ OString strlit

-- We represent the priority or 'fixity' of different types of expressions
-- by the ExprIdx argument, with A0 as the highest.

expr0 :: GenParser Char st Expr
expr0 = exprN A0

-- what state in the expression parser tree we are inside of.
data ExprIdx = A0 | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 | A9 | A10 | A11 | A12

exprN :: ExprIdx -> GenParser Char st Expr

exprN A12 =
         literal
    *<|> variable
    *<|> "bracketed expression" ?: do
        -- eg. ( 1 + 5 )
        _ <- string "("
        expr <- expr0
        _ <- string ")"
        return expr
    *<|> "vector/list" ?: (
        do
            -- eg. [ 3, a, a+1, b, a*b ]
            _ <- string "["
            exprs <- sepBy expr0 (char ',' )
            _ <- string "]"
            return $ ListE exprs
        *<|> do
            -- eg. ( 1,2,3 )
            _ <- string "("
            exprs <- sepBy expr0 (char ',' )
            _ <- string ")"
            return $ ListE exprs
        )
    *<|> "vector/list generator" ?: do
        -- eg.  [ a : 1 : a + 10 ]
        _ <- string "["
        exprs <- sepBy expr0 (char ':' )
        _ <- string "]"
        return $ collector "list_gen" exprs

exprN A11 =
    do
        obj <- exprN A12
        _ <- genSpace
        mods <- many1 (
            "function application" ?: do
                _ <- padString "("
                args <- sepBy expr0 (padString ",")
                _ <- padString ")"
                return $ \f -> f :$ args
            *<|> "list indexing" ?: do
                _ <- padString "["
                i <- expr0
                _ <- padString "]"
                return $ \l -> Var "index" :$ [l, i]
            *<|> "list splicing" ?: do
                _ <- padString "["
                start <- optionMaybe expr0
                _ <- padString ":"
                end   <- optionMaybe expr0
                _ <- padString "]"
                return $ case (start, end) of
                    (Nothing, Nothing) -> id
                    (Just s,  Nothing)  -> \l -> Var "splice" :$ [l, s, LitE OUndefined ]
                    (Nothing, Just e )  -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]
                    (Just s,  Just e )  -> \l -> Var "splice" :$ [l, s, e]
            )
        return $ foldl (\a b -> b a) obj mods
    *<|> exprN A12

-- match a leading (+) or (-) operator.
exprN A10 =
    "negation" ?: do
        _ <- padString "-"
        expr <- exprN A11
        return $ Var "negate" :$ [expr]
    *<|> do
        _ <- padString "+"
        exprN A11
    *<|> exprN A11

-- match power-of (^) operator.
exprN A9 =
    "exponentiation" ?: do
        a <- exprN A10
        _ <- padString "^"
        b <- exprN A9
        return $ Var "^" :$ [a,b]
    *<|> exprN A10

-- match sequences of multiplication and division.
exprN A8 =
    "multiplication/division" ?: do
        -- outer list is multiplication, inner division.
        -- eg. "1*2*3/4/5*6*7/8"
        --     [[1],[2],[3,4,5],[6],[7,8]]
        exprs <- sepBy1
            (sepBy1 (exprN A9) (try $ padString "/" ))
            (try $ padString "*" )
        let div' a b = Var "/" :$ [a, b]
        return . collector "*" $ map (foldl1 div') exprs
    *<|> exprN A9

-- match remainder (%) operator.
exprN A7 =
    "modulo" ?: do
        exprs <- sepBy1 (exprN  A8) (try $ padString "%")
        let mod' a b = Var "%" :$ [a, b]
        return $ foldl1 mod' exprs
    *<|> exprN A8

-- match string addition (++) operator.
exprN A6 =
    "append" ?: do
        exprs <- sepBy1 (exprN A7) (try $ padString "++")
        return $ collector "++" exprs
    *<|> exprN A7

-- match sequences of addition and subtraction.
exprN A5 =
    "addition/subtraction" ?: do
        -- Similar to multiply & divide
        -- eg. "1+2+3-4-5+6-7"
        --     [[1],[2],[3,4,5],[6,7]]
        exprs <- sepBy1
            (sepBy1 (exprN A6) (try $ padString "-" ))
            (try $ padString "+" )
        let sub a b = Var "-" :$ [a, b]
        return . collector "+" $ map (foldl1 sub) exprs
    *<|> exprN A6

-- match comparison operators.
exprN A4 =
    do
        firstExpr <- exprN A5
        otherComparisonsExpr <- many $ do
            comparisonSymb <-
                     padString "=="
                *<|> padString "!="
                *<|> padString ">="
                *<|> padString "<="
                *<|> padString ">"
                *<|> padString "<"
            expr <- exprN A5
            return (Var comparisonSymb, expr)
        let
            (comparisons, otherExprs) = unzip otherComparisonsExpr
            exprs = firstExpr:otherExprs
        return $ case comparisons of
            []  -> firstExpr
            [x] -> x :$ exprs
            _   -> collector "all" $ zipWith3 (\c e1 e2 -> c :$ [e1,e2]) comparisons exprs (tail exprs)
    *<|> exprN A5

-- match the logical negation operator.
exprN A3 =
    "logical-not" ?: do
        _ <- padString "!"
        a <- exprN A4
        return $ Var "!" :$ [a]
    *<|> exprN A4

-- match the logical And and Or (&&,||) operators.
exprN A2 =
    "logical and/or" ?: do
        a <- exprN A3
        symb <-      padString "&&"
                *<|> padString "||"
        b <- exprN A2
        return $ Var symb :$ [a,b]
    *<|> exprN A3

-- match the ternary (1?2:3) operator.
exprN A1 =
    "ternary" ?: do
        a <- exprN A2
        _ <- padString "?"
        b <- exprN A1
        _ <- padString ":"
        c <- exprN A1
        return $ Var "?" :$ [a,b,c]
    *<|> exprN A2

-- Match and throw away any white space around an expression.
exprN A0 =
    do
        _ <- genSpace
        expr <- exprN A1
        _ <- genSpace
        return expr
    *<|> exprN A1