{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

-- | Build expression parsers.
--   Very much inspired by "Control.Monad.Combinators.Expr" from the
--   @parser-combinators@ package.
--   Unlike that, this module allows expressions to fail based on their
--   arguments.
--   This is, in particular, useful for parsing mixed-type expressions.
--   This module further differs from "Control.Monad.Combinators.Expr" in that
--   operator tables contain rows of increasing, not decreasing precedence.
module Control.Monad.Combinators.FailExpr
  ( Associativity(..)
  , Operator(..)
  , makeExprParser
  )
where


-- Notes:
--  * We can merge any operators of the same precedence and associativity.
--    (TODO?)
--  * CONSIDER: Support unary (prefix) operators.
--    - Not deemed too useful, because we believe that unary (prefix)
--      operators should always have highest precedence.
--      - Consider the common boolean `!`.
--        - One might want to parse `! 3 == 3` as `! (3 == 3)`, which would
--          require `!` to have a specific precedence (lower than `==`).
--        - However, `! true == true`, should certainly be parsed as
--          `(! true) == true`.
--        - We currently do not support different precedence based on the
--          operands' types, and that seems generally difficult.


import Prelude hiding (exp)
import Control.Applicative (Alternative, empty, (<|>))
import Data.Foldable (asum)


data Associativity = AssocN | AssocL | AssocR

-- | A (binary) 'Operator' has an 'Associativity', and a parser that yields a
--   function to combine operand expressions, which may fail based on the
--   operands.
--   The parser must not accept the empty input.
data Operator m a
  = Binary Associativity (m (a -> a -> Maybe a))


runBinOp :: (Functor m) => Operator m a -> m (Associativity, a -> a -> Maybe a)
runBinOp (Binary assoc p) = (assoc,) <$> p

runAnyBinOp
  :: (Alternative m) => [Operator m a] -> m (Associativity, a -> a -> Maybe a)
runAnyBinOp = asumMap runBinOp

isOpAssocR :: Operator m a -> Bool
isOpAssocR (Binary AssocR _) = True
isOpAssocR _                 = False

isOpAssocL :: Operator m a -> Bool
isOpAssocL (Binary AssocL _) = True
isOpAssocL _                 = False

asumMap :: (Alternative f) => (a -> f b) -> [a] -> f b
asumMap f = asum . map f

liftMaybe :: (Alternative f) => Maybe a -> f a
liftMaybe (Just x) = pure x
liftMaybe Nothing  = empty


-- Algorithm overview:
--  * We do not handle parantheses; expressions within parantheses count as
--    terminals.
--  * Expressions have the following form (with parantheses added to denote
--    associativity):
--      > (...(((T op1 E1) op2 E2) op3 E3) op4 ...)
--      * T is a terminal, E{i} are expressions, op{i} operators.
--      * Assuming all operators are non-associative, op{k} has lower
--        precedence than all operators in E{k}, and higher precedence than
--        op{k+1}.
--        * IOW: prec(ops(E{k})) > prec(op{k}) > prec(op{k+1})
--      * Parsing is thus basically:
--        * prec <- 0
--        * exp <- Parse terminal.
--        * opPrec <- None
--        * while possible:
--          * (op, opPrec) <- Parse operator with precedence >= prec
--                            and < opPrec.
--            * The latter can be relaxed to != opPrec.
--              * Reason: The precesing expression ate up all ops with
--                precedence > opPrec.
--          * exp' <- parse expression with precedences > opPrec.
--          * exp <- exp op exp'
--        * return exp
--      * Associative operators only require a few modifications.
--  * Instead of precedence numbers, we match on parts of the operator table.
--    * A suffix of the operator table models `>= prec`.
--    * We do not model `< prec`, which is not needed for the algorithm.
--    * We model `== prec` as a single row of the operator table.


-- | Build an expression parser from an operator table.
--   The operator table consists of rows of increasing precedence.
--   Operators in the same row have the same precedence.
makeExprParser
  :: forall m a. (Alternative m, MonadFail m)
  => m a -> [[Operator m a]] -> m a
makeExprParser termP = exp
  where
    exp :: [[Operator m a]] -> m a
    exp ctxOpss = termP >>= suf []
      where
        suf :: [Operator m a] -> a -> m a
        suf badInitialOps x
           =  runAnyBinOp badInitialOps *> fail
                ( unwords
                    [ "Operators have same precedence,"
                    , "but either different or no associativity."
                    ]
                )
          <|> suf' ctxOpss
          where
            suf' :: [[Operator m a]] -> m a
            suf' []         = return x
            suf' (ops:opss) = suf'' ops opss <|> suf' opss

            suf'' :: [Operator m a] -> [[Operator m a]] -> m a
            suf'' ops opss = do
              (assoc, f) <- runAnyBinOp ops
              y <- exp $ case assoc of
                AssocR -> filter isOpAssocR ops : opss
                _      -> opss
              x' <- liftMaybe (f x y)
                      <|> fail "Mismatching operator signature."
              case assoc of
                AssocL -> suf (filter (not . isOpAssocL) ops) x'
                _      -> suf ops x'