Commit 632f9f24 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢
Browse files

Merge branch 'FunctorDescription' [#28]

parents cabf9b4c 92a63e1b
......@@ -18,8 +18,8 @@ import Copar.FunctorExpression.Sorts
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Parser
import Copar.Functors.Polynomial
import Copar.Functors.SomeFunctor (someFunctorExprParser)
import Copar.Functors
import Copar.FunctorDescription
benchmarks :: Benchmark
benchmarks = bgroup "Morphism Parser"
......@@ -38,7 +38,7 @@ benchIdentity = bgroup "Identity" $
benchMarkov :: Benchmark
benchMarkov = bgroup "Ax(R^X)" $
let
functors = map dynFunctorExprParser registeredFunctors
functors = map someFunctorExprParser registeredFunctors
Right f = annotateSorts <$> parseFunctorExpression functors "" "{a,b,c,d,e}x(R^X)"
in
[ benchParser "simple" f
......
......@@ -56,7 +56,6 @@ library
, Copar.Algorithm.Split
, Copar.FunctorExpression.Type
, Copar.FunctorExpression.Parser
, Copar.FunctorExpression.Printable
, Copar.FunctorExpression.Sorts
, Copar.FunctorExpression.Desorting
, Copar.FunctorExpression.Transform
......
......@@ -22,16 +22,12 @@ data Pair a = Pair a a
$(deriveShow1 ''Pair)
instance Printable Distribution where
printMe cfg (Pair lhs rhs) = withName cfg "Pair" <> lhs <> " x " <> rhs
pair :: FunctorDescription Pair
pair = FunctorDescription
{ name = "Pair"
, syntaxExample = "{f, n} x PX"
, description = Just "A pair of functors"
, functorExprParser = pairp
}
instance FunctorDescription Pair where
name = "Pair"
syntaxExample = "{f, n} x PX"
description = Just "A pair of functors"
functorExprParser = pairp
functorExprPrinter cfg (Pair lhs rhs) = withName cfg "Pair" <> lhs <> " x " <> rhs
pairp :: FunctorParser Pair
pairp = FunctorParser $ \inner ->
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
module Copar.FunctorDescription
( DynFunctorDescription(..)
, FunctorParser(..)
, FunctorDescription(..)
, PrintConfig(..)
, Suitable
, formatFunctorDescription
, formatFunctorDescriptions
, dynPrecedence
, dynFunctorDescription
, dynFunctorExprParser
)
where
import Control.DeepSeq (NFData(..))
import Data.Functor.Classes
import Data.Text ( Text )
import Data.Text.Prettyprint ( Doc
, (<+>)
, AnsiStyle
)
import qualified Data.Text.Prettyprint as Doc
import qualified Data.Text.Lazy.Builder as Build
import Data.Proxy
import Type.Reflection
import Copar.FunctorExpression.Parser
import Copar.Functors.SomeFunctor
import Copar.RefinementInterface
import Copar.Coalgebra.Parser.Class
import Copar.PrettyShow
type Suitable f
= ( RefinementInterface f
, ParseMorphism f
, Eq1 f
, Functor f
, FunctorDescription f
, Foldable f
, Typeable f
, Traversable f
, Show1 f
, NFData (F1 f)
, NFData (Label f)
, PrettyShow (Label f)
, PrettyShow (F1 f))
class (Suitable f) => FunctorDescription f where
class FunctorDescription f where
name :: Text
syntaxExample :: Text
description :: Maybe (Doc AnsiStyle)
precedence :: Int
functorExprParser :: FunctorParser f
functorExprPrinter :: PrintConfig -> f Build.Builder -> Build.Builder
dynFunctorDescription :: forall f. FunctorDescription f => DynFunctorDescription
dynFunctorDescription :: forall f. Suitable f => DynFunctorDescription
dynFunctorDescription = DynFunctorDescription (Proxy :: Proxy f)
data PrintConfig = PrintConfig { withName :: Build.Builder -> Build.Builder }
data DynFunctorDescription where
DynFunctorDescription :: FunctorDescription f => Proxy f -> DynFunctorDescription
DynFunctorDescription :: Suitable f => Proxy f -> DynFunctorDescription
dynPrecedence :: DynFunctorDescription -> Int
dynPrecedence (DynFunctorDescription (Proxy :: Proxy f)) = precedence @f
dynFunctorExprParser :: DynFunctorDescription -> FunctorParser SomeFunctor
dynFunctorExprParser (DynFunctorDescription (Proxy :: Proxy f)) = transParser SomeFunctor (functorExprParser @f)
formatFunctorDescription :: FunctorDescription f => Proxy f -> Doc AnsiStyle
formatFunctorDescription (Proxy :: Proxy f)= Doc.vsep
[ Doc.annotate (Doc.bold <> Doc.underlined) (Doc.pretty (name @f))
......
module Copar.FunctorExpression.Printable
( Printable (..)
, PrintConfig (..)
, printTree
, defaultPrintConfig
) where
import Data.Text.Lazy.Builder as Build
-- | Print the required skeleton for the current scope.
--
-- The current scope has already been popped of the stack.
printSkeleton :: [a] -> [[a]] -> Build.Builder
printSkeleton h xs =
foldl (\str e -> (if null e then " " else "│ ") <> str)
(if null h then "└ " else "├ ")
xs
printTree :: (a -> ([(Build.Builder, a)], Build.Builder)) -> a -> Build.Builder
printTree f head =
let (children, functor) = f head
in functor <> printInner f [children]
printInner :: (a -> ([(Build.Builder, a)], Build.Builder)) -> [[(Build.Builder, a)]] -> Build.Builder
printInner f (((scope, v):h):rs) =
"\n" <> printSkeleton h rs <> scope <> ": "
<> functor <> (printInner f (children:h:rs))
where
(children, functor) = f v
printInner f ([]:rs) = printInner f rs
printInner _ [] = mempty
data PrintConfig = PrintConfig { withName :: Build.Builder -> Build.Builder }
defaultPrintConfig :: PrintConfig
defaultPrintConfig = PrintConfig {
withName = \name -> name <> " "
}
class Printable f where
-- | The operator precedence of the given functor,
--
-- This is used to elide some unnecessary braces and should
-- be kept up to date with `registeredFunctors`.
precedence :: f a -> Int
printMe :: PrintConfig -> f Build.Builder -> Build.Builder
module Copar.FunctorPrinter (printFunctor, printParseableFunctor, Printable) where
module Copar.FunctorPrinter (printFunctor, printParseableFunctor) where
import Data.Text as T
import Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder as Build
import qualified Data.Text as T
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Builder as Build
import Copar.FunctorExpression.Printable
import Copar.FunctorExpression.Sorts (Sort, formatSortAsScope)
import Copar.FunctorExpression.Type (FunctorExpression (..))
import Copar.FunctorDescription
import Copar.Functors.SomeFunctor
printFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> T.Text
printFunctor :: FunctorExpression SomeFunctor Sort -> T.Text
printFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (printTree inner f'))
printFunctor Variable = "Variable X"
inner :: (Printable f, Foldable f, Functor f)
=> f (FunctorExpression f Sort)
inner :: SomeFunctor (FunctorExpression SomeFunctor Sort)
-- ([('sort, subfunctor)], functor)
-> ([(Build.Builder, f (FunctorExpression f Sort))], Build.Builder)
-> ([(Build.Builder, SomeFunctor (FunctorExpression SomeFunctor Sort))], Build.Builder)
inner f = (foldMap getChild f, print (fmap printChild f))
where
print = printMe PrintConfig { withName = \name -> name <> " " }
print = printSomeFunctorExpr PrintConfig { withName = \name -> name <> " " }
printChild Variable = "X"
printChild (Functor sort _) = formatSortAsScope sort
......@@ -26,19 +26,44 @@ inner f = (foldMap getChild f, print (fmap printChild f))
getChild Variable = []
getChild (Functor sort f') = [(formatSortAsScope sort, f')]
printParseableFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> T.Text
printParseableFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (print (fmap (printInner (precedence f')) f')))
printParseableFunctor :: FunctorExpression SomeFunctor Sort -> T.Text
printParseableFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (print (fmap (printInner (functorPrecedence f')) f')))
where
print :: forall f. (Printable f) => f Build.Builder -> Build.Builder
print = printMe PrintConfig { withName = \_ -> "" }
print :: SomeFunctor Build.Builder -> Build.Builder
print = printSomeFunctorExpr PrintConfig { withName = \_ -> "" }
printInner :: (Printable f, Foldable f, Functor f) => Int -> FunctorExpression f Sort -> Build.Builder
functorPrecedence :: SomeFunctor a -> Int
functorPrecedence = dynPrecedence . someFunctorDescription
printInner :: Int -> FunctorExpression SomeFunctor Sort -> Build.Builder
printInner _ Variable = "X"
printInner prec (Functor _ inner) =
let inner_prec = precedence inner
let inner_prec = dynPrecedence (someFunctorDescription inner)
in if inner_prec > prec
then print (fmap (printInner inner_prec) inner)
else "(" <> print (fmap (printInner inner_prec) inner) <> ")"
printParseableFunctor Variable = "X"
-- | Print the required skeleton for the current scope.
--
-- The current scope has already been popped of the stack.
printSkeleton :: [a] -> [[a]] -> Build.Builder
printSkeleton h xs =
foldl (\str e -> (if null e then " " else "│ ") <> str)
(if null h then "└ " else "├ ")
xs
printTree :: (a -> ([(Build.Builder, a)], Build.Builder)) -> a -> Build.Builder
printTree f head =
let (children, functor) = f head
in functor <> printInner f [children]
printInner :: (a -> ([(Build.Builder, a)], Build.Builder)) -> [[(Build.Builder, a)]] -> Build.Builder
printInner f (((scope, v):h):rs) =
"\n" <> printSkeleton h rs <> scope <> ": "
<> functor <> (printInner f (children:h:rs))
where
(children, functor) = f v
printInner f ([]:rs) = printInner f rs
printInner _ [] = mempty
\ No newline at end of file
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE UndecidableInstances #-}
......@@ -45,12 +46,14 @@ import Data.Text ( Text )
import Text.Megaparsec
import Copar.Coalgebra.Parser
import qualified Copar.Parser.Lexer as L
import qualified Copar.Parser.Lexer as L
import Copar.RefinementInterface
import Copar.Functors.Polynomial hiding ( PolyF1(..) )
import qualified Copar.Functors.SomeFunctor as SF
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Printable
import Copar.FunctorDescription
import Copar.Parser.Types
import qualified Data.Vector.Utils as V
import Data.Primitive.SmallArray
......@@ -61,22 +64,26 @@ data Inner f a = Direct a | Absorbed (f a)
$(deriveShow1 ''Inner)
$(deriveEq1 ''Inner)
newtype AbsorbingPolynomial f a = AbsorbingPolynomial (Polynomial (Inner f a))
deriving (Functor, Foldable, Traversable)
instance (Printable f) => Printable (AbsorbingPolynomial f) where
precedence _ = 10
instance FunctorDescription (AbsorbingPolynomial SF.SomeFunctor) where
name = "AbsorbingPolynomial"
syntaxExample = "2xX + X^3"
description = Nothing -- AbsorbingPolynomial is not relevant for users
precedence = 10
functorExprParser = undefined -- It is not possible to parse an AbsorbnigPolynomial directly
printMe cfg (AbsorbingPolynomial poly) =
let name = withName cfg "AbsorbingPolynomial"
functorExprPrinter cfg (AbsorbingPolynomial poly) =
let name = withName cfg "AbsorbingPolynomial"
in name <> printPolynomial cfg ((\case
Direct a -> a
-- We want to always print the surrounding braces in case functor names
-- are printed.
Absorbed inner -> if precedence inner > 10 && name == mempty
then printMe cfg inner
else "(" <> printMe cfg inner <> ")"
Absorbed inner ->
if dynPrecedence (SF.someFunctorDescription inner) > 10 && name == mempty
then SF.printSomeFunctorExpr cfg inner
else "(" <> SF.printSomeFunctorExpr cfg inner <> ")"
) <$> poly)
$(deriveShow1 ''AbsorbingPolynomial)
......
......@@ -24,7 +24,6 @@ import Data.Text.Prettyprint ((<+>))
import Copar.RefinementInterface
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import Copar.Coalgebra.Parser
import Copar.Functors.GroupValued
import Copar.FunctorDescription
......@@ -32,11 +31,6 @@ import Copar.FunctorDescription
newtype Bag a = Bag a
deriving (Functor,Foldable,Traversable)
instance Printable Bag where
precedence _ = 40
printMe cfg (Bag x) = withName cfg "Bag" <> "B" <> x
instance FunctorDescription Bag where
name = "Bag"
syntaxExample = "BX | ƁX"
......@@ -44,6 +38,8 @@ instance FunctorDescription Bag where
precedence = 40
functorExprParser = prefix ((L.symbol "B" <|> L.symbol "Ɓ") >> pure Bag)
functorExprPrinter cfg (Bag x) = withName cfg "Bag" <> "B" <> x
bagHelp :: Doc.Doc Doc.AnsiStyle
bagHelp =
Doc.reflow "This is like the Powerset functor, except that states can have \
......
......@@ -19,7 +19,6 @@ import Data.Float.Utils (EqDouble)
import Copar.Coalgebra.Parser
import Copar.FunctorDescription
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import Copar.Functors.GroupValued
import qualified Copar.Parser.Lexer as L
import Copar.RefinementInterface
......@@ -28,11 +27,6 @@ import Copar.RefinementInterface
newtype Distribution x = Distribution x
deriving (Functor, Foldable, Traversable)
instance Printable Distribution where
precedence _ = 30
printMe cfg (Distribution x) = withName cfg "Distribution" <> "D" <> x
instance FunctorDescription Distribution where
name = "Distribution"
syntaxExample = "DX | ƊX"
......@@ -41,6 +35,8 @@ instance FunctorDescription Distribution where
functorExprParser = prefix ((L.symbol "D" <|> L.symbol "Ɗ")
>> pure Distribution)
functorExprPrinter cfg (Distribution x) = withName cfg "Distribution" <> "D" <> x
distHelp :: Doc.Doc Doc.AnsiStyle
distHelp =
Doc.reflow "Coalgebras for the distribution functor correspond to markov \
......
......@@ -37,7 +37,6 @@ import qualified Data.Vector.Utils as V
import Copar.RefinementInterface
import Copar.Coalgebra.Parser
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import qualified Copar.Parser.Lexer as L
import Copar.Parser.Types
import Copar.FunctorDescription
......@@ -54,27 +53,6 @@ deriving instance Traversable (GroupValued m)
$(deriveShow1 ''GroupValued)
instance Printable (GroupValued Int) where
precedence _ = 150
printMe cfg (GroupValued x) = withName cfg "Integer-valued" <> "Z^" <> x
instance Printable (GroupValued EqDouble) where
precedence _ = 140
printMe cfg (GroupValued x) = withName cfg "Real-valued" <> "R^" <> x
instance Printable (GroupValued OrderedComplex) where
precedence _ = 130
printMe cfg (GroupValued x) = withName cfg "Complex-valued" <> "C^" <> x
instance Printable (GroupValued (Ratio Int)) where
precedence _ = 120
printMe cfg (GroupValued x) = withName cfg "Rational-valued" <> "Q^" <> x
type IntValued = GroupValued Int
instance FunctorDescription (GroupValued Int) where
......@@ -84,6 +62,7 @@ instance FunctorDescription (GroupValued Int) where
precedence = 150
functorExprParser =
prefix ((L.symbol "Z" <|> L.symbol "ℤ") >> L.symbol "^" >> pure GroupValued)
functorExprPrinter cfg (GroupValued x) = withName cfg "Integer-valued" <> "Z^" <> x
intHelp :: Doc.Doc Doc.AnsiStyle
intHelp =
......@@ -103,6 +82,7 @@ instance FunctorDescription (GroupValued EqDouble) where
precedence = 140
functorExprParser = prefix
((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure GroupValued)
functorExprPrinter cfg (GroupValued x) = withName cfg "Real-valued" <> "R^" <> x
realHelp :: Doc.Doc Doc.AnsiStyle
realHelp =
......@@ -122,6 +102,7 @@ instance FunctorDescription (GroupValued (Ratio Int)) where
precedence = 120
functorExprParser = prefix
((L.symbol "Q" <|> L.symbol "ℚ") >> L.symbol "^" >> pure GroupValued)
functorExprPrinter cfg (GroupValued x) = withName cfg "Rational-valued" <> "Q^" <> x
rationalHelp :: Doc.Doc Doc.AnsiStyle
rationalHelp =
......@@ -151,6 +132,7 @@ instance FunctorDescription (GroupValued OrderedComplex) where
precedence = 130
functorExprParser = prefix
((L.symbol "C" <|> L.symbol "ℂ") >> L.symbol "^" >> pure GroupValued)
functorExprPrinter cfg (GroupValued x) = withName cfg "Complex-valued" <> "C^" <> x
complexHelp :: Doc.Doc Doc.AnsiStyle
complexHelp =
......
......@@ -32,14 +32,13 @@ import Text.Megaparsec
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ( (<+>) )
import Data.Text ( Text )
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Vector.Utils as V
import Copar.RefinementInterface
import Copar.FunctorDescription
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import Copar.Functors.SomeFunctor
import Copar.Coalgebra.Parser
import Data.Float.Utils ( MaxDouble(..)
, MinDouble(..)
......@@ -54,37 +53,6 @@ import Data.Proxy
newtype SlowMonoidValued m a = SlowMonoidValued a
-- TODO Remove Printable in favor of FunctorDescription
instance Printable (SlowMonoidValued (Max Int)) where
precedence _ = 250
printMe cfg (SlowMonoidValued x) = withName cfg "Max-valued" <> "(Z, max)^" <> x
instance Printable (SlowMonoidValued (Min Int)) where
precedence _ = 240
printMe cfg (SlowMonoidValued x) = withName cfg "Min-valued" <> "(Z, min)^" <> x
instance Printable (SlowMonoidValued MaxDouble) where
precedence _ = 230
printMe cfg (SlowMonoidValued x) = withName cfg "Max-valued" <> "(R, max)^" <> x
instance Printable (SlowMonoidValued MinDouble) where
precedence _ = 220
printMe cfg (SlowMonoidValued x) = withName cfg "Min-valued" <> "(R, min)^" <> x
instance Printable (SlowMonoidValued (BitAnd Word64)) where
precedence _ = 210
printMe cfg (SlowMonoidValued x) = withName cfg "BitAnd-valued" <> "(Word, and)^" <> x
instance Printable (SlowMonoidValued (BitOr Word64)) where
precedence _ = 200
printMe cfg (SlowMonoidValued x) = withName cfg "BitOr-valued" <> "(Word, or)^" <> x
instance Eq1 (SlowMonoidValued m) where
liftEq f (SlowMonoidValued a1) (SlowMonoidValued a2) = f a1 a2
......@@ -125,6 +93,11 @@ instance MonoidValuedDescription m => FunctorDescription (SlowMonoidValued m) wh
>> pure SlowMonoidValued
)
functorExprPrinter cfg (SlowMonoidValued x) =
withName cfg (Build.fromText (name @(SlowMonoidValued m))) <>
"(" <> Build.fromText (head (mvSet @m)) <> ", " <> Build.fromText (mvOperation @m) <> ")^"
<> x
functorSyntax :: Text -> Text -> Text
functorSyntax s o = "(" <> s <> ", " <> o <> ")^X"
......
......@@ -55,7 +55,6 @@ import qualified Copar.Parser.Lexer as L
import Copar.Parser.Types
import Copar.RefinementInterface
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import Copar.FunctorDescription
......@@ -94,12 +93,6 @@ $(deriveEq1 ''Polynomial)
$(deriveShow1 ''Factor)
$(deriveShow1 ''Polynomial)
instance Printable Polynomial where
precedence _ = 10
printMe cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
printPolynomial :: PrintConfig -> Polynomial Build.Builder -> Build.Builder
printPolynomial cfg (Polynomial (Sum (prods))) = fold (NonEmpty.intersperse " + " (fmap (printProduct cfg) prods))
......@@ -150,6 +143,7 @@ instance FunctorDescription Polynomial where
description = Just polynomialHelp
precedence = 10
functorExprParser = polynomialp
functorExprPrinter cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
polynomialHelp :: Doc.Doc Doc.AnsiStyle
polynomialHelp =
......
......@@ -25,7 +25,6 @@ import Data.Text.Prettyprint ((<+>))
import Copar.RefinementInterface
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.FunctorExpression.Printable
import Copar.Coalgebra.Parser
import Copar.FunctorDescription
......@@ -35,11 +34,6 @@ newtype Powerset a = Powerset a
$(deriveShow1 ''Powerset)
$(deriveEq1 ''Powerset)
instance Printable Powerset where
precedence _ = 50
printMe cfg (Powerset x) = withName cfg "Powerset" <> "P" <> x
instance FunctorDescription Powerset where
name = "Powerset"
syntaxExample = "PX | ƤX"
......@@ -47,6 +41,7 @@ instance FunctorDescription Powerset where
precedence = 50
functorExprParser =
prefix ((L.symbol "P" <|> L.symbol "Ƥ") >> pure Powerset)
functorExprPrinter cfg (Powerset x) = withName cfg "Powerset" <> "P" <> x
powersetHelp :: Doc.Doc Doc.AnsiStyle
powersetHelp =
......
......@@ -10,6 +10,9 @@ module Copar.Functors.SomeFunctor
( SomeFunctor(..)
, Suitable
, transformInner
, someFunctorExprParser
, someFunctorDescription
, printSomeFunctorExpr
, SomeWeight(..)
, SomeLabel
, SomeF1
......@@ -25,30 +28,19 @@ import Unsafe.Coerce
import Data.Maybe (mapMaybe)
#endif
import Data.Functor.Classes
import Data.Proxy
import Control.DeepSeq (NFData(..))
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as Build
import Copar.Coalgebra.Parser.Class
import Copar.FunctorExpression.Printable
import Copar.FunctorExpression.Parser
import Copar.PrettyShow
import Copar.RefinementInterface
type Suitable f
= ( RefinementInterface f
, ParseMorphism f
, Printable f
, Eq1 f
, Functor f
, Foldable f