```-- | Creates RPN expressions from infix inputs.
--
-- Penny accepts only infix expressions, but RPN expressions are
-- easier to process. This module converts infix expressions to RPN
-- expressions for further processing.
--
-- Uses the shunting-yard algorithm, best described at
-- http://www.chris-j.co.uk/parsing.php (be sure to use the \"click to
module Penny.Liberty.Expressions.Infix (

Precedence(Precedence),

Associativity(ALeft,
ARight),

Token(TokOperand,
TokUnaryPostfix,
TokUnaryPrefix,
TokBinary,
TokOpenParen,
TokCloseParen),

infixToRPN
) where

import qualified Data.Foldable as Fdbl
import qualified Penny.Liberty.Expressions.RPN as R
import qualified Data.Sequence as Seq
import Data.Sequence((|>), Seq)

-- | Precedence can be any integer; the greater the number, the higher
-- the precedence.
newtype Precedence = Precedence Int deriving (Show, Eq, Ord)

data Associativity = ALeft | ARight deriving Show

data Token a =
TokOperand a
| TokUnaryPostfix (a -> a)
| TokUnaryPrefix Precedence (a -> a)
| TokBinary Precedence Associativity (a -> a -> a)
| TokOpenParen
| TokCloseParen

instance (Show a) => Show (Token a) where
show (TokOperand a) = "<operand " ++ show a ++ ">"
show (TokUnaryPostfix _) = "<unary postfix>"
show (TokUnaryPrefix (Precedence i) _) =
"<unary prefix, precedence " ++ (show i) ++ ">"
show (TokBinary (Precedence i) a _) =
"<binary, precedence " ++ show i ++ " "
++ show a ++ ">"
show TokOpenParen = "<OpenParen>"
show TokCloseParen = "<CloseParen>"

data StackVal a =
StkUnaryPrefix Precedence (a -> a)
| StkBinary Precedence (a -> a -> a)
| StkOpenParen

instance Show (StackVal a) where
show (StkUnaryPrefix p _) =
"<unary prefix, " ++ show p ++ ">"
show (StkBinary p _) =
"<binary, " ++ show p ++ ">"
show StkOpenParen = "<OpenParen>"

-- | Converts an infix expression to an RPN expression.
infixToRPN ::
Fdbl.Foldable l
=> l (Token a)
-- ^ Input tokens. These should be in the sequence from left to
-- right in ordinary infix order. The easiest choice is a list,
-- though you might want to use Data.Sequence if many appends will
-- be needed to build the sequence.

-> Maybe (Seq (R.Token a))
-- ^ The resulting RPN expression. The token type here is a token
-- from Penny.Liberty.Expressions.RPN, which is a different type
-- than the Token in this module. Fails only if there is a close
-- parenthesis without a matching open parenthesis, or if there is
-- an open parenthesis without a matching close parenthesis. Other
-- nonsensical expressions will still parse to an RPN expression
-- successfully, so the RPN parser has to catch these errors.

infixToRPN ls =
Fdbl.foldlM processToken ([], Seq.empty) ls
>>= popRemainingOperators

-- | Process a single input token. Fails if the token is a close
-- parenthesis and a matching open parenthesis is not
-- found. Otherwise, succeeds and adjusts the stack and the output
-- queue accordingly.
processToken ::
([StackVal a], Seq (R.Token a))
-> Token a
-> Maybe ([StackVal a], Seq (R.Token a))
processToken (ss, ts) tok =
case tok of
TokOperand a -> Just (ss, processOperand a ts)
TokUnaryPostfix f ->
Just (ss, processUnaryPostfix f ts)
TokUnaryPrefix p f ->
Just (processUnaryPrefix p f ss, ts)
TokBinary p a f ->
Just (processBinary p a f (ss, ts))
TokOpenParen -> Just (processOpenParen ss, ts)
TokCloseParen -> processCloseParen (ss, ts)

-- | If a token is an operand, append it to the postfix output.
processOperand :: a -> Seq (R.Token a) -> Seq (R.Token a)
processOperand a sq = sq |> (R.TokOperand (R.Operand a))

-- | If a token is a unary postfix operator, append it to the postfix
-- output.
processUnaryPostfix ::
(a -> a)
-> Seq (R.Token a)
-> Seq (R.Token a)
processUnaryPostfix f sq =
sq |> (R.TokOperator (R.Unary f))

-- | If a token is a unary prefix operator, push it onto the stack.
processUnaryPrefix ::
Precedence
-> (a -> a)
-> [StackVal a]
-> [StackVal a]
processUnaryPrefix p f s = (StkUnaryPrefix p f):s

-- | Pops tokens from the stack and appends them to the ouptut, as
-- long as the token at the top of the stack is and operator and its
-- precedence meets the given predicate.
popTokens ::
(Precedence -> Bool)
-> ([StackVal a], Seq (R.Token a))
-> ([StackVal a], Seq (R.Token a))
popTokens f (ss, os) =
case ss of
[] -> (ss, os)
x:xs -> case x of
StkOpenParen -> (ss, os)
StkUnaryPrefix p g -> popper (R.Unary g) p
StkBinary p g -> popper (R.Binary g) p
where
popper tok pr =
if f pr
then
let output' = os |> (R.TokOperator tok)
in popTokens f (xs, output')
else (ss, os)

-- | If the token is a binary operator A, then:
--
-- If A is left associative, while there is an operator B of higher or
-- equal precedence than A at the top of the stack, pop B off the
-- stack and append it to the output.
--
-- If A is right associative, while there is an operator B of higher
-- precedence than A at the top of the stack, pop B off the stack and
-- append it to the output.
--
-- Push A onto the stack.
processBinary ::
Precedence
-> Associativity
-> (a -> a -> a)
-> ([StackVal a], Seq (R.Token a))
-> ([StackVal a], Seq (R.Token a))
processBinary p a f pair =
let pdct = case a of
ALeft -> (>= p)
ARight -> (> p)
(ss, os) = popTokens pdct pair
in ((StkBinary p f):ss, os)

-- | If the token is an opening parenthesis, push it onto the stack.
processOpenParen :: [StackVal a] -> [StackVal a]
processOpenParen = (StkOpenParen :)

-- | If the token is a closing parenthesis, pop operators off the top
-- of the stack and append them to the output until the operator at
-- the top of the stack is an opening bracket. Pop the opening bracket
-- off the stack.
--
-- Fails if no open paren is found.
processCloseParen ::
([StackVal a], Seq (R.Token a))
-> Maybe ([StackVal a], Seq (R.Token a))
processCloseParen (ss, os) = case ss of
[] -> Nothing
(x:xs) ->
let popper op = processCloseParen (xs, output')
where
output' = os |> (R.TokOperator op)
in case x of
StkUnaryPrefix _ f -> popper (R.Unary f)
StkBinary _ f -> popper (R.Binary f)
StkOpenParen -> Just (xs, os)

-- | Removes all remaining operators from the stack and puts them on
-- the output queue. Fails if the stack has an open parenthesis; as
-- this is unmatched.
popRemainingOperators ::
([StackVal a], Seq (R.Token a))
-> Maybe (Seq (R.Token a))
popRemainingOperators (s, os) = case s of
[] -> Just os
x:xs -> case x of
StkOpenParen -> Nothing
StkUnaryPrefix _ f -> pusher (R.Unary f)
StkBinary _ f -> pusher (R.Binary f)
where
pusher op = popRemainingOperators (xs, output') where
output' = os |> (R.TokOperator op)
```