1 files changed, 129 insertions, 0 deletions
diff --git a/src/Control/Monad/Combinators/FailExpr.hs b/src/Control/Monad/Combinators/FailExpr.hs
new file mode 100644
index 0000000..045bd00
--- /dev/null
+++ b/src/Control/Monad/Combinators/FailExpr.hs
@@ -0,0 +1,129 @@
+{-# 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?)
+
+
+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'