    -- |
    -- 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 a. m a -> m a -> m a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` a -> m a
    forall a. 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 b a. (b -> a -> b) -> b -> [a] -> b
    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 a b. m a -> (a -> m b) -> m b
    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 a. 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 a b. (a -> b -> b) -> b -> [a] -> b
    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
      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
      x    <- term
      post <- option id postfix
      return . post . pre $ 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
      f <- m (a -> a -> a)
    op
      y <- p
      return $ f x 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
      f <- m (a -> a -> a)
    op
      y <- p
      let r = a -> a -> a
    f a
    x a
    y
      pInfixL op p r `mplus` return 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
      f <- m (a -> a -> a)
    op
      y <- p >>= \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 a. m a -> m a -> m a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    r
      return $ f x 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
      sep2 <- m (m (a -> a -> a -> a))
    sep1
      y <- p >>= \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 a. m a -> m a -> m a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    r
      f <- sep2
      z <- p >>= \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 a. m a -> m a -> m a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    r
      return $ f x y 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)