Commit 9860ade9 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

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.
parent 558310f7
{-# 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
......@@ -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)
......
......@@ -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)
......
......@@ -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))
......
......@@ -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
......
......@@ -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 = ()
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment