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

Merge branch 'print-functor' [#23]

parents 88ad3ed0 3c59ac8e
......@@ -154,6 +154,7 @@ test-suite spec
, Copar.FunctorExpression.ParserSpec
, Copar.FunctorExpression.PrettySpec
, Copar.FunctorExpression.SortsSpec
, Copar.FunctorPrinterSpec
, Copar.Coalgebra.ParserSpec
, Copar.ParserSpec
, Copar.Parser.LexerSpec
......
......@@ -22,6 +22,9 @@ 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"
......
module Copar.FunctorExpression.Printable
( Printable (..)
, PrintConfig (..)
, printTree
, sortAsScope
) where
......@@ -35,5 +36,7 @@ printInner f (((scope, v):h):rs) =
printInner f ([]:rs) = printInner f rs
printInner _ [] = mempty
data PrintConfig = PrintConfig { withName :: Build.Builder -> Build.Builder }
class Printable f where
printMe :: f Build.Builder -> Build.Builder
printMe :: PrintConfig -> f Build.Builder -> Build.Builder
module Copar.FunctorPrinter (printFunctor, Printable) where
module Copar.FunctorPrinter (printFunctor, printParseableFunctor, Printable) where
import Data.Text as T
import Data.Text.Lazy as Lazy
......@@ -10,18 +10,30 @@ import Copar.FunctorExpression.Type (FunctorExpression (..))
printFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f 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)
-- ([('sort, subfunctor)], functor)
-> ([(Build.Builder, f (FunctorExpression f Sort))], Build.Builder)
inner f = (foldMap getChild f, printMe (fmap printChild f))
inner f = (foldMap getChild f, print (fmap printChild f))
where
print = printMe PrintConfig { withName = \name -> name <> " " }
printChild Variable = "X"
printChild (Functor sort _) = sortAsScope sort
getChild Variable = []
getChild (Functor sort f') = [(sortAsScope sort, f')]
printParseableFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> T.Text
printParseableFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (print (fmap printInner f')))
where
print :: forall f. (Printable f) => f Build.Builder -> Build.Builder
print = printMe PrintConfig { withName = \_ -> "" }
printInner :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> Build.Builder
printInner Variable = "X"
printInner (Functor _ inner) = "(" <> print (fmap printInner inner) <> ")"
printParseableFunctor Variable = "X"
......@@ -31,6 +31,7 @@ import Control.Monad.ST
import Unsafe.Coerce
import Data.Foldable
import Data.Eq.Deriving ( deriveEq1 )
import Text.Show.Deriving ( deriveShow1 )
import Data.Vector ( Vector )
import qualified Data.Vector as V
......@@ -58,20 +59,20 @@ data Inner f a = Direct a | Absorbed (f a)
deriving (Functor, Foldable, Traversable)
$(deriveShow1 ''Inner)
$(deriveEq1 ''Inner)
newtype AbsorbingPolynomial f a = AbsorbingPolynomial (Polynomial (Inner f a))
deriving (Functor, Foldable, Traversable)
instance (Printable f) => Printable (AbsorbingPolynomial f) where
printMe (AbsorbingPolynomial poly) = "AbsorbingPolynomial "
<> printPolynomial ((\case
printMe cfg (AbsorbingPolynomial poly) = withName cfg "AbsorbingPolynomial" <> printPolynomial cfg ((\case
Direct a -> a
Absorbed inner -> "(" <> printMe inner <> ")"
Absorbed inner -> "(" <> printMe cfg inner <> ")"
) <$> poly)
$(deriveShow1 ''AbsorbingPolynomial)
$(deriveEq1 ''AbsorbingPolynomial)
absorbInnerFunctors
:: Polynomial (FunctorExpression f a)
......
......@@ -36,7 +36,7 @@ newtype Bag a = Bag a
deriving (Functor,Foldable,Traversable)
instance Printable Bag where
printMe (Bag x) = "Bag B" <> x
printMe cfg (Bag x) = withName cfg "Bag" <> "B" <> x
bag :: FunctorDescription Bag
bag = FunctorDescription
......
......@@ -32,7 +32,7 @@ newtype Distribution x = Distribution x
deriving (Functor, Foldable, Traversable)
instance Printable Distribution where
printMe (Distribution x) ="Distribution D" <> x
printMe cfg (Distribution x) = withName cfg "Distribution" <> "D" <> x
distribution :: FunctorDescription Distribution
distribution = FunctorDescription
......
......@@ -55,18 +55,17 @@ deriving instance Traversable (GroupValued m)
$(deriveShow1 ''GroupValued)
instance Printable (GroupValued Int) where
printMe (GroupValued x) = "Integer-valued Z^" <> x
printMe cfg (GroupValued x) = withName cfg "Integer-valued" <> "Z^" <> x
instance Printable (GroupValued EqDouble) where
printMe (GroupValued x) = "Real-valued R^" <> x
printMe cfg (GroupValued x) = withName cfg "Real-valued" <> "R^" <> x
instance Printable (GroupValued (Ratio Int)) where
printMe (GroupValued x) = "Rational-valued Q^" <> x
printMe cfg (GroupValued x) = withName cfg "Rational-valued" <> "Q^" <> x
instance Printable (GroupValued OrderedComplex) where
printMe (GroupValued x) = "Complex-valued C^" <> x
printMe cfg (GroupValued x) = withName cfg "Complex-valued" <> "C^" <> x
intValued :: FunctorDescription (GroupValued Int)
intValued = FunctorDescription
......
......@@ -53,22 +53,22 @@ newtype SlowMonoidValued m a = SlowMonoidValued a
-- TODO We may want to change MonoidValuedDiscription to a type class,
-- this would allow us to simplify these instances.
instance Printable (SlowMonoidValued (Max Int)) where
printMe (SlowMonoidValued x) = "Max-valued (Z, max)^" <> x
printMe cfg (SlowMonoidValued x) = withName cfg "Max-valued" <> "(Z, max)^" <> x
instance Printable (SlowMonoidValued (Min Int)) where
printMe (SlowMonoidValued x) = "Min-valued (Z, min)^" <> x
printMe cfg (SlowMonoidValued x) = withName cfg "Min-valued" <> "(Z, min)^" <> x
instance Printable (SlowMonoidValued MaxDouble) where
printMe (SlowMonoidValued x) = "Max-valued (R, max)^" <> x
printMe cfg (SlowMonoidValued x) = withName cfg "Max-valued" <> "(R, max)^" <> x
instance Printable (SlowMonoidValued MinDouble) where
printMe (SlowMonoidValued x) = "Min-valued (R, min)^" <> x
printMe cfg (SlowMonoidValued x) = withName cfg "Min-valued" <> "(R, min)^" <> x
instance Printable (SlowMonoidValued (BitAnd Word64)) where
printMe (SlowMonoidValued x) = "BitAnd-valued (Word, and)^" <> x
printMe cfg (SlowMonoidValued x) = withName cfg "BitAnd-valued" <> "(Word, and)^" <> x
instance Printable (SlowMonoidValued (BitOr Word64)) where
printMe (SlowMonoidValued x) = "BitOr-valued (Word, or)^" <> x
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
......
......@@ -97,26 +97,26 @@ $(deriveShow1 ''Factor)
$(deriveShow1 ''Polynomial)
instance Printable Polynomial where
printMe poly = "Polynomial " <> printPolynomial poly
printMe cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
printPolynomial :: Polynomial Build.Builder -> Build.Builder
printPolynomial (Polynomial (Sum (prods))) = fold (NonEmpty.intersperse " + " (fmap printProduct prods))
printPolynomial :: PrintConfig -> Polynomial Build.Builder -> Build.Builder
printPolynomial cfg (Polynomial (Sum (prods))) = fold (NonEmpty.intersperse " + " (fmap (printProduct cfg) prods))
printProduct :: Product Build.Builder -> Build.Builder
printProduct (Product (factors)) = fold (NonEmpty.intersperse "x" (fmap printFactor factors))
printProduct :: PrintConfig -> Product Build.Builder -> Build.Builder
printProduct cfg (Product (factors)) = fold (NonEmpty.intersperse "x" (fmap (printFactor cfg) factors))
printFactor :: Factor Build.Builder -> Build.Builder
printFactor (Const IntSet) = "Z"
printFactor (Const NatSet) = "N"
printFactor (Const (FiniteNatSet v)) = Build.decimal v
printFactor (Const (ExplicitSet elems)) =
printFactor :: PrintConfig -> Factor Build.Builder -> Build.Builder
printFactor _ (Const IntSet) = "Z"
printFactor _ (Const NatSet) = "N"
printFactor _ (Const (FiniteNatSet v)) = Build.decimal v
printFactor _ (Const (ExplicitSet elems)) =
(V.foldl
(\s e -> s <> ", " <> Build.fromText e)
("{" <> Build.fromText (V.head elems)) (V.tail elems)
) <> "}"
printFactor (Identity a) = a
printFactor (Exponential a exp) = a <> "^" <> printExp exp
printFactor _ (Identity a) = a
printFactor _ (Exponential a exp) = a <> "^" <> printExp exp
printExp :: Exponent -> Build.Builder
printExp (FiniteNatExp v) = Build.decimal v
......
......@@ -18,6 +18,7 @@ import Data.Bits
import Text.Megaparsec
import qualified Data.Vector as V
import qualified Data.Vector.Utils as V
import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ((<+>))
......@@ -33,9 +34,10 @@ newtype Powerset a = Powerset a
deriving (Show,Functor,Foldable,Traversable)
$(deriveShow1 ''Powerset)
$(deriveEq1 ''Powerset)
instance Printable Powerset where
printMe (Powerset x) = "Powerset P" <> x
printMe cfg (Powerset x) = withName cfg "Powerset" <> "P" <> x
powerset :: FunctorDescription Powerset
powerset = FunctorDescription
......
......@@ -40,6 +40,7 @@ import Copar.RefinementInterface
type Suitable f
= ( RefinementInterface f
, Printable f
, Eq1 f
, Functor f
, Foldable f
, Traversable f
......@@ -64,9 +65,14 @@ instance Show1 SomeFunctor where
liftShowsPrec shows' showsList' pred (SomeFunctor f) =
liftShowsPrec shows' showsList' pred f
instance Printable SomeFunctor where
printMe (SomeFunctor x) = printMe x
instance Eq1 SomeFunctor where
liftEq eq' (SomeFunctor (lhs :: f' a)) (SomeFunctor (rhs :: f'' b)) =
case eqTypeRep (typeRep @f') (typeRep @f'') of
Nothing -> False
Just HRefl -> liftEq eq' lhs rhs
instance Printable SomeFunctor where
printMe cfg (SomeFunctor x) = printMe cfg x
-- | Apply a natural transformation under the 'SomeFunctor'.
--
......
module Copar.FunctorPrinterSpec (spec) where
import Test.Hspec
import Data.Bifunctor
import Data.Either
import Data.Text (unpack, Text)
import Copar.Functors.SomeFunctor
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Sorts
import Copar.FunctorPrinter
import Copar.Parser
spec :: Spec
spec = do
printParseableFunctorSpec
printParseableFunctorSpec:: Spec
printParseableFunctorSpec = describe "printParseableFunctor" $ do
let
idFunctor :: FunctorExpression SomeFunctor Sort -> Either String (FunctorExpression SomeFunctor Sort)
idFunctor = parseFunctor "" . printParseableFunctor
it_is_id :: Text -> Spec
it_is_id s = it (unpack ("is the identity for `" <> s <> "`")) $
(parseFunctor "" s) `shouldSatisfy`\res -> (res >>= idFunctor) == res && isRight res
it_is_eq :: Text -> Text -> Spec
it_is_eq s expected = it (unpack ("is the identity for `" <> s <> "`")) $
(printParseableFunctor <$> (parseFunctor "" s) `shouldSatisfy` (\res -> fromRight False ((== expected) <$> res)))
it_is_id "D(PX)"
it_is_id "{n, f}xPX"
it_is_id "D({f,n}xPX)"
it_is_id "D({f,n}xP(DX)^{a, b, c}+({f, n}xX + (Z, min)^({f ,n})))"
it_is_id "(Z, min)^X"
it_is_eq "D(PX)" "D(PX)"
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