Infix.hs

-- | Creates RPN expressions from infix inputs.
--
-- Penny accepts only infix expressions, but RPN expressions are
-- easier to process. This module converts infix expressions to RPN
-- expressions for further processing.
--
-- Uses the shunting-yard algorithm, best described at
-- http://www.chris-j.co.uk/parsing.php (be sure to use the \"click to
-- display\" links).
module Penny.Liberty.Expressions.Infix (

  Precedence(Precedence),

  Associativity(ALeft,
                ARight),

  Token(TokOperand,
        TokUnaryPostfix,
        TokUnaryPrefix,
        TokBinary,
        TokOpenParen,
        TokCloseParen),

  infixToRPN
  ) where

import qualified Data.Foldable as Fdbl
import qualified Penny.Liberty.Expressions.RPN as R
import qualified Data.Sequence as Seq
import Data.Sequence((|>), Seq)

-- | Precedence can be any integer; the greater the number, the higher
-- the precedence.
newtype Precedence = Precedence Int deriving (Show, Eq, Ord)

data Associativity = ALeft | ARight deriving Show

data Token a =
  TokOperand a
  | TokUnaryPostfix (a -> a)
  | TokUnaryPrefix Precedence (a -> a)
  | TokBinary Precedence Associativity (a -> a -> a)
  | TokOpenParen
  | TokCloseParen

instance (Show a) => Show (Token a) where
  show (TokOperand a) = "<operand " ++ show a ++ ">"
  show (TokUnaryPostfix _) = "<unary postfix>"
  show (TokUnaryPrefix (Precedence i) _) =
    "<unary prefix, precedence " ++ (show i) ++ ">"
  show (TokBinary (Precedence i) a _) =
    "<binary, precedence " ++ show i ++ " "
    ++ show a ++ ">"
  show TokOpenParen = "<OpenParen>"
  show TokCloseParen = "<CloseParen>"

data StackVal a =
  StkUnaryPrefix Precedence (a -> a)
  | StkBinary Precedence (a -> a -> a)
  | StkOpenParen

instance Show (StackVal a) where
  show (StkUnaryPrefix p _) =
    "<unary prefix, " ++ show p ++ ">"
  show (StkBinary p _) =
    "<binary, " ++ show p ++ ">"
  show StkOpenParen = "<OpenParen>"

-- | Converts an infix expression to an RPN expression.
infixToRPN ::
  Fdbl.Foldable l
  => l (Token a)
  -- ^ Input tokens. These should be in the sequence from left to
  -- right in ordinary infix order. The easiest choice is a list,
  -- though you might want to use Data.Sequence if many appends will
  -- be needed to build the sequence.

  -> Maybe (Seq (R.Token a))
  -- ^ The resulting RPN expression. The token type here is a token
  -- from Penny.Liberty.Expressions.RPN, which is a different type
  -- than the Token in this module. Fails only if there is a close
  -- parenthesis without a matching open parenthesis, or if there is
  -- an open parenthesis without a matching close parenthesis. Other
  -- nonsensical expressions will still parse to an RPN expression
  -- successfully, so the RPN parser has to catch these errors.

infixToRPN ls =
  Fdbl.foldlM processToken ([], Seq.empty) ls
  >>= popRemainingOperators


-- | Process a single input token. Fails if the token is a close
-- parenthesis and a matching open parenthesis is not
-- found. Otherwise, succeeds and adjusts the stack and the output
-- queue accordingly.
processToken ::
  ([StackVal a], Seq (R.Token a))
  -> Token a
  -> Maybe ([StackVal a], Seq (R.Token a))
processToken (ss, ts) tok =
  case tok of
    TokOperand a -> Just (ss, processOperand a ts)
    TokUnaryPostfix f ->
      Just (ss, processUnaryPostfix f ts)
    TokUnaryPrefix p f ->
      Just (processUnaryPrefix p f ss, ts)
    TokBinary p a f ->
      Just (processBinary p a f (ss, ts))
    TokOpenParen -> Just (processOpenParen ss, ts)
    TokCloseParen -> processCloseParen (ss, ts)

-- | If a token is an operand, append it to the postfix output.
processOperand :: a -> Seq (R.Token a) -> Seq (R.Token a)
processOperand a sq = sq |> (R.TokOperand (R.Operand a))

-- | If a token is a unary postfix operator, append it to the postfix
-- output.
processUnaryPostfix ::
  (a -> a)
  -> Seq (R.Token a)
  -> Seq (R.Token a)
processUnaryPostfix f sq =
  sq |> (R.TokOperator (R.Unary f))

-- | If a token is a unary prefix operator, push it onto the stack.
processUnaryPrefix ::
  Precedence
  -> (a -> a)
  -> [StackVal a]
  -> [StackVal a]
processUnaryPrefix p f s = (StkUnaryPrefix p f):s

-- | Pops tokens from the stack and appends them to the ouptut, as
-- long as the token at the top of the stack is and operator and its
-- precedence meets the given predicate.
popTokens ::
  (Precedence -> Bool)
  -> ([StackVal a], Seq (R.Token a))
  -> ([StackVal a], Seq (R.Token a))
popTokens f (ss, os) =
  case ss of
    [] -> (ss, os)
    x:xs -> case x of
      StkOpenParen -> (ss, os)
      StkUnaryPrefix p g -> popper (R.Unary g) p
      StkBinary p g -> popper (R.Binary g) p
      where
        popper tok pr =
          if f pr
          then
            let output' = os |> (R.TokOperator tok)
            in popTokens f (xs, output')
          else (ss, os)
  

-- | If the token is a binary operator A, then:
--
-- If A is left associative, while there is an operator B of higher or
-- equal precedence than A at the top of the stack, pop B off the
-- stack and append it to the output.
--
-- If A is right associative, while there is an operator B of higher
-- precedence than A at the top of the stack, pop B off the stack and
-- append it to the output.
--
-- Push A onto the stack.
processBinary ::
  Precedence
  -> Associativity
  -> (a -> a -> a)
  -> ([StackVal a], Seq (R.Token a))
  -> ([StackVal a], Seq (R.Token a))
processBinary p a f pair =
  let pdct = case a of
        ALeft -> (>= p)
        ARight -> (> p)
      (ss, os) = popTokens pdct pair
  in ((StkBinary p f):ss, os)

-- | If the token is an opening parenthesis, push it onto the stack.
processOpenParen :: [StackVal a] -> [StackVal a]
processOpenParen = (StkOpenParen :)

-- | If the token is a closing parenthesis, pop operators off the top
-- of the stack and append them to the output until the operator at
-- the top of the stack is an opening bracket. Pop the opening bracket
-- off the stack.
--
-- Fails if no open paren is found.
processCloseParen ::
  ([StackVal a], Seq (R.Token a))
  -> Maybe ([StackVal a], Seq (R.Token a))
processCloseParen (ss, os) = case ss of
  [] -> Nothing
  (x:xs) ->
    let popper op = processCloseParen (xs, output')
          where
            output' = os |> (R.TokOperator op)
    in case x of
      StkUnaryPrefix _ f -> popper (R.Unary f)        
      StkBinary _ f -> popper (R.Binary f)
      StkOpenParen -> Just (xs, os)

-- | Removes all remaining operators from the stack and puts them on
-- the output queue. Fails if the stack has an open parenthesis; as
-- this is unmatched.
popRemainingOperators ::
  ([StackVal a], Seq (R.Token a))
  -> Maybe (Seq (R.Token a))
popRemainingOperators (s, os) = case s of
  [] -> Just os
  x:xs -> case x of
    StkOpenParen -> Nothing
    StkUnaryPrefix _ f -> pusher (R.Unary f)
    StkBinary _ f -> pusher (R.Binary f)
    where
      pusher op = popRemainingOperators (xs, output') where
        output' = os |> (R.TokOperator op)