{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Parsec.Expr
-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
-- License     :  BSD-style (see the LICENSE file)
--
-- Maintainer  :  derek.a.elkins@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- A helper module to parse \"expressions\".
-- Builds a parser given a table of operators and associativities.
--
-----------------------------------------------------------------------------

module Text.Parsec.Expr
    ( Assoc(..), Operator(..), OperatorTable
    , buildExpressionParser
    ) where

import Data.Typeable ( Typeable )

import Text.Parsec.Prim
import Text.Parsec.Combinator

-----------------------------------------------------------
-- Assoc and OperatorTable
-----------------------------------------------------------

-- |  This data type specifies the associativity of operators: left, right
-- or none.

data Assoc                = AssocNone
                          | AssocLeft
                          | AssocRight
   deriving ( Typeable )

-- | 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 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

-- | An @OperatorTable s u m a@ is a list of @Operator s u m a@
-- lists. The list is ordered in descending
-- precedence. All operators in one list have the same precedence (but
-- may have a different associativity).

type OperatorTable s u m a = [[Operator s u m a]]

-----------------------------------------------------------
-- Convert an OperatorTable and basic term parser into
-- a full fledged expression parser
-----------------------------------------------------------

-- | @buildExpressionParser table term@ builds an expression parser for
-- terms @term@ with operators from @table@, taking the associativity
-- and precedence specified in @table@ into account. Prefix and postfix
-- operators of the same precedence can only occur once (i.e. @--2@ is
-- not allowed if @-@ is prefix negate). Prefix and postfix operators
-- of the same precedence associate to the left (i.e. if @++@ is
-- postfix increment, than @-2++@ equals @-1@, not @-3@).
--
-- The @buildExpressionParser@ takes care of all the complexity
-- involved in building expression parser. Here is an example of an
-- expression parser that handles prefix signs, postfix increment and
-- basic arithmetic.
--
-- >  expr    = buildExpressionParser table term
-- >          <?> "expression"
-- >
-- >  term    =  parens expr
-- >          <|> natural
-- >          <?> "simple expression"
-- >
-- >  table   = [ [prefix "-" negate, prefix "+" id ]
-- >            , [postfix "++" (+1)]
-- >            , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]
-- >            , [binary "+" (+) AssocLeft, binary "-" (-)   AssocLeft ]
-- >            ]
-- >
-- >  binary  name fun assoc = Infix (do{ reservedOp name; return fun }) assoc
-- >  prefix  name fun       = Prefix (do{ reservedOp name; return fun })
-- >  postfix name fun       = Postfix (do{ reservedOp name; return fun })

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
    = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall {t :: * -> *} {s} {m :: * -> *} {t} {t} {t} {t} {t} {u} {b}.
(Foldable t, Stream s m t, Stream s m t, Stream s m t,
 Stream s m 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)      = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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   = 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   = 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   = 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   = 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  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  = 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 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= forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$
                                  do{ a
_ <- ParsecT s u m a
op; forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"ambiguous use of a " forall a. [a] -> [a] -> [a]
++ String
assoc
                                                     forall a. [a] -> [a] -> [a]
++ String
" associative operator")
                                    }

              ambiguousRight :: ParsecT s u m a
ambiguousRight    = 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     = 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      = 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
                             ; 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 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id

              prefixP :: ParsecT s u m (b -> b)
prefixP    = ParsecT s u m (b -> b)
prefixOp forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return 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 }
                             ; forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
f b
x b
y)
                             }
                           forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousLeft
                           forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousNon
                           -- <|> return x

              rassocP1 :: b -> ParsecT s u m b
rassocP1 b
x = b -> ParsecT s u m b
rassocP b
x  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m 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)
                             }
                           forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousRight
                           forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousNon
                           -- <|> return x

              lassocP1 :: b -> ParsecT s u m b
lassocP1 b
x = b -> ParsecT s u m b
lassocP b
x forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m 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
                             ;    forall {a}. ParsecT s u m a
ambiguousRight
                              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousLeft
                              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. ParsecT s u m a
ambiguousNon
                              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
f b
x b
y)
                             }
                           -- <|> return x

           in  do{ b
x <- ParsecT s u m b
termP
                 ; b -> ParsecT s u m b
rassocP b
x 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 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 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
                   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)
opforall 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)
opforall 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)
opforall 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)
opforall 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)
opforall a. a -> [a] -> [a]
:[ParsecT s u m (a -> a)]
postfix)