Commit f757c731 authored by Bastian Kauschke's avatar Bastian Kauschke

printParseableFunctor: omit unnecessary braces

parent 3c59ac8e
......@@ -39,4 +39,10 @@ printInner _ [] = mempty
data PrintConfig = PrintConfig { withName :: Build.Builder -> Build.Builder }
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
......@@ -27,13 +27,18 @@ inner f = (foldMap getChild f, print (fmap printChild f))
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')))
printParseableFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (print (fmap (printInner (precedence f')) 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) <> ")"
printInner :: (Printable f, Foldable f, Functor f) => Int -> FunctorExpression f Sort -> Build.Builder
printInner _ Variable = "X"
printInner prec (Functor _ inner) =
let inner_prec = precedence inner
in if inner_prec > prec
then print (fmap (printInner inner_prec) inner)
else "(" <> print (fmap (printInner inner_prec) inner) <> ")"
printParseableFunctor Variable = "X"
......@@ -24,19 +24,22 @@ import Copar.Functors.MonoidValued ( maxIntValued
import Copar.Functors.SomeFunctor
registeredFunctors :: [[FunctorDescription SomeFunctor]]
registeredFunctors =
[ [ someFunctor maxIntValued
, someFunctor minIntValued
, someFunctor maxRealValued
, someFunctor minRealValued
, someFunctor andWordValued
, someFunctor orWordValued
registeredFunctors = -- precedence:
[ [ someFunctor maxIntValued -- 250
, someFunctor minIntValued -- 240
, someFunctor maxRealValued -- 230
, someFunctor minRealValued -- 220
, someFunctor andWordValued -- 210
, someFunctor orWordValued -- 200
]
, [ someFunctor intValued
, someFunctor realValued
, someFunctor complexValued
, someFunctor rationalValued
, [ someFunctor intValued -- 150
, someFunctor realValued -- 140
, someFunctor complexValued -- 130
, someFunctor rationalValued -- 120
]
, [someFunctor powerset, someFunctor bag, someFunctor distribution]
, [someFunctor polynomial]
, [someFunctor powerset -- 50
, someFunctor bag -- 40
, someFunctor distribution -- 30
]
, [someFunctor polynomial] -- 10
]
......@@ -66,8 +66,11 @@ newtype AbsorbingPolynomial f a = AbsorbingPolynomial (Polynomial (Inner f a))
deriving (Functor, Foldable, Traversable)
instance (Printable f) => Printable (AbsorbingPolynomial f) where
precedence _ = 10
printMe cfg (AbsorbingPolynomial poly) = withName cfg "AbsorbingPolynomial" <> printPolynomial cfg ((\case
Direct a -> a
-- FIXME: We could skip the braces in some cases.
Absorbed inner -> "(" <> printMe cfg inner <> ")"
) <$> poly)
......
......@@ -36,6 +36,8 @@ newtype Bag a = Bag a
deriving (Functor,Foldable,Traversable)
instance Printable Bag where
precedence _ = 40
printMe cfg (Bag x) = withName cfg "Bag" <> "B" <> x
bag :: FunctorDescription Bag
......
......@@ -32,6 +32,8 @@ newtype Distribution x = Distribution x
deriving (Functor, Foldable, Traversable)
instance Printable Distribution where
precedence _ = 30
printMe cfg (Distribution x) = withName cfg "Distribution" <> "D" <> x
distribution :: FunctorDescription Distribution
......
......@@ -55,17 +55,26 @@ 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 (Ratio Int)) where
printMe cfg (GroupValued x) = withName cfg "Rational-valued" <> "Q^" <> 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
intValued :: FunctorDescription (GroupValued Int)
intValued = FunctorDescription
......
......@@ -53,21 +53,33 @@ 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
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
......
......@@ -97,6 +97,8 @@ $(deriveShow1 ''Factor)
$(deriveShow1 ''Polynomial)
instance Printable Polynomial where
precedence _ = 10
printMe cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
......
......@@ -37,6 +37,8 @@ $(deriveShow1 ''Powerset)
$(deriveEq1 ''Powerset)
instance Printable Powerset where
precedence _ = 50
printMe cfg (Powerset x) = withName cfg "Powerset" <> "P" <> x
powerset :: FunctorDescription Powerset
......
......@@ -72,6 +72,8 @@ instance Eq1 SomeFunctor where
Just HRefl -> liftEq eq' lhs rhs
instance Printable SomeFunctor where
precedence (SomeFunctor x) = precedence x
printMe cfg (SomeFunctor x) = printMe cfg x
-- | Apply a natural transformation under the 'SomeFunctor'.
......
......@@ -24,11 +24,17 @@ printParseableFunctorSpec = describe "printParseableFunctor" $ do
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
let res = parseFunctor "" s
in do
res `shouldSatisfy` isRight
res `shouldBe` (res >>= idFunctor)
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_eq s expected = it (unpack ("returns `" <> expected <> "` for `" <> s <> "`")) $
let res = printParseableFunctor <$> (parseFunctor "" s)
in do
res `shouldSatisfy` isRight
res `shouldSatisfy` \res -> fromRight False ((== expected) <$> res)
it_is_id "D(PX)"
it_is_id "{n, f}xPX"
......@@ -36,5 +42,6 @@ printParseableFunctorSpec = describe "printParseableFunctor" $ do
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)"
it_is_eq "DPX" "DPX"
it_is_eq "D({f,n}xP(DX)^{a, b, c}+({f, n}xX + (Z, min)^({f ,n})))" "D({f, n}xP(DX)^{a, b, c} + ({f, n}xX + (Z, min)^({f, n})))"
it_is_eq "(Z, min)^((R, min)^(Z, min)^({f, n} x DX))" "(Z, min)^((R, min)^(Z, min)^({f, n}xDX))"
Markdown is supported
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