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

Prettify functor expressions

This switches the parser for functor expressions (not yet morphisms)
from a YAML based one to a custom one, making those expressions much
more readable and giving individual functors greater flexibility to
define their own syntax.
parent 95ba4305
functors:
- FixedProduct: [box, circle, triangle]
- Powerset
functor: "{box,circle,triangle} x PX"
morphisms:
- - box # 0: s1
......
......@@ -28,6 +28,9 @@ library
, Data.BlockQueue
, Data.Partition
, Data.Partition.Common
, Text.Parser.Lexer
, Text.Parser.Types
, Text.Parser.Functor
, Parser
, Algorithm
default-language: Haskell2010
......@@ -47,6 +50,7 @@ library
, mtl
, extra
, containers
, megaparsec
executable ma
main-is: Main.hs
......
......@@ -3,21 +3,18 @@
module Data.Functors where
import Control.Arrow ((&&&))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import Data.RefinementInterface
import Data.Functors.Powerset (powerset)
import Data.Functors.FixedProduct (fixedProduct)
import Data.Functors.FixedProduct (fixedproduct)
import Text.Parser.Functor
data SomeRefinementInterface where
SomeRefinementInterface :: RefinementInterface h => h -> SomeRefinementInterface
registeredFunctors :: HashMap Text RefinableFunctor
registeredFunctors = HM.fromList $ map (name &&& id)
[ powerset
, fixedProduct
registeredFunctors :: [[SomeFunctorParser]]
registeredFunctors =
[
[f powerset]
, [f fixedproduct]
]
where
f :: RefinementInterface a => FunctorParser a -> SomeFunctorParser
f = SomeFunctorParser
......@@ -3,7 +3,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Functors.FixedProduct where
module Data.Functors.FixedProduct (fixedproduct) where
import Control.Monad (void)
import qualified Data.Yaml as Yaml
import qualified Data.Vector as V
......@@ -14,10 +16,19 @@ import Data.Text (Text)
import Data.RefinementInterface
import qualified Data.MorphismEncoding as Encoding
import Data.MorphismEncoding (Edge(Edge))
import Text.Parser.Functor
import qualified Text.Parser.Lexer as L
import Text.Megaparsec
data FixedProduct = FixedProduct (Vector Text)
deriving (Show)
fixedproduct :: FunctorParser FixedProduct
fixedproduct = Prefix $ do
labels <- L.braces (L.name `sepBy` L.comma)
void $ L.symbol "x"
return (FixedProduct (V.fromList labels))
data Three = ToSub | ToCompound | ToRest
deriving (Show, Eq, Ord)
......@@ -59,11 +70,3 @@ instance RefinementInterface FixedProduct where
(False, False) -> ToRest
in
((tag, toS), (tag, three), (tag, not toS && toC))
fixedProduct :: RefinableFunctor
fixedProduct = RefinableFunctor
{ name = "FixedProduct"
-- FIXME Ensure that labels are unique
, parseArguments = ArgumentParser $ \val ->
(FixedProduct . V.fromList) <$> Yaml.parseJSON val
}
......@@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Data.Functors.Powerset where
module Data.Functors.Powerset (powerset) where
import Data.Vector (Vector)
import qualified Data.Vector as V
......@@ -11,10 +11,15 @@ import qualified Data.Yaml as Yaml
import Data.RefinementInterface
import qualified Data.MorphismEncoding as Encoding
import Text.Parser.Functor
import qualified Text.Parser.Lexer as L
data Powerset = Powerset
deriving (Show)
powerset :: FunctorParser Powerset
powerset = Prefix (L.symbol "P" >> pure Powerset)
instance RefinementInterface Powerset where
-- | No edge labels
type Label Powerset = ()
......@@ -54,9 +59,3 @@ instance RefinementInterface Powerset where
weightToCwithoutS = (toRest + toS, toCwithoutS)
in
(weightToS, h3, weightToCwithoutS)
powerset :: RefinableFunctor
powerset = RefinableFunctor
{ name = "Powerset"
, parseArguments = NoArguments Powerset
}
......@@ -32,3 +32,6 @@ class (Show h, Show (Label h), Show (H1 h), Show (Weight h), Ord (H1 h), Ord (H3
parse :: h -> Vector Yaml.Value -> Yaml.Parser (Encoding (Label h) (H1 h))
init :: H1 h -> [Label h] -> Weight h
update :: [Label h] -> Weight h -> (Weight h, H3 h, Weight h)
data SomeRefinementInterface where
SomeRefinementInterface :: RefinementInterface h => h -> SomeRefinementInterface
......@@ -13,59 +13,40 @@ import qualified Data.Yaml as Yaml
import Data.Yaml ((.:))
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.ByteString (ByteString)
import qualified Text.Megaparsec as Megaparsec
import Data.RefinementInterface
import Data.Functors (registeredFunctors)
import Data.Sort
import Text.Parser.Functor
data SomeRefinementInterface where
SRI :: RefinementInterface h => h -> SomeRefinementInterface
deriving instance Show SomeRefinementInterface
newtype RFIList = RFIList { fromRFIList :: Vector SomeRefinementInterface }
instance Yaml.FromJSON RFIList where
parseJSON = Yaml.withArray "list of functors" $ \arr ->
RFIList <$> mapM parseFunctor arr
parseFunctor :: Yaml.Value -> Yaml.Parser SomeRefinementInterface
parseFunctor value =
case value of
Yaml.String name -> case HashMap.lookup name registeredFunctors of
Nothing -> failUnknownFunctor name
Just (RefinableFunctor { parseArguments = NoArguments h }) -> return (SRI h)
_ -> fail ("Functor" ++ T.unpack name ++ "requires an argument")
Yaml.Object obj -> case HashMap.toList obj of
[(name, argument)] -> case HashMap.lookup name registeredFunctors of
Nothing -> failUnknownFunctor name
Just (RefinableFunctor { parseArguments = ArgumentParser parser }) -> SRI <$> parser argument
_ -> fail ("Functor" ++ T.unpack name ++ "doesn't have arguments")
_ -> failIllegalJson
_ -> failIllegalJson
parseJSON = Yaml.withText "functor expression" $ \expr -> do
let res = Megaparsec.parse
(functorsParser registeredFunctors)
"functor expression"
expr
where
failUnknownFunctor name = fail ("Functor " ++ T.unpack name ++ " not found")
failIllegalJson = fail "Illegal functor specification"
case res of
Left err -> fail $ "Invalid functor expression: " ++ Megaparsec.parseErrorPretty err
Right interfaces -> return (RFIList (V.fromList interfaces))
newtype CoalgebraSpecification = CoalgebraSpecification { fromCoalg :: Vector Morphism }
deriving (Show)
instance Yaml.FromJSON CoalgebraSpecification where
parseJSON = Yaml.withObject "coalgebra" $ \obj -> do
functors <- fromRFIList <$> obj .: "functors"
functors <- fromRFIList <$> obj .: "functor"
morphisms :: Vector (Vector Yaml.Value) <- obj .: "morphisms"
-- TODO Ensure functors and morphisms are of equal length
encodings <- forM (V.zip functors morphisms) $ \(SRI functor, yamlValue) -> do
Morphism functor <$> parse functor yamlValue
encodings <- forM (V.zip functors morphisms) $
\(SomeRefinementInterface functor, yamlValue) -> do
Morphism functor <$> parse functor yamlValue
return (CoalgebraSpecification encodings)
......
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Parser.Functor
( FunctorParser(..)
, SomeFunctorParser(..)
, functorsParser
)
where
import Text.Megaparsec
import qualified Text.Megaparsec.Expr as Expr
import Text.Parser.Types
import Text.Parser.Lexer
import Data.RefinementInterface
data FunctorParser a = Prefix (Parser a) | Postfix (Parser a)
deriving (Functor)
data SomeFunctorParser where
SomeFunctorParser :: RefinementInterface a => FunctorParser a -> SomeFunctorParser
makeOpTable :: [[SomeFunctorParser]] -> [[Expr.Operator Parser [SomeRefinementInterface]]]
makeOpTable = map (map funcToOp)
where
funcToOp :: SomeFunctorParser -> Expr.Operator Parser [SomeRefinementInterface]
funcToOp (SomeFunctorParser funcParser) = case funcParser of
Prefix p -> Expr.Prefix (((:) . SomeRefinementInterface) <$> p)
Postfix p -> Expr.Postfix (((:) . SomeRefinementInterface) <$> p)
functorsParser :: [[SomeFunctorParser]] -> Parser [SomeRefinementInterface]
functorsParser functors = Expr.makeExprParser term (makeOpTable functors)
where
term = parens (functorsParser functors) <|> (symbol "X" >> return [])
{-# LANGUAGE OverloadedStrings #-}
module Text.Parser.Lexer
( spaceConsumer
, symbol
, lexeme
, braces
, parens
, angles
, semicolon
, comma
, colon
, dot
, name
) where
import Data.Text (Text)
import qualified Data.Text as T
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Parser.Types
spaceConsumer :: Parser ()
spaceConsumer = L.space space1 empty empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer
symbol :: Text -> Parser Text
symbol = L.symbol spaceConsumer
braces :: Parser a -> Parser a
braces = between (symbol "{") (symbol "}")
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")
angles :: Parser a -> Parser a
angles = between (symbol "<") (symbol ">")
semicolon :: Parser Text
semicolon = symbol ";"
comma :: Parser Text
comma = symbol ","
colon :: Parser Text
colon = symbol ":"
dot :: Parser Text
dot = symbol "."
name :: Parser Text
name = T.pack <$> ((:) <$> letterChar <*> many alphaNumChar)
module Text.Parser.Types
( Parser
) where
import Data.Void (Void)
import Text.Megaparsec
import Data.Text (Text)
type Parser = Parsec Void Text
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