{-| Simple fix-expression parser

    If in doubt, just use parsefix
-}

module Parser.Fix.Simple (TokenType (..), Fixity (..), parsefix, foldfix, shunt) where

import Control.Monad;
import Control.Monad.Instances;
import Data.List;
import Data.Maybe;

-- | Fixity/Associativity
data Fixity = Prefix | InfixLeft | InfixRight | InfixNull | Postfix deriving Eq;

data TokenType = -- | Plain, i.e. operand
                 TokenPlain
               | TokenLParenth
               | TokenRParenth
                 -- | Operator, with fixity and precedence
               | TokenOper Fixity Integer
  deriving Eq;

-- | Shunt and Fold
parsefix :: (t -> a, t -> a -> a, t -> a -> a -> a) -> (t -> TokenType) -> [t] -> a;
parsefix apply = liftM2 (.) (foldfix apply) shunt;

-- | Fold expression in postfix form
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' [];

{-| Change from infix to postfix form

    Precedence at start is zero
-}
-- Dijkstra's algorithm
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;