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 -> t -> a, t -> t -> t -> a) -> (t -> TokenType) -> [t] -> [a];
parsefix apply = liftM2 (.) (foldfix apply) shunt;
foldfix :: (t -> a, t -> t -> a, t -> t -> t -> a) -> (t -> TokenType) -> [t] -> [a];
foldfix (apply0, apply1, apply2) lookup_t =
let {
foldfix' _ [] = [];
foldfix' stack (t:ts) =
case lookup_t t of {
TokenPlain -> foldfix' (t:stack) ts;
TokenOper fix p | fix_arity fix == 2,
(x:y:stack') <- stack -> apply2 t x y : foldfix' stack' ts
| fix_arity fix == 1,
(x:stack') <- stack -> apply1 t x : foldfix' stack' ts
| otherwise -> error "Malformed fix expression";
TokenLParenth -> error "Mismatched Parentheses";
TokenRParenth -> 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);
};
}) [];