{-# OPTIONS -fglasgow-exts #-}

{-
    Higher-level parser for building ASTs.

    I sang of leaves, of leaves of gold, and leaves of gold there grew:
    Of wind I sang, a wind there came and in the branches blew.
    Beyond the Sun, beyond the Moon, the foam was on the Sea,
    And by the strand of Ilmarin there grew a golden Tree...
-}

module Parser where
import Internals
import AST
import Lexer

type StateParser a = GenParser Char () a

operators :: OperatorTable Char () Exp
operators =
    [ methOps  " . .+ .? .* .+ .() .[] .{} .<<>> .= "   -- Method postfix
    , postOps  " ++ -- "                                -- Auto-Increment
    , rightOps " ** "                                   -- Exponentiation
    , preOps   " ! + - ~ ? * ** +^ ~^ ?^ \\ "           -- Symbolic Unary
    , leftOps  " * / % x xx +& +< +> ~& ~< ~> "     -- Multiplicative
    , leftOps  " + - ~ +| +^ ~| ~^ "                    -- Additive
    , leftOps  " & ! "                                  -- Junctive And
    , leftOps  " ^ | "                                  -- Junctive Or
    , preOps   primitiveUnaryFunctions                  -- Name Unary
    , leftOps  " => but does cmp <=> .. ^.. ..^ ^..^ "  -- Non-chaining Binary
      ++ postOps "..."
    , cmpOps $ " != == < <= > >= ~~ !~ " ++
               " eq ne lt le gt ge =:= "                -- Chained Binary
    , leftOps  " && "                                   -- Tight And
    , leftOps  " || ^^ // "                             -- Tight Or
    , ternOps  [("??", "::")]                           -- Ternary
    , leftOps  " = := ::= += **= xx= "                  -- Assignment
    -- XXX rewrite chained Ops using sepBy!
    , rightOps " , "                                    -- List Item Separator
    , preOps   primitiveListFunctions                   -- List Operator
    , leftOps  " ==> "                                  -- Pipe Forward
    , leftOps  " and "                                  -- Loose And
    , leftOps  " or xor err "                           -- Loose Or
    , leftOps  " ; "                                    -- Terminator
    ]

primitiveListFunctions = " not "

parseExp = parseOp

parseOp = buildExpressionParser operators parseTerm

ops f s = [f n | n <- words s]

makeOp op name = do
    reservedOp name
    return $ op name

leftOps     = ops left
rightOps    = ops right
cmpOps      = ops cmp
postOps     = ops postfix
preOps      = ops prefix

left name   = Infix (makeOp Op2 name) AssocLeft
right name  = Infix (makeOp Op2 name) AssocRight
cmp name    = Infix (makeOp OpCmp name) AssocLeft
prefix      = Prefix . makeOp Op1
postfix     = Postfix . makeOp Op1

parseTerm = parens parseOp
    <|> parseLit
--  <|> nonTerm
    <?> "term"

nonTerm = do
    pos <- getPosition
    return $ NonTerm pos

parseLit = choice
    [ numLiteral
    , strLiteral
    , namedLiteral "undef"  VUndef
    , namedLiteral "NaN"    (VNum $ 0/0)
    , namedLiteral "Inf"    (VNum $ 1/0)
    ]

numLiteral = do
    n <- naturalOrFloat  
    case n of
        Left  i -> return . Val $ VInt i
        Right d -> return . Val $ VNum d

strLiteral = return . Val . VStr =<< stringLiteral

namedLiteral n v = do
    lexeme (string n)
    return $ Val v

op_methodPostfix    = []
op_namedUnary       = []
methOps _ = []
primitiveUnaryFunctions = []
ternOps _ = []
listOps _ = []

-- runLex :: Show a => StateParser a -> String -> IO ()
runLex f p input
        = runParse f (do{ whiteSpace
                 ; x <- p
                 ; eof
                 ; return x
                 }) input

-- run :: Show a => StateParser a -> String -> IO ()
runParse f p input
        = case ( runParser p () "" input ) of
            Left err -> do{ putStr "parse error at "
                          ; print err
                          }
            Right x  -> f x