parsers-0.6: src/Text/Parser/Expression.hs
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.Parser.Expression
-- Copyright : (c) Edward Kmett 2011-2012
-- (c) Paolo Martini 2007
-- (c) Daan Leijen 1999-2001,
-- License : BSD-style (see the LICENSE file)
--
-- Maintainer : ekmett@gmail.com
-- Stability : experimental
-- Portability : non-portable
--
-- A helper module to parse \"expressions\".
-- Builds a parser given a table of operators and associativities.
--
-----------------------------------------------------------------------------
module Text.Parser.Expression
( Assoc(..), Operator(..), OperatorTable
, buildExpressionParser
) where
import Control.Applicative
import Text.Parser.Combinators
import Data.Data hiding (Infix, Prefix)
import Data.Ix
-----------------------------------------------------------
-- Assoc and OperatorTable
-----------------------------------------------------------
-- | This data type specifies the associativity of operators: left, right
-- or none.
data Assoc
= AssocNone
| AssocLeft
| AssocRight
deriving (Eq,Ord,Show,Read,Ix,Enum,Bounded,Data,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 m a
= Infix (m (a -> a -> a)) Assoc
| Prefix (m (a -> a))
| Postfix (m (a -> a))
-- | An @OperatorTable m a@ 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 a different associativity).
type OperatorTable m a = [[Operator 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 (fun <* reservedOp name) assoc
-- > prefix name fun = Prefix (fun <* reservedOp name)
-- > postfix name fun = Postfix (fun <* reservedOp name)
buildExpressionParser :: (Parsing m, Monad m)
=> OperatorTable m a
-> m a
-> m a
buildExpressionParser operators simpleExpr
= foldl makeParser simpleExpr operators
where
makeParser term ops
= let (rassoc,lassoc,nassoc,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops
rassocOp = choice rassoc
lassocOp = choice lassoc
nassocOp = choice nassoc
prefixOp = choice prefix <?> ""
postfixOp = choice postfix <?> ""
ambiguous assoc op= try $ op *> fail ("ambiguous use of a " ++ assoc ++ " associative operator")
ambiguousRight = ambiguous "right" rassocOp
ambiguousLeft = ambiguous "left" lassocOp
ambiguousNon = ambiguous "non" nassocOp
preTermP = try (do { pre <- prefixP; x <- term; return $ pre x })
<|> term
termP = do { x <- preTermP
; post <- postfixP
; return (post x)
}
postfixP = postfixOp <|> return id
prefixP = prefixOp <|> return id
rassocP x = do{ f <- rassocOp
; y <- termP >>= rassocP1
; return (f x y)
}
<|> ambiguousLeft
<|> ambiguousNon
-- <|> return x
rassocP1 x = rassocP x <|> return x
lassocP x = do{ f <- lassocOp
; y <- termP
; lassocP1 (f x y)
}
<|> ambiguousRight
<|> ambiguousNon
-- <|> return x
lassocP1 x = lassocP x <|> return x
nassocP x = do{ f <- nassocOp
; y <- termP
; ambiguousRight
<|> ambiguousLeft
<|> ambiguousNon
<|> return (f x y)
}
-- <|> return x
in do{ x <- termP
; rassocP x <|> lassocP x <|> nassocP x <|> return x
<?> "operator"
}
splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix)
= case assoc of
AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix)
AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix)
AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix)
splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix)
= (rassoc,lassoc,nassoc,op:prefix,postfix)
splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix)
= (rassoc,lassoc,nassoc,prefix,op:postfix)