{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
data Assoc
= AssocNone
| AssocLeft
| AssocRight
deriving (Assoc -> Assoc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assoc -> Assoc -> Bool
$c/= :: Assoc -> Assoc -> Bool
== :: Assoc -> Assoc -> Bool
$c== :: Assoc -> Assoc -> Bool
Eq,Eq Assoc
Assoc -> Assoc -> Bool
Assoc -> Assoc -> Ordering
Assoc -> Assoc -> Assoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Assoc -> Assoc -> Assoc
$cmin :: Assoc -> Assoc -> Assoc
max :: Assoc -> Assoc -> Assoc
$cmax :: Assoc -> Assoc -> Assoc
>= :: Assoc -> Assoc -> Bool
$c>= :: Assoc -> Assoc -> Bool
> :: Assoc -> Assoc -> Bool
$c> :: Assoc -> Assoc -> Bool
<= :: Assoc -> Assoc -> Bool
$c<= :: Assoc -> Assoc -> Bool
< :: Assoc -> Assoc -> Bool
$c< :: Assoc -> Assoc -> Bool
compare :: Assoc -> Assoc -> Ordering
$ccompare :: Assoc -> Assoc -> Ordering
Ord,Int -> Assoc -> ShowS
[Assoc] -> ShowS
Assoc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assoc] -> ShowS
$cshowList :: [Assoc] -> ShowS
show :: Assoc -> String
$cshow :: Assoc -> String
showsPrec :: Int -> Assoc -> ShowS
$cshowsPrec :: Int -> Assoc -> ShowS
Show,ReadPrec [Assoc]
ReadPrec Assoc
Int -> ReadS Assoc
ReadS [Assoc]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Assoc]
$creadListPrec :: ReadPrec [Assoc]
readPrec :: ReadPrec Assoc
$creadPrec :: ReadPrec Assoc
readList :: ReadS [Assoc]
$creadList :: ReadS [Assoc]
readsPrec :: Int -> ReadS Assoc
$creadsPrec :: Int -> ReadS Assoc
Read,Ord Assoc
(Assoc, Assoc) -> Int
(Assoc, Assoc) -> [Assoc]
(Assoc, Assoc) -> Assoc -> Bool
(Assoc, Assoc) -> Assoc -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (Assoc, Assoc) -> Int
$cunsafeRangeSize :: (Assoc, Assoc) -> Int
rangeSize :: (Assoc, Assoc) -> Int
$crangeSize :: (Assoc, Assoc) -> Int
inRange :: (Assoc, Assoc) -> Assoc -> Bool
$cinRange :: (Assoc, Assoc) -> Assoc -> Bool
unsafeIndex :: (Assoc, Assoc) -> Assoc -> Int
$cunsafeIndex :: (Assoc, Assoc) -> Assoc -> Int
index :: (Assoc, Assoc) -> Assoc -> Int
$cindex :: (Assoc, Assoc) -> Assoc -> Int
range :: (Assoc, Assoc) -> [Assoc]
$crange :: (Assoc, Assoc) -> [Assoc]
Ix,Int -> Assoc
Assoc -> Int
Assoc -> [Assoc]
Assoc -> Assoc
Assoc -> Assoc -> [Assoc]
Assoc -> Assoc -> Assoc -> [Assoc]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Assoc -> Assoc -> Assoc -> [Assoc]
$cenumFromThenTo :: Assoc -> Assoc -> Assoc -> [Assoc]
enumFromTo :: Assoc -> Assoc -> [Assoc]
$cenumFromTo :: Assoc -> Assoc -> [Assoc]
enumFromThen :: Assoc -> Assoc -> [Assoc]
$cenumFromThen :: Assoc -> Assoc -> [Assoc]
enumFrom :: Assoc -> [Assoc]
$cenumFrom :: Assoc -> [Assoc]
fromEnum :: Assoc -> Int
$cfromEnum :: Assoc -> Int
toEnum :: Int -> Assoc
$ctoEnum :: Int -> Assoc
pred :: Assoc -> Assoc
$cpred :: Assoc -> Assoc
succ :: Assoc -> Assoc
$csucc :: Assoc -> Assoc
Enum,Assoc
forall a. a -> a -> Bounded a
maxBound :: Assoc
$cmaxBound :: Assoc
minBound :: Assoc
$cminBound :: Assoc
Bounded,Typeable Assoc
Assoc -> Constr
Assoc -> DataType
(forall b. Data b => b -> b) -> Assoc -> Assoc
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Assoc -> u
forall u. (forall d. Data d => d -> u) -> Assoc -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Assoc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Assoc -> c Assoc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Assoc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Assoc)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Assoc -> m Assoc
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Assoc -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Assoc -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Assoc -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Assoc -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Assoc -> r
gmapT :: (forall b. Data b => b -> b) -> Assoc -> Assoc
$cgmapT :: (forall b. Data b => b -> b) -> Assoc -> Assoc
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Assoc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Assoc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Assoc)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Assoc)
dataTypeOf :: Assoc -> DataType
$cdataTypeOf :: Assoc -> DataType
toConstr :: Assoc -> Constr
$ctoConstr :: Assoc -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Assoc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Assoc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Assoc -> c Assoc
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Assoc -> c Assoc
Data,Typeable)
data Operator m a
= Infix (m (a -> a -> a)) Assoc
| Prefix (m (a -> a))
| Postfix (m (a -> a))
type OperatorTable m a = [[Operator m a]]
buildExpressionParser :: forall m a. (Parsing m, Applicative m)
=> OperatorTable m a
-> m a
-> m a
buildExpressionParser :: forall (m :: * -> *) a.
(Parsing m, Applicative m) =>
OperatorTable m a -> m a -> m a
buildExpressionParser OperatorTable m a
operators m a
simpleExpr
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {t :: * -> *}. Foldable t => m a -> t (Operator m a) -> m a
makeParser m a
simpleExpr OperatorTable m a
operators
where
makeParser :: m a -> t (Operator m a) -> m a
makeParser m a
term t (Operator m a)
ops
= let rassoc, lassoc, nassoc :: [m (a -> a -> a)]
prefix, postfix :: [m (a -> a)]
([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *} {a}.
Operator m a
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
[m (a -> a)], [m (a -> a)])
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
[m (a -> a)], [m (a -> a)])
splitOp ([],[],[],[],[]) t (Operator m a)
ops
rassocOp, lassocOp, nassocOp :: m (a -> a -> a)
rassocOp :: m (a -> a -> a)
rassocOp = forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m (a -> a -> a)]
rassoc
lassocOp :: m (a -> a -> a)
lassocOp = forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m (a -> a -> a)]
lassoc
nassocOp :: m (a -> a -> a)
nassocOp = forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m (a -> a -> a)]
nassoc
prefixOp, postfixOp :: m (a -> a)
prefixOp :: m (a -> a)
prefixOp = forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m (a -> a)]
prefix forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
""
postfixOp :: m (a -> a)
postfixOp = forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m (a -> a)]
postfix forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
""
ambiguous :: String -> m x -> m y
ambiguous :: forall x y. String -> m x -> m y
ambiguous String
assoc m x
op = forall (m :: * -> *) a. Parsing m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ m x
op forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a
empty forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> (String
"ambiguous use of a " forall a. [a] -> [a] -> [a]
++ String
assoc forall a. [a] -> [a] -> [a]
++ String
"-associative operator")
ambiguousRight, ambiguousLeft, ambiguousNon :: m y
ambiguousRight :: forall y. m y
ambiguousRight = forall x y. String -> m x -> m y
ambiguous String
"right" m (a -> a -> a)
rassocOp
ambiguousLeft :: forall y. m y
ambiguousLeft = forall x y. String -> m x -> m y
ambiguous String
"left" m (a -> a -> a)
lassocOp
ambiguousNon :: forall y. m y
ambiguousNon = forall x y. String -> m x -> m y
ambiguous String
"non" m (a -> a -> a)
nassocOp
termP :: m a
termP :: m a
termP = (m (a -> a)
prefixP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
term) forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> m (a -> a)
postfixP
postfixP :: m (a -> a)
postfixP :: m (a -> a)
postfixP = m (a -> a)
postfixOp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
prefixP :: m (a -> a)
prefixP :: m (a -> a)
prefixP = m (a -> a)
prefixOp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
rassocP, rassocP1, lassocP, lassocP1, nassocP :: m (a -> a)
rassocP :: m (a -> a)
rassocP = (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a -> a)
rassocOp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (m a
termP forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> m (a -> a)
rassocP1)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousLeft
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousNon)
rassocP1 :: m (a -> a)
rassocP1 = m (a -> a)
rassocP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
lassocP :: m (a -> a)
lassocP = ((forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a -> a)
lassocOp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
termP) forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a)
lassocP1)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousRight
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousNon)
lassocP1 :: m (a -> a)
lassocP1 = m (a -> a)
lassocP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
nassocP :: m (a -> a)
nassocP = (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a -> a)
nassocOp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
termP)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (forall y. m y
ambiguousRight
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousLeft
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall y. m y
ambiguousNon
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id)
in m a
termP forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (m (a -> a)
rassocP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (a -> a)
lassocP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (a -> a)
nassocP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id) forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"operator"
splitOp :: Operator m a
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
[m (a -> a)], [m (a -> a)])
-> ([m (a -> a -> a)], [m (a -> a -> a)], [m (a -> a -> a)],
[m (a -> a)], [m (a -> a)])
splitOp (Infix m (a -> a -> a)
op Assoc
assoc) ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
= case Assoc
assoc of
Assoc
AssocNone -> ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,m (a -> a -> a)
opforall a. a -> [a] -> [a]
:[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
Assoc
AssocLeft -> ([m (a -> a -> a)]
rassoc,m (a -> a -> a)
opforall a. a -> [a] -> [a]
:[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
Assoc
AssocRight -> (m (a -> a -> a)
opforall a. a -> [a] -> [a]
:[m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
splitOp (Prefix m (a -> a)
op) ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
= ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,m (a -> a)
opforall a. a -> [a] -> [a]
:[m (a -> a)]
prefix,[m (a -> a)]
postfix)
splitOp (Postfix m (a -> a)
op) ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,[m (a -> a)]
postfix)
= ([m (a -> a -> a)]
rassoc,[m (a -> a -> a)]
lassoc,[m (a -> a -> a)]
nassoc,[m (a -> a)]
prefix,m (a -> a)
opforall a. a -> [a] -> [a]
:[m (a -> a)]
postfix)