{-| 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 -> t -> a, t -> t -> t -> a) -> (t -> TokenType) -> [t] -> [a];
parsefix apply = liftM2 (.) (foldfix apply) shunt;

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

{-| 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);
                      };
   }) [];