{-|
Module      : $Header$
Description : Turns a list of lexemes into a AST of Nodes (Expression.hs)
Copyright   : (c) Joshua Gutow, 2016
License     : GNU AGPL-3

Maintainer  : jbgutow@gmail.com
Stability   : experimental
Portability : portable

This turns infix notation into Polish Notation (prefix notation) so
that the order of operations in unambiguous.
-}

module Parser ( parseList,
                infixToPolish,
              ) where

import Numeric (readSigned, readFloat)
import Data.List (elemIndex, findIndex)
import Lexer
import Operations
import Expression
import Atomic


-- | This function parses a lexeme list in infix notation.
parseList :: [Lexeme] -> Node
parseList = createAST . removeImplicitMult . infixToPolish

-- | Turns implicit mult lexemes into proper operation lexemes.
removeImplicitMult :: [Lexeme] -> [Lexeme]
removeImplicitMult = map (\x -> if x == Opr ImplicitMult
                                then Opr (LexOp Multiplication)
                                else x)


-- | This creates an abstract syntax tree from a list of Lexemes in Polish
-- notation.
createAST :: [Lexeme] -- ^ Input list in polish notation.
          -> Node     -- ^ Output tree. Not in canonical form.

createAST (Opr (LexUOp o):xs)    = UnaryOp   o (createAST xs)
createAST (Opr (LexBOp o):xs)    = BinaryOp  o (createAST xs) (createAST $ gSB xs)
createAST (x@(Opr (LexOp o)):xs) = Operation o $ map createAST $ gCom x xs

createAST (LexVar s:_)  = Leaf $ Var s
createAST (LexDiff s:_) = Leaf $ Diff s
createAST (LexNum s:_)  = Leaf $ Num (fst.head $ readSigned readFloat s :: Rational)


-- | This flattens out commutative operations.
gCom :: Lexeme -> [Lexeme] -> [[Lexeme]]
gCom o list = first ++ rest where
    first = if head list == o
            then gCom o $ tail list
            else [list]
    rest = if head (gSB list) == o
           then gCom o $ tail $ gSB list
           else [gSB list]


-- | This finds the second operand of a binary operation be setting up gs with
-- the right conditions.
gSB :: [Lexeme] -> [Lexeme]
gSB x@(Opr _:_) = gs x 1
gSB xs = tail xs

-- | This finds the second operand of a binary operation by counting the
-- expected number of arguments to each operation.
gs :: [Lexeme] -> Int -> [Lexeme]
gs (o@(Opr (LexUOp _)):xs) count
    | count == 0 = o:xs
    | otherwise  = gs xs count
gs (o@(Opr _):xs) count
    | count == 0 = o:xs
    | otherwise  = gs xs (count + 1)
gs (x:xs) count
    | count == 0 = x:xs
    | otherwise  = gs xs (count - 1)


-- | This function takes a list of lexemes in infix notation and then turns it
-- into a list of lexemes in prefix notation.
infixToPolish :: [Lexeme] -- ^ Input list in infix notation.
              -> [Lexeme] -- ^ Output list in polish notation.
infixToPolish input = sy (reverse input) []

-- | This function implements the shunting yard algorithm. It is modified from
-- Dijkstra's to turn the input into prefix instead of postfix.
sy :: [Lexeme] -- ^ Input list
   -> [Lexeme] -- ^ Operator stack
   -> [Lexeme] -- ^ Return value

sy [] ops = reverse ops

sy (x@(LexVar _):xs)  ops = sy xs ops ++ [x]
sy (x@(LexNum _):xs)  ops = sy xs ops ++ [x]
sy (x@(LexDiff _):xs) ops = sy xs ops ++ [x]

sy (x@CloseParen:xs) ops = sy xs (x:ops)

sy (x@(Opr _):xs)  ops@(CloseParen:_) = sy xs (x:ops)
sy (x@(Opr o1):xs) ops@(Opr o2:os)
    | aright o1 && isUnary x = sy xs ops ++ [x]
    | otherwise              = sy xs newOps ++ newOut
  where
    newOps = case findIndex (endOp o1) ops of
                Just n  -> x:drop n ops
                Nothing -> [x]
    newOut = case findIndex (endOp o1) ops of
                Just n  -> reverse $ take n ops
                Nothing -> reverse ops

    -- | This determines if the lexeme should be popped of into the output given
    -- the current operator in the input.
    endOp :: Operator a => a -> Lexeme -> Bool
    endOp a (Opr b)
        | aleft  a && prec a <  prec b = False
        | aright a && prec a <= prec b = False
        | otherwise                    = True
    endOp _ _                          = True

sy (x@(Opr o):xs) []
    | aright o && isUnary x           = sy xs [] ++ [x]
    | otherwise                       = sy xs [x]

sy (OpenParen:xs) []  = sy xs []
sy (OpenParen:xs) ops = sy xs newOps ++ newOut
  where
    newOps = case elemIndex CloseParen ops of
                Just n  -> drop (n + 1) ops
                Nothing -> error "Unmatched parentheses"
    newOut = case elemIndex CloseParen ops of
                Just n  -> reverse $ take n ops
                Nothing -> error "Unmatched parentheses."


-- | The operator class is used to aid the shunting yard algorithm in the
-- precedence and associativity of different operations.
class Operator a where
    -- | Gets the precedence of a given operation.
    prec :: a -> Int
    -- | Determines if an operation associates to the left. Default = True.
    aleft :: a -> Bool
    -- | Determines if an operation associates to the right. Default = not aleft.
    aright :: a -> Bool
    aleft _ = True
    aright = not . aleft

-- | Simply unwraps the LexOperation data.
instance Operator LexOperation where
    prec  (LexOp o)    = prec o
    prec  (LexBOp o)   = prec o
    prec  (LexUOp o)   = prec o
    prec  ImplicitMult = 6
    aleft (LexOp o)    = aleft o
    aleft (LexBOp o)   = aleft o
    aleft (LexUOp o)   = aleft o
    aleft ImplicitMult = True

-- | Defines precedence for commutative operations.
instance Operator Op where
    prec Addition = 2
    prec Multiplication = 3

-- | Defines precedence and associativity for binary operations.
instance Operator BOp where
    prec Exp = 4
    prec Division = 3
    prec Subtraction = 2
    aleft Exp = False
    aleft _ = True

-- | Define precedence for unary operations.
instance Operator UOp where
    aleft Factorial = True
    aleft _ = False
    prec _ = 5

