{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
module Text.Parsec.Expr
( Assoc(..), Operator(..), OperatorTable
, buildExpressionParser
) where
import Data.Typeable ( Typeable )
import Text.Parsec.Prim
import Text.Parsec.Combinator
data Assoc = AssocNone
| AssocLeft
| AssocRight
deriving ( Typeable )
data Operator s u m a = Infix (ParsecT s u m (a -> a -> a)) Assoc
| Prefix (ParsecT s u m (a -> a))
| Postfix (ParsecT s u m (a -> a))
#if MIN_VERSION_base(4,7,0)
deriving ( Typeable )
#endif
type OperatorTable s u m a = [[Operator s u m a]]
buildExpressionParser :: (Stream s m t)
=> OperatorTable s u m a
-> ParsecT s u m a
-> ParsecT s u m a
{-# INLINABLE buildExpressionParser #-}
buildExpressionParser :: forall s (m :: * -> *) t u a.
Stream s m t =>
OperatorTable s u m a -> ParsecT s u m a -> ParsecT s u m a
buildExpressionParser OperatorTable s u m a
operators ParsecT s u m a
simpleExpr
= (ParsecT s u m a -> [Operator s u m a] -> ParsecT s u m a)
-> ParsecT s u m a -> OperatorTable s u m a -> ParsecT s u m a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ParsecT s u m a -> [Operator s u m a] -> ParsecT s u m a
forall {t :: * -> *} {s} {m :: * -> *} {t} {u} {b}.
(Foldable t, Stream s m t) =>
ParsecT s u m b -> t (Operator s u m b) -> ParsecT s u m b
makeParser) ParsecT s u m a
simpleExpr OperatorTable s u m a
operators
where
makeParser :: ParsecT s u m b -> t (Operator s u m b) -> ParsecT s u m b
makeParser ParsecT s u m b
term t (Operator s u m b)
ops
= let ([ParsecT s u m (b -> b -> b)]
rassoc,[ParsecT s u m (b -> b -> b)]
lassoc,[ParsecT s u m (b -> b -> b)]
nassoc
,[ParsecT s u m (b -> b)]
prefix,[ParsecT s u m (b -> b)]
postfix) = (Operator s u m b
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)])
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)]))
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)])
-> t (Operator s u m b)
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)])
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Operator s u m b
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)])
-> ([ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b -> b)],
[ParsecT s u m (b -> b -> b)], [ParsecT s u m (b -> b)],
[ParsecT s u m (b -> b)])
forall {s} {u} {m :: * -> *} {a}.
Operator s u m a
-> ([ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a -> a)],
[ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a)],
[ParsecT s u m (a -> a)])
-> ([ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a -> a)],
[ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a)],
[ParsecT s u m (a -> a)])
splitOp ([],[],[],[],[]) t (Operator s u m b)
ops
rassocOp :: ParsecT s u m (b -> b -> b)
rassocOp = [ParsecT s u m (b -> b -> b)] -> ParsecT s u m (b -> b -> b)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m (b -> b -> b)]
rassoc
lassocOp :: ParsecT s u m (b -> b -> b)
lassocOp = [ParsecT s u m (b -> b -> b)] -> ParsecT s u m (b -> b -> b)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m (b -> b -> b)]
lassoc
nassocOp :: ParsecT s u m (b -> b -> b)
nassocOp = [ParsecT s u m (b -> b -> b)] -> ParsecT s u m (b -> b -> b)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m (b -> b -> b)]
nassoc
prefixOp :: ParsecT s u m (b -> b)
prefixOp = [ParsecT s u m (b -> b)] -> ParsecT s u m (b -> b)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m (b -> b)]
prefix ParsecT s u m (b -> b) -> String -> ParsecT s u m (b -> b)
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
""
postfixOp :: ParsecT s u m (b -> b)
postfixOp = [ParsecT s u m (b -> b)] -> ParsecT s u m (b -> b)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m (b -> b)]
postfix ParsecT s u m (b -> b) -> String -> ParsecT s u m (b -> b)
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
""
ambiguous :: String -> ParsecT s u m a -> ParsecT s u m a
ambiguous String
assoc ParsecT s u m a
op= ParsecT s u m a -> ParsecT s u m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s u m a -> ParsecT s u m a)
-> ParsecT s u m a -> ParsecT s u m a
forall a b. (a -> b) -> a -> b
$
do{ a
_ <- ParsecT s u m a
op; String -> ParsecT s u m a
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"ambiguous use of a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
assoc
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" associative operator")
}
ambiguousRight :: ParsecT s u m a
ambiguousRight = String -> ParsecT s u m (b -> b -> b) -> ParsecT s u m a
forall {s} {u} {m :: * -> *} {a} {a}.
String -> ParsecT s u m a -> ParsecT s u m a
ambiguous String
"right" ParsecT s u m (b -> b -> b)
rassocOp
ambiguousLeft :: ParsecT s u m a
ambiguousLeft = String -> ParsecT s u m (b -> b -> b) -> ParsecT s u m a
forall {s} {u} {m :: * -> *} {a} {a}.
String -> ParsecT s u m a -> ParsecT s u m a
ambiguous String
"left" ParsecT s u m (b -> b -> b)
lassocOp
ambiguousNon :: ParsecT s u m a
ambiguousNon = String -> ParsecT s u m (b -> b -> b) -> ParsecT s u m a
forall {s} {u} {m :: * -> *} {a} {a}.
String -> ParsecT s u m a -> ParsecT s u m a
ambiguous String
"non" ParsecT s u m (b -> b -> b)
nassocOp
termP :: ParsecT s u m b
termP = do{ b -> b
pre <- ParsecT s u m (b -> b)
prefixP
; b
x <- ParsecT s u m b
term
; b -> b
post <- ParsecT s u m (b -> b)
postfixP
; b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b
post (b -> b
pre b
x))
}
postfixP :: ParsecT s u m (b -> b)
postfixP = ParsecT s u m (b -> b)
postfixOp ParsecT s u m (b -> b)
-> ParsecT s u m (b -> b) -> ParsecT s u m (b -> b)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (b -> b) -> ParsecT s u m (b -> b)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return b -> b
forall a. a -> a
id
prefixP :: ParsecT s u m (b -> b)
prefixP = ParsecT s u m (b -> b)
prefixOp ParsecT s u m (b -> b)
-> ParsecT s u m (b -> b) -> ParsecT s u m (b -> b)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (b -> b) -> ParsecT s u m (b -> b)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return b -> b
forall a. a -> a
id
rassocP :: b -> ParsecT s u m b
rassocP b
x = do{ b -> b -> b
f <- ParsecT s u m (b -> b -> b)
rassocOp
; b
y <- do{ b
z <- ParsecT s u m b
termP; b -> ParsecT s u m b
rassocP1 b
z }
; b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
f b
x b
y)
}
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousLeft
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousNon
rassocP1 :: b -> ParsecT s u m b
rassocP1 b
x = b -> ParsecT s u m b
rassocP b
x ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
lassocP :: b -> ParsecT s u m b
lassocP b
x = do{ b -> b -> b
f <- ParsecT s u m (b -> b -> b)
lassocOp
; b
y <- ParsecT s u m b
termP
; b -> ParsecT s u m b
lassocP1 (b -> b -> b
f b
x b
y)
}
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousRight
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousNon
lassocP1 :: b -> ParsecT s u m b
lassocP1 b
x = b -> ParsecT s u m b
lassocP b
x ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
nassocP :: b -> ParsecT s u m b
nassocP b
x = do{ b -> b -> b
f <- ParsecT s u m (b -> b -> b)
nassocOp
; b
y <- ParsecT s u m b
termP
; ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousRight
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousLeft
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m b
forall {a}. ParsecT s u m a
ambiguousNon
ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
f b
x b
y)
}
in do{ b
x <- ParsecT s u m b
termP
; b -> ParsecT s u m b
rassocP b
x ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
lassocP b
x ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
nassocP b
x ParsecT s u m b -> ParsecT s u m b -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> b -> ParsecT s u m b
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
ParsecT s u m b -> String -> ParsecT s u m b
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"operator"
}
splitOp :: Operator s u m a
-> ([ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a -> a)],
[ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a)],
[ParsecT s u m (a -> a)])
-> ([ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a -> a)],
[ParsecT s u m (a -> a -> a)], [ParsecT s u m (a -> a)],
[ParsecT s u m (a -> a)])
splitOp (Infix ParsecT s u m (a -> a -> a)
op Assoc
assoc) ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
= case Assoc
assoc of
Assoc
AssocNone -> ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,ParsecT s u m (a -> a -> a)
opParsecT s u m (a -> a -> a)
-> [ParsecT s u m (a -> a -> a)] -> [ParsecT s u m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
Assoc
AssocLeft -> ([ParsecT s u m (a -> a -> a)]
rassoc,ParsecT s u m (a -> a -> a)
opParsecT s u m (a -> a -> a)
-> [ParsecT s u m (a -> a -> a)] -> [ParsecT s u m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
Assoc
AssocRight -> (ParsecT s u m (a -> a -> a)
opParsecT s u m (a -> a -> a)
-> [ParsecT s u m (a -> a -> a)] -> [ParsecT s u m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
splitOp (Prefix ParsecT s u m (a -> a)
op) ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
= ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,ParsecT s u m (a -> a)
opParsecT s u m (a -> a)
-> [ParsecT s u m (a -> a)] -> [ParsecT s u m (a -> a)]
forall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
splitOp (Postfix ParsecT s u m (a -> a)
op) ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,[ParsecT s u m (a -> a)]
postfix)
= ([ParsecT s u m (a -> a -> a)]
rassoc,[ParsecT s u m (a -> a -> a)]
lassoc,[ParsecT s u m (a -> a -> a)]
nassoc,[ParsecT s u m (a -> a)]
prefix,ParsecT s u m (a -> a)
opParsecT s u m (a -> a)
-> [ParsecT s u m (a -> a)] -> [ParsecT s u m (a -> a)]
forall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a)]
postfix)