module Prednote.Expressions.Infix
( InfixToken (..)
, Paren(..)
, createRPN
) where
import Data.Functor.Contravariant
import qualified Prednote.Expressions.RPN as R
import qualified Data.Foldable as Fdbl
data InfixToken a
= TokRPN (R.RPNToken a)
| TokParen Paren
instance Contravariant InfixToken where
contramap f t = case t of
TokRPN r -> TokRPN . contramap f $ r
TokParen p -> TokParen p
data Paren = Open | Close
data OpStackVal
= StkOp R.Operator
| StkOpenParen
processInfixToken
:: ([OpStackVal], [R.RPNToken a])
-> InfixToken a
-> Maybe ([OpStackVal], [R.RPNToken a])
processInfixToken (os, ts) t = case t of
TokRPN tok -> return $ processRPNToken (os, ts) tok
TokParen p -> processParen (os, ts) p
processRPNToken
:: ([OpStackVal], [R.RPNToken a])
-> R.RPNToken a
-> ([OpStackVal], [R.RPNToken a])
processRPNToken (os, ts) t = case t of
p@(R.TokOperand _) -> (os, p:ts)
R.TokOperator d -> case d of
R.OpNot -> (StkOp R.OpNot : os, ts)
R.OpAnd -> (StkOp R.OpAnd : os, ts)
R.OpOr ->
let (os', ts') = popper os ts
in (StkOp R.OpOr : os', ts')
popper :: [OpStackVal] -> [R.RPNToken a] -> ([OpStackVal], [R.RPNToken a])
popper os ts = case os of
[] -> (os, ts)
x:xs -> case x of
StkOp R.OpAnd ->
let os' = xs
ts' = R.TokOperator R.OpAnd : ts
in popper os' ts'
_ -> (os, ts)
popThroughOpen
:: ([OpStackVal], [R.RPNToken a])
-> Maybe ([OpStackVal], [R.RPNToken a])
popThroughOpen (os, ts) = case os of
[] -> Nothing
v:vs -> case v of
StkOp op -> popThroughOpen (vs, R.TokOperator op : ts)
StkOpenParen -> return (vs, ts)
processParen
:: ([OpStackVal], [R.RPNToken a])
-> Paren
-> Maybe ([OpStackVal], [R.RPNToken a])
processParen (os, ts) p = case p of
Open -> Just (StkOpenParen : os, ts)
Close -> popThroughOpen (os, ts)
createRPN
:: Fdbl.Foldable f
=> f (InfixToken a)
-> Maybe [R.RPNToken a]
createRPN ts = do
(stack, toks) <- Fdbl.foldlM processInfixToken ([], []) ts
fmap reverse $ popRemainingOperators stack toks
popRemainingOperators :: [OpStackVal] -> [R.RPNToken a] -> Maybe [R.RPNToken a]
popRemainingOperators os ts = case os of
[] -> return ts
x:xs -> case x of
StkOp op -> popRemainingOperators xs (R.TokOperator op : ts)
StkOpenParen -> Nothing