From 9860ade97c5922dba44f229f8a83264bf0a0d345 Mon Sep 17 00:00:00 2001
From: Hans-Peter Deifel <hpd@hpdeifel.de>
Date: Tue, 17 Jul 2018 17:43:03 +0200
Subject: [PATCH] Generalize functor expression parser
This allows to parser more complex expressions in a single
functor (like the polynomial functor), instead of only unary and
binary parsers.
The downside is that implementing a functor parser got more complex:
Each functor now has to call the `inner` parser by itself and also
handle the case where the inner parser succeeds and the outer parser
fails separately.
This design doesn't sound particularly elegant, but there is no
obvious other solution.
---
src/MA/FunctorExpression/Parser.hs | 91 ++++++++++++------------
src/MA/Functors/Bag.hs | 2 +-
src/MA/Functors/Distribution.hs | 2 +-
src/MA/Functors/FixedProduct.hs | 2 +-
src/MA/Functors/MonoidValued.hs | 4 +-
src/MA/Functors/Powerset.hs | 2 +-
src/MA/Functors/Product.hs | 2 +-
src/MA/Parser.hs | 4 +-
tests/MA/FunctorExpression/ParserSpec.hs | 9 +--
9 files changed, 58 insertions(+), 60 deletions(-)
diff --git a/src/MA/FunctorExpression/Parser.hs b/src/MA/FunctorExpression/Parser.hs
index e305491..b786df0 100644
--- a/src/MA/FunctorExpression/Parser.hs
+++ b/src/MA/FunctorExpression/Parser.hs
@@ -1,6 +1,11 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module MA.FunctorExpression.Parser
( FunctorParser(..)
+ , prefix
+ , postfix
+ , infixR
, transParser
, Precedence(..)
, functorsParser
@@ -8,6 +13,7 @@ module MA.FunctorExpression.Parser
) where
import Data.List
+import Control.Monad
import Text.Megaparsec
import qualified Text.Megaparsec.Expr as Expr
@@ -18,60 +24,51 @@ import MA.Parser.Lexer
import MA.Parser.Types
data FunctorParser f where
- Prefix :: (forall a m. ParserT m (a -> f a)) -> FunctorParser f
- Postfix :: (forall a m. ParserT m (a -> f a)) -> FunctorParser f
- InfixN :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
- InfixL :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
- InfixR :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
+ FunctorParser :: (forall a m. MonadParser m => m a -> m (Either a (f a))) -> FunctorParser f
+
+prefix :: (forall a m. MonadParser m => m (a -> f a)) -> FunctorParser f
+prefix parser = FunctorParser $ \inner -> do
+ (parser >>= \f -> Right . f <$> inner) <|> (Left <$> inner)
+
+postfix :: (forall a m. MonadParser m => m (a -> f a)) -> FunctorParser f
+postfix parser = FunctorParser $ \inner -> do
+ i <- inner
+ (parser >>= \f -> return (Right (f i))) <|> return (Left i)
+
+infixR :: (forall a m. MonadParser m => m (a -> a -> f a)) -> FunctorParser f
+infixR parser = FunctorParser $ \inner -> do
+ l <- inner
+ let p = do
+ f <- parser
+ r <- inner
+ return (Right (f l r))
+
+ p <|> return (Left l)
transParser :: (forall a. f a -> g a) -> FunctorParser f -> FunctorParser g
-transParser natTrans (Prefix p) = Prefix (fmap natTrans <$> p)
-transParser natTrans (Postfix p) = Postfix (fmap natTrans <$> p)
-transParser natTrans (InfixN p) = InfixN ((\f a b -> natTrans (f a b)) <$> p)
-transParser natTrans (InfixL p) = InfixL ((\f a b -> natTrans (f a b)) <$> p)
-transParser natTrans (InfixR p) = InfixR ((\f a b -> natTrans (f a b)) <$> p)
+transParser natTrans (FunctorParser p) =
+ -- yeah! Tripple fmap
+ FunctorParser (fmap (fmap (fmap natTrans)) p)
newtype Precedence = Precedence Int
deriving (Num, Bounded, Enum, Integral, Real, Ord, Eq, Show)
-functorsParser :: [[FunctorParser f]] -> ParserT m (FunctorExpression f Precedence)
-functorsParser functors =
- try spaceConsumer *> Expr.makeExprParser term (makeOpTable functors)
- >>= checkForFunction
+functorsParser :: forall f m. [FunctorParser f] -> ParserT m (FunctorExpression f Precedence)
+functorsParser functors = try spaceConsumer *> parseLevel (zip (reverse functors) [1..]) >>= checkForFunctor
where
- term = parens (functorsParser functors) <|> (symbol "X" >> return Variable)
+ parseLevel :: [(FunctorParser f, Precedence)] -> ParserT m (FunctorExpression f Precedence)
+ parseLevel ((FunctorParser f, i):functors) = f (parseLevel functors) >>= \case
+ Left a -> return a
+ Right fa -> return (Functor i fa)
+ parseLevel [] = variable <|> parens (functorsParser functors)
-checkForFunction ::
- FunctorExpression f Precedence -> ParserT m (FunctorExpression f Precedence)
-checkForFunction (Functor a b) = return (Functor a b)
-checkForFunction Variable = fail "Functor expression needs at least one function symbol"
-
-makeOpTable ::
- [[FunctorParser f]]
- -> [[Expr.Operator (ParserT m) (FunctorExpression f Precedence)]]
-makeOpTable table =
- let tableWithPrecedence = zip (reverse [1 .. genericLength table]) table
- in map
- (\(precedence, functors) -> map (funcToOp precedence) functors)
- tableWithPrecedence
- where
- funcToOp ::
- Precedence
- -> FunctorParser f
- -> Expr.Operator (ParserT m) (FunctorExpression f Precedence)
- funcToOp precedence funcParser =
- case funcParser of
- Prefix p -> Expr.Prefix ((Functor precedence .) <$> p)
- Postfix p -> Expr.Postfix ((Functor precedence .) <$> p)
- InfixN p -> Expr.InfixN (mkInfix precedence <$> p)
- InfixL p -> Expr.InfixL (mkInfix precedence <$> p)
- InfixR p -> Expr.InfixR (mkInfix precedence <$> p)
+ variable :: ParserT m (FunctorExpression f Precedence)
+ variable = symbol "X" >> return Variable
- mkInfix precedence f a b = Functor precedence (f a b)
+checkForFunctor ::
+ FunctorExpression f Precedence -> ParserT m (FunctorExpression f Precedence)
+checkForFunctor (Functor a b) = return (Functor a b)
+checkForFunctor Variable = fail "Functor expression needs at least one function symbol"
-parseFunctorExpression ::
- [[FunctorParser f]]
- -> String
- -> Text
- -> Either ParseErr (FunctorExpression f Precedence)
-parseFunctorExpression functors = parse (functorsParser functors)
+parseFunctorExpression :: [[FunctorParser f]] -> String -> Text -> Either ParseErr (FunctorExpression f Precedence)
+parseFunctorExpression = parse . functorsParser . concat
diff --git a/src/MA/Functors/Bag.hs b/src/MA/Functors/Bag.hs
index bce4dc6..55cc667 100644
--- a/src/MA/Functors/Bag.hs
+++ b/src/MA/Functors/Bag.hs
@@ -32,7 +32,7 @@ newtype Bag a = Bag a
deriving (Functor,Foldable,Traversable)
bag :: FunctorParser Bag
-bag = Prefix ((L.symbol "B" <|> L.symbol "Ɓ") >> pure Bag)
+bag = prefix ((L.symbol "B" <|> L.symbol "Ɓ") >> pure Bag)
type instance Label Bag = Label (MonoidValued Int)
type instance Weight Bag = Weight (MonoidValued Int)
diff --git a/src/MA/Functors/Distribution.hs b/src/MA/Functors/Distribution.hs
index f748a8a..46b3157 100644
--- a/src/MA/Functors/Distribution.hs
+++ b/src/MA/Functors/Distribution.hs
@@ -25,7 +25,7 @@ newtype Distribution x = Distribution x
deriving (Functor, Foldable, Traversable)
distribution :: FunctorParser Distribution
-distribution = Prefix ((L.symbol "D" <|> L.symbol "Ɗ") >> pure Distribution)
+distribution = prefix ((L.symbol "D" <|> L.symbol "Ɗ") >> pure Distribution)
type instance Label Distribution = Label (MonoidValued Double)
type instance Weight Distribution = Weight (MonoidValued Double)
diff --git a/src/MA/Functors/FixedProduct.hs b/src/MA/Functors/FixedProduct.hs
index 6f6126e..98d4649 100644
--- a/src/MA/Functors/FixedProduct.hs
+++ b/src/MA/Functors/FixedProduct.hs
@@ -23,7 +23,7 @@ data FixedProduct a = FixedProduct (Vector Text) a
deriving (Show,Functor,Foldable,Traversable)
fixedproduct :: FunctorParser FixedProduct
-fixedproduct = Prefix $ do
+fixedproduct = prefix $ do
labels <- L.braces (L.name `sepBy` L.comma)
void $ L.symbol "x"
return (FixedProduct (V.fromList labels))
diff --git a/src/MA/Functors/MonoidValued.hs b/src/MA/Functors/MonoidValued.hs
index cd9b5a3..f309038 100644
--- a/src/MA/Functors/MonoidValued.hs
+++ b/src/MA/Functors/MonoidValued.hs
@@ -35,11 +35,11 @@ deriving instance Foldable (MonoidValued m)
deriving instance Traversable (MonoidValued m)
intValued :: FunctorParser (MonoidValued Int)
-intValued = Prefix
+intValued = prefix
((L.symbol "Z" <|> L.symbol "ℤ") >> L.symbol "^" >> pure IntValued)
realValued :: FunctorParser (MonoidValued Double)
-realValued = Prefix
+realValued = prefix
((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure RealValued)
type instance Label (MonoidValued m) = m
diff --git a/src/MA/Functors/Powerset.hs b/src/MA/Functors/Powerset.hs
index 3ef7950..fb1ed9a 100644
--- a/src/MA/Functors/Powerset.hs
+++ b/src/MA/Functors/Powerset.hs
@@ -18,7 +18,7 @@ newtype Powerset a = Powerset a
deriving (Show,Functor,Foldable,Traversable)
powerset :: FunctorParser Powerset
-powerset = Prefix ((L.symbol "P" <|> L.symbol "Ƥ") >> pure Powerset)
+powerset = prefix ((L.symbol "P" <|> L.symbol "Ƥ") >> pure Powerset)
-- | No edge labels
type instance Label Powerset = ()
diff --git a/src/MA/Functors/Product.hs b/src/MA/Functors/Product.hs
index 29ee9d9..2c7430a 100644
--- a/src/MA/Functors/Product.hs
+++ b/src/MA/Functors/Product.hs
@@ -18,7 +18,7 @@ data Product a = Product a a
deriving (Show, Functor, Foldable, Traversable)
product :: FunctorParser Product
-product = InfixR $ do
+product = infixR $ do
void $ L.symbol "×"
return Product
diff --git a/src/MA/Parser.hs b/src/MA/Parser.hs
index 51b22c9..f8164cc 100644
--- a/src/MA/Parser.hs
+++ b/src/MA/Parser.hs
@@ -6,7 +6,6 @@ module MA.Parser
, readCoalgebraFromStdin
) where
-import Control.Monad
import Data.Bifunctor
import Data.Proxy
@@ -29,7 +28,8 @@ coalgebraParser ::
(Traversable f, ParseMorphism f)
=> [[FunctorParser f]]
-> Parser (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
-coalgebraParser = fmap annotateSorts . functorsParser >=> morphismsParser
+coalgebraParser functors =
+ functorsParser (concat functors) >>= return . annotateSorts >>= morphismsParser
-- TODO: Needs better name
type TheFunctor = Desorted SomeFunctor
diff --git a/tests/MA/FunctorExpression/ParserSpec.hs b/tests/MA/FunctorExpression/ParserSpec.hs
index e0c3042..f651dad 100644
--- a/tests/MA/FunctorExpression/ParserSpec.hs
+++ b/tests/MA/FunctorExpression/ParserSpec.hs
@@ -63,6 +63,7 @@ parseFunctorExpressionSpec = describe "parseFunctorExpression" $ do
it "handles whitespace at the begining" $
parsing `shouldSucceedOn` " Pre X"
+
-- A simple prefix parser
data PrefixFunctor a = PrefixFunctor a
@@ -73,11 +74,11 @@ instance Eq1 PrefixFunctor where
instance Show1 PrefixFunctor where
liftShowsPrec show' _ prec (PrefixFunctor x) rest
- | prec > 10 = "(PrefixFunctor" ++ show' 11 x (rest ++ ")")
- | otherwise = "PrefixFunctor" ++ show' 11 x rest
+ | prec > 10 = "(PrefixFunctor " ++ show' 11 x (rest ++ ")")
+ | otherwise = "PrefixFunctor " ++ show' 11 x rest
prefixParser :: FunctorParser PrefixFunctor
-prefixParser = Prefix (symbol "Pre" >> return PrefixFunctor)
+prefixParser = prefix (symbol "Pre" >> return PrefixFunctor)
-- A simple postfix parser
@@ -93,7 +94,7 @@ instance Show1 PostfixFunctor where
| otherwise = "PostfixFunctor " ++ show' 11 x rest
postfixParser :: FunctorParser PostfixFunctor
-postfixParser = Postfix (symbol "Post" >> return PostfixFunctor)
+postfixParser = postfix (symbol "Post" >> return PostfixFunctor)
-- List of functors
--
GitLab