1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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'
|
