-- |
-- Copyright   :  © 2015–2018 Megaparsec contributors
--                © 2007 Paolo Martini
--                © 1999–2001 Daan Leijen
--
--
-- Code adapted from from megaparsec under the BSD license.
module Test.Tasty.Patterns.Expr
  ( Operator (..)
  , makeExprParser )
where

import Control.Monad

choice :: MonadPlus m => [m a] -> m a
choice :: forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice = [m a] -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum

option :: MonadPlus m => a -> m a -> m a
option :: forall (m :: * -> *) a. MonadPlus m => a -> m a -> m a
option a
x m a
p = m a
p m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | This data type specifies operators that work on values of type @a@. An
-- operator is either binary infix or unary prefix or postfix. A binary
-- operator has also an associated associativity.

data Operator m a
  = InfixN  (m (a -> a -> a)) -- ^ Non-associative infix
  | InfixL  (m (a -> a -> a)) -- ^ Left-associative infix
  | InfixR  (m (a -> a -> a)) -- ^ Right-associative infix
  | Prefix  (m (a -> a))      -- ^ Prefix
  | Postfix (m (a -> a))      -- ^ Postfix
  | TernR   (m (m (a -> a -> a -> a)))
    -- ^ Right-associative ternary. Right-associative means that
    -- @a ? b : d ? e : f@ parsed as
    -- @a ? b : (d ? e : f)@ and not as @(a ? b : d) ? e : f@.

-- | @'makeExprParser' term table@ builds an expression parser for terms
-- @term@ with operators from @table@, taking the associativity and
-- precedence specified in the @table@ into account.
--
-- @table@ is a list of @[Operator m a]@ lists. The list is ordered in
-- descending precedence. All operators in one list have the same precedence
-- (but may have different associativity).
--
-- Prefix and postfix operators of the same precedence associate to the left
-- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@).
--
-- Unary operators of the same precedence can only occur once (i.e. @--2@ is
-- not allowed if @-@ is prefix negate). If you need to parse several prefix
-- or postfix operators in a row, (like C pointers—@**i@) you can use this
-- approach:
--
-- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp
--
-- This is not done by default because in some cases allowing repeating
-- prefix or postfix operators is not desirable.
--
-- If you want to have an operator that is a prefix of another operator in
-- the table, use the following (or similar) wrapper instead of plain
-- 'Text.Megaparsec.Char.Lexer.symbol':
--
-- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar)
--
-- 'makeExprParser' takes care of all the complexity involved in building an
-- expression parser. Here is an example of an expression parser that
-- handles prefix signs, postfix increment and basic arithmetic:
--
-- > expr = makeExprParser term table <?> "expression"
-- >
-- > term = parens expr <|> integer <?> "term"
-- >
-- > table = [ [ prefix  "-"  negate
-- >           , prefix  "+"  id ]
-- >         , [ postfix "++" (+1) ]
-- >         , [ binary  "*"  (*)
-- >           , binary  "/"  div  ]
-- >         , [ binary  "+"  (+)
-- >           , binary  "-"  (-)  ] ]
-- >
-- > binary  name f = InfixL  (f <$ symbol name)
-- > prefix  name f = Prefix  (f <$ symbol name)
-- > postfix name f = Postfix (f <$ symbol name)

makeExprParser :: MonadPlus m
  => m a               -- ^ Term parser
  -> [[Operator m a]]  -- ^ Operator table, see 'Operator'
  -> m a               -- ^ Resulting expression parser
makeExprParser :: forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser = (m a -> [Operator m a] -> m a) -> m a -> [[Operator m a]] -> m a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m a -> [Operator m a] -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> [Operator m a] -> m a
addPrecLevel
{-# INLINEABLE makeExprParser #-}

-- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@
-- to parser @p@.

addPrecLevel :: MonadPlus m => m a -> [Operator m a] -> m a
addPrecLevel :: forall (m :: * -> *) a. MonadPlus m => m a -> [Operator m a] -> m a
addPrecLevel m a
term [Operator m a]
ops =
  m a
term' m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> [m a] -> m a
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [a -> m a
ras' a
x, a -> m a
las' a
x, a -> m a
nas' a
x, a -> m a
tern' a
x, a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x]
  where ([m (a -> a -> a)]
ras, [m (a -> a -> a)]
las, [m (a -> a -> a)]
nas, [m (a -> a)]
prefix, [m (a -> a)]
postfix, [m (m (a -> a -> a -> a))]
tern) = (Operator m a
 -> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
     [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))])
 -> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
     [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))]))
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
    [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))])
-> [Operator m a]
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
    [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Operator m a
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
    [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))])
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
    [m (a -> a)], [m (a -> a)], [m (m (a -> a -> a -> a))])
forall (m :: * -> *) a. Operator m a -> Batch m a -> Batch m a
splitOp ([],[],[],[],[],[]) [Operator m a]
ops
        term' :: m a
term' = m (a -> a) -> m a -> m (a -> a) -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a) -> m a -> m (a -> a) -> m a
pTerm ([m (a -> a)] -> m (a -> a)
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (a -> a)]
prefix) m a
term ([m (a -> a)] -> m (a -> a)
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (a -> a)]
postfix)
        ras' :: a -> m a
ras'  = m (a -> a -> a) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixR ([m (a -> a -> a)] -> m (a -> a -> a)
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (a -> a -> a)]
ras) m a
term'
        las' :: a -> m a
las'  = m (a -> a -> a) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixL ([m (a -> a -> a)] -> m (a -> a -> a)
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (a -> a -> a)]
las) m a
term'
        nas' :: a -> m a
nas'  = m (a -> a -> a) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixN ([m (a -> a -> a)] -> m (a -> a -> a)
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (a -> a -> a)]
nas) m a
term'
        tern' :: a -> m a
tern' = m (m (a -> a -> a -> a)) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (m (a -> a -> a -> a)) -> m a -> a -> m a
pTernR   ([m (m (a -> a -> a -> a))] -> m (m (a -> a -> a -> a))
forall (m :: * -> *) a. MonadPlus m => [m a] -> m a
choice [m (m (a -> a -> a -> a))]
tern) m a
term'

-- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional
-- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are
-- allowed to fail, in this case 'id' is used.

pTerm :: MonadPlus m => m (a -> a) -> m a -> m (a -> a) -> m a
pTerm :: forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a) -> m a -> m (a -> a) -> m a
pTerm m (a -> a)
prefix m a
term m (a -> a)
postfix = do
  a -> a
pre  <- (a -> a) -> m (a -> a) -> m (a -> a)
forall (m :: * -> *) a. MonadPlus m => a -> m a -> m a
option a -> a
forall a. a -> a
id m (a -> a)
prefix
  a
x    <- m a
term
  a -> a
post <- (a -> a) -> m (a -> a) -> m (a -> a)
forall (m :: * -> *) a. MonadPlus m => a -> m a -> m a
option a -> a
forall a. a -> a
id m (a -> a)
postfix
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (a -> a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
post (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
pre (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a
x

-- | @pInfixN op p x@ parses non-associative infix operator @op@, then term
-- with parser @p@, then returns result of the operator application on @x@
-- and the term.

pInfixN :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a
pInfixN :: forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixN m (a -> a -> a)
op m a
p a
x = do
  a -> a -> a
f <- m (a -> a -> a)
op
  a
y <- m a
p
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
f a
x a
y

-- | @pInfixL op p x@ parses left-associative infix operator @op@, then term
-- with parser @p@, then returns result of the operator application on @x@
-- and the term.

pInfixL :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a
pInfixL :: forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixL m (a -> a -> a)
op m a
p a
x = do
  a -> a -> a
f <- m (a -> a -> a)
op
  a
y <- m a
p
  let r :: a
r = a -> a -> a
f a
x a
y
  m (a -> a -> a) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixL m (a -> a -> a)
op m a
p a
r m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | @pInfixR op p x@ parses right-associative infix operator @op@, then
-- term with parser @p@, then returns result of the operator application on
-- @x@ and the term.

pInfixR :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a
pInfixR :: forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixR m (a -> a -> a)
op m a
p a
x = do
  a -> a -> a
f <- m (a -> a -> a)
op
  a
y <- m a
p m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> m (a -> a -> a) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (a -> a -> a) -> m a -> a -> m a
pInfixR m (a -> a -> a)
op m a
p a
r m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
f a
x a
y

-- | Parse the first separator of a ternary operator

pTernR :: MonadPlus m => m (m (a -> a -> a -> a)) -> m a -> a -> m a
pTernR :: forall (m :: * -> *) a.
MonadPlus m =>
m (m (a -> a -> a -> a)) -> m a -> a -> m a
pTernR m (m (a -> a -> a -> a))
sep1 m a
p a
x = do
  m (a -> a -> a -> a)
sep2 <- m (m (a -> a -> a -> a))
sep1
  a
y <- m a
p m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> m (m (a -> a -> a -> a)) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (m (a -> a -> a -> a)) -> m a -> a -> m a
pTernR m (m (a -> a -> a -> a))
sep1 m a
p a
r m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  a -> a -> a -> a
f <- m (a -> a -> a -> a)
sep2
  a
z <- m a
p m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> m (m (a -> a -> a -> a)) -> m a -> a -> m a
forall (m :: * -> *) a.
MonadPlus m =>
m (m (a -> a -> a -> a)) -> m a -> a -> m a
pTernR m (m (a -> a -> a -> a))
sep1 m a
p a
r m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> a
f a
x a
y a
z

type Batch m a =
  ( [m (a -> a -> a)]
  , [m (a -> a -> a)]
  , [m (a -> a -> a)]
  , [m (a -> a)]
  , [m (a -> a)]
  , [m (m (a -> a -> a -> a))]
  )

-- | A helper to separate various operators (binary, unary, and according to
-- associativity) and return them in a tuple.

splitOp :: Operator m a -> Batch m a -> Batch m a
splitOp :: forall (m :: * -> *) a. Operator m a -> Batch m a -> Batch m a
splitOp (InfixR  m (a -> a -> a)
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = (m (a -> a -> a)
opm (a -> a -> a) -> [m (a -> a -> a)] -> [m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern)
splitOp (InfixL  m (a -> a -> a)
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = ([m (a -> a -> a)]
r, m (a -> a -> a)
opm (a -> a -> a) -> [m (a -> a -> a)] -> [m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern)
splitOp (InfixN  m (a -> a -> a)
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, m (a -> a -> a)
opm (a -> a -> a) -> [m (a -> a -> a)] -> [m (a -> a -> a)]
forall a. a -> [a] -> [a]
:[m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern)
splitOp (Prefix  m (a -> a)
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, m (a -> a)
opm (a -> a) -> [m (a -> a)] -> [m (a -> a)]
forall a. a -> [a] -> [a]
:[m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern)
splitOp (Postfix m (a -> a)
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, m (a -> a)
opm (a -> a) -> [m (a -> a)] -> [m (a -> a)]
forall a. a -> [a] -> [a]
:[m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern)
splitOp (TernR   m (m (a -> a -> a -> a))
op) ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, [m (m (a -> a -> a -> a))]
tern) = ([m (a -> a -> a)]
r, [m (a -> a -> a)]
l, [m (a -> a -> a)]
n, [m (a -> a)]
pre, [m (a -> a)]
post, m (m (a -> a -> a -> a))
opm (m (a -> a -> a -> a))
-> [m (m (a -> a -> a -> a))] -> [m (m (a -> a -> a -> a))]
forall a. a -> [a] -> [a]
:[m (m (a -> a -> a -> a))]
tern)