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)
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>"
infixToRPN ::
Fdbl.Foldable l
=> l (Token a)
-> Maybe (Seq (R.Token a))
infixToRPN ls =
Fdbl.foldlM processToken ([], Seq.empty) ls
>>= popRemainingOperators
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)
processOperand :: a -> Seq (R.Token a) -> Seq (R.Token a)
processOperand a sq = sq |> (R.TokOperand (R.Operand a))
processUnaryPostfix ::
(a -> a)
-> Seq (R.Token a)
-> Seq (R.Token a)
processUnaryPostfix f sq =
sq |> (R.TokOperator (R.Unary f))
processUnaryPrefix ::
Precedence
-> (a -> a)
-> [StackVal a]
-> [StackVal a]
processUnaryPrefix p f s = (StkUnaryPrefix p f):s
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)
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)
processOpenParen :: [StackVal a] -> [StackVal a]
processOpenParen = (StkOpenParen :)
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)
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)