module Parser.Fix.Simple (TokenType (..), Fixity (..), parsefix, foldfix, shunt) where
import Control.Monad;
import Control.Monad.Instances;
import Data.List;
import Data.Maybe;
data Fixity = Prefix | InfixLeft | InfixRight | InfixNull | Postfix deriving Eq;
data TokenType =
TokenPlain
| TokenLParenth
| TokenRParenth
| TokenOper Fixity Integer
deriving Eq;
parsefix :: (t -> a, t -> a -> a, t -> a -> a -> a) -> (t -> TokenType) -> [t] -> a;
parsefix apply = liftM2 (.) (foldfix apply) shunt;
foldfix :: (t -> a, t -> a -> a, t -> a -> a -> a) -> (t -> TokenType) -> [t] -> a;
foldfix (apply0, apply1, apply2) lookup_t =
let {
foldfix' stack = flip list (list const (error "Empty Stack!") stack) $ \ t ->
case lookup_t t of {
TokenPlain -> foldfix' (apply0 t:stack);
TokenOper fix p | fix_arity fix == 2,
(x:y:stack') <- stack -> foldfix' (apply2 t x y : stack')
| fix_arity fix == 1,
(x:stack') <- stack -> foldfix' (apply1 t x : stack')
| otherwise -> const $ error "Malformed fix expression";
TokenLParenth -> const $ error "Mismatched Parentheses";
TokenRParenth -> const $ error "Mismatched Parentheses";
};
fix_arity Prefix = 1;
fix_arity Postfix = 1;
fix_arity InfixLeft = 2;
fix_arity InfixRight = 2;
fix_arity InfixNull = 2;
} in foldfix' [];
shunt :: (t -> TokenType) -> [t] -> [t];
shunt lookup_t = join . snd . mapAccumR
(\ stack t ->
case lookup_t t of {
TokenPlain -> (stack, [t]);
TokenOper fix1 p1 | or $ map (== fix1) [InfixLeft, InfixRight, InfixNull] ->
case map lookup_t stack of {
(TokenOper fix2 p2 : _) | fix1 == InfixLeft && p1 <= p2 ||
fix1 == InfixRight && p1 < p2 ->
(t : tail stack, [head stack]);
_ -> (t : id stack, []);
}
| Postfix == fix1 -> ( stack, [t])
| Prefix == fix1 -> (t:stack, [])
;
TokenLParenth -> (t:stack, []);
TokenRParenth -> case break ((== TokenLParenth) . lookup_t) stack of {
(ts, _:stack') -> (stack', ts);
(ts, _) -> (error "Mismatched Parentheses", ts);
};
}) [];
list :: (a -> [a] -> b) -> b -> [a] -> b;
list f y [] = y;
list f y (x:xs) = f x xs;