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
130
131
132
133
134
135
136
137
138
|
{-# 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
loopM :: (Alternative m, Monad m) => (a -> m a) -> a -> m a
loopM f = go
where
go x = (f x >>= go) <|> return x
-- 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 >>= sufs
where
sufs :: a -> m a
sufs = fmap snd . loopM (uncurry suf) . ([],)
suf :: [Operator m a] -> a -> m ([Operator m a], 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 ([Operator m a], a)
suf' [] = return ([], x)
suf' (ops:opss) = suf'' ops opss <|> suf' opss
suf''
:: [Operator m a] -> [[Operator m a]] -> m ([Operator m a], 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 -> return (filter (not . isOpAssocL) ops, x')
_ -> return (ops, x')
|
