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

Merge branch 'remove-pretty' [#25]

parents bc724890 27e54c1e
......@@ -56,7 +56,6 @@ library
, Copar.Algorithm.Split
, Copar.FunctorExpression.Type
, Copar.FunctorExpression.Parser
, Copar.FunctorExpression.Pretty
, Copar.FunctorExpression.Printable
, Copar.FunctorExpression.Sorts
, Copar.FunctorExpression.Desorting
......@@ -152,7 +151,6 @@ test-suite spec
, Copar.Functors.MonoidValuedSpec
, Copar.Functors.AbsorbingPolynomialSpec
, Copar.FunctorExpression.ParserSpec
, Copar.FunctorExpression.PrettySpec
, Copar.FunctorExpression.SortsSpec
, Copar.FunctorPrinterSpec
, Copar.Coalgebra.ParserSpec
......
......@@ -65,7 +65,7 @@ refine Proxy encoding enableOptimization = do
Partition.freeze (partition state)
-- | Seme as 'refine', but also reports some statistics about the algorithm's
-- | Same as 'refine', but also reports some statistics about the algorithm's
-- execution.
refineWithStats
:: forall f
......
......@@ -44,7 +44,7 @@ infixR parser = FunctorParser $ \inner -> do
transParser :: (forall a. f a -> g a) -> FunctorParser f -> FunctorParser g
transParser natTrans (FunctorParser p) =
-- yeah! Tripple fmap
FunctorParser (fmap (fmap (fmap natTrans)) p)
FunctorParser (fmap (fmap (fmap natTrans)) p)
newtype Precedence = Precedence Int
deriving (Num, Bounded, Enum, Integral, Real, Ord, Eq, Show)
......
module Copar.FunctorExpression.Pretty
( PrettyPrint(..)
, pretty
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Builder as Build
import Data.Text.Lazy.Builder (Builder)
import Copar.FunctorExpression.Parser (Precedence)
import Copar.FunctorExpression.Type
class PrettyPrint f where
prettyPrint :: f Builder -> Builder
pretty :: (PrettyPrint f, Functor f) => FunctorExpression f Precedence -> Text
pretty = Build.toLazyText . prettyImpl 0
prettyImpl ::
(PrettyPrint f, Functor f)
=> Precedence
-> FunctorExpression f Precedence
-> Builder
prettyImpl precedenceOuter (Functor precedenceInner f)
| precedenceOuter >= precedenceInner = "(" <> recurse <> ")"
| otherwise = recurse
where
recurse = prettyPrint (fmap (prettyImpl precedenceInner) f)
prettyImpl _ Variable = "X"
......@@ -2,13 +2,10 @@ module Copar.FunctorExpression.Printable
( Printable (..)
, PrintConfig (..)
, printTree
, sortAsScope
, defaultPrintConfig
) where
import Data.Text.Lazy.Builder as Build
import Data.Text.Lazy.Builder.Int as Build
import Copar.FunctorExpression.Sorts (Sort)
-- | Print the required skeleton for the current scope.
--
......@@ -19,9 +16,6 @@ printSkeleton h xs =
(if null h then "└ " else "├ ")
xs
sortAsScope :: Sort -> Build.Builder
sortAsScope sort = "'" <> Build.decimal sort
printTree :: (a -> ([(Build.Builder, a)], Build.Builder)) -> a -> Build.Builder
printTree f head =
let (children, functor) = f head
......@@ -38,6 +32,11 @@ 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,
--
......
......@@ -11,20 +11,13 @@ module Copar.FunctorExpression.Sorts
, annotateSorts
-- * Extracting a sort table
, sortTable
-- * Printing a sort table
-- $printing
, printSorts
, showSorts
, formatSortAsScope
) where
import Data.Foldable
import Data.List (intersperse)
import GHC.Generics
import Control.Monad.State
import Data.Text (Text)
import qualified Data.Text.Lazy as T (toStrict)
import qualified Data.Text.Lazy.IO as TIO
import Data.Text.Lazy.Builder as Build
import Data.Text.Lazy.Builder.Int as Build
import Data.Vector (Vector)
......@@ -33,7 +26,6 @@ import qualified Data.Vector.Mutable as VM
import Control.DeepSeq (NFData)
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Pretty
import Copar.PrettyShow
-- | Sorts are basically unique integers for every sub-expression in a functor
......@@ -51,6 +43,9 @@ data Sorted a = Sorted
instance PrettyShow a => PrettyShow (Sorted a) where
prettyShow s = "(" <> prettyShow (sortedSort s) <> ", " <> prettyShow (sortedElem s) <> ")"
formatSortAsScope :: Sort -> Build.Builder
formatSortAsScope sort = "'" <> Build.decimal sort
-- | Assigns each sub-expression a different sort, starting with 1.
annotateSorts :: Traversable f => FunctorExpression f a -> FunctorExpression f Sort
annotateSorts expr = evalState (traverse anon expr) initState
......@@ -83,34 +78,3 @@ sortTable expr = V.create $ do
populateVector v (Functor sort f) = do
VM.write v (fromIntegral sort - 1) (fmap (const ()) f)
traverse_ (populateVector v) f
-- $printing
-- The functions in this section are mostly for debugging purposes.
-- | Print a table of sorts to stdout.
--
-- See 'showSorts' for details on the format of this table.
printSorts ::
(PrettyPrint f, Foldable f, Functor f) => FunctorExpression f Sort -> IO ()
printSorts = mapM_ (TIO.putStrLn . Build.toLazyText) . printSortsHelper2
-- | Format all sorts of a sorted functor expression as a table.
--
-- Table format:
--
-- > 1: Func1 X
-- > 2: Func2 X X
-- > ...
showSorts :: (PrettyPrint f, Foldable f, Functor f) => FunctorExpression f Sort -> Text
showSorts expr =
T.toStrict
(Build.toLazyText (mconcat (intersperse "\n" (printSortsHelper2 expr))))
printSortsHelper2 ::
forall f. (Functor f, Foldable f, PrettyPrint f)
=> FunctorExpression f Sort
-> [Builder]
printSortsHelper2 = map print . zip [1..] . toList . sortTable
where
print :: (Int, f ()) -> Builder
print (i, f) = Build.decimal i <> ": " <> prettyPrint (fmap (const "X") f)
......@@ -5,7 +5,7 @@ import Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder as Build
import Copar.FunctorExpression.Printable
import Copar.FunctorExpression.Sorts (Sort)
import Copar.FunctorExpression.Sorts (Sort, formatSortAsScope)
import Copar.FunctorExpression.Type (FunctorExpression (..))
printFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> T.Text
......@@ -21,10 +21,10 @@ inner f = (foldMap getChild f, print (fmap printChild f))
print = printMe PrintConfig { withName = \name -> name <> " " }
printChild Variable = "X"
printChild (Functor sort _) = sortAsScope sort
printChild (Functor sort _) = formatSortAsScope sort
getChild Variable = []
getChild (Functor sort f') = [(sortAsScope sort, f')]
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')))
......
......@@ -61,10 +61,16 @@ deriving instance Functor SomeFunctor
deriving instance Foldable SomeFunctor
deriving instance Traversable SomeFunctor
instance Show a => Show (SomeFunctor a) where
showsPrec = showsPrec1
instance Show1 SomeFunctor where
liftShowsPrec shows' showsList' pred (SomeFunctor f) =
liftShowsPrec shows' showsList' pred f
instance Eq a => Eq (SomeFunctor a) where
(==) = eq1
instance Eq1 SomeFunctor where
liftEq eq' (SomeFunctor (lhs :: f' a)) (SomeFunctor (rhs :: f'' b)) =
case eqTypeRep (typeRep @f') (typeRep @f'') of
......
{-# LANGUAGE EmptyCase #-}
module Copar.FunctorExpression.PrettySpec (spec) where
import Test.Hspec
import Data.Semigroup
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Pretty
spec :: Spec
spec = prettySpec
data Void1 a
instance PrettyPrint Void1 where
prettyPrint x = case x of
instance Functor Void1 where
fmap f x = case x of
data Powerset a = Powerset a
deriving (Functor)
instance PrettyPrint Powerset where
prettyPrint (Powerset inner) = "P " <> inner
data Distri a = Distri a
deriving (Functor)
instance PrettyPrint Distri where
prettyPrint (Distri inner) = "D " <> inner
data Quad a = Quad a
deriving (Functor)
instance PrettyPrint Quad where
prettyPrint (Quad inner) = inner <> "^2"
data SomeFunctor a where
SomeFunctor :: (PrettyPrint f, Functor f) => f a -> SomeFunctor a
instance PrettyPrint SomeFunctor where
prettyPrint (SomeFunctor f) = prettyPrint f
deriving instance Functor SomeFunctor
prettySpec :: Spec
prettySpec = describe "pretty" $ do
it "correctly prints a variable as X" $
pretty @Void1 Variable `shouldBe` "X"
it "correctly prints an expression with one prefix functor" $
pretty (Functor 1 (SomeFunctor (Powerset Variable))) `shouldBe` "P X"
it "correctly prints an expression with one suffix functor" $
pretty (Functor 1 (SomeFunctor (Quad Variable))) `shouldBe` "X^2"
it "handles nested functors of the same type" $
pretty
(Functor
1
(SomeFunctor (Powerset (Functor 1 (SomeFunctor (Powerset Variable)))))) `shouldBe`
"P (P X)"
it "gets precedence right" $ do
pretty
(Functor
1
(SomeFunctor (Powerset (Functor 2 (SomeFunctor (Distri Variable)))))) `shouldBe`
"P D X"
pretty
(Functor
2
(SomeFunctor (Powerset (Functor 1 (SomeFunctor (Distri Variable)))))) `shouldBe`
"P (D X)"
it "allows mixing prefix and suffix functors" $ do
pretty
(Functor
1
(SomeFunctor (Powerset (Functor 2 (SomeFunctor (Quad Variable)))))) `shouldBe`
"P X^2"
pretty
(Functor
2
(SomeFunctor (Quad (Functor 1 (SomeFunctor (Powerset Variable)))))) `shouldBe`
"(P X)^2"
......@@ -10,15 +10,18 @@ import Type.Reflection
import qualified Data.Vector as V
import Copar.Coalgebra.Parser
import Copar.FunctorExpression.Sorts
import Copar.FunctorExpression.Type
import Copar.FunctorExpression.Pretty
import Copar.FunctorExpression.Printable
import Copar.RefinementInterface
import Copar.Functors.SomeFunctor
spec :: Spec
spec = do
annotateSortsSpec
sortTableSpec
showSortsSpec
annotateSortsSpec :: Spec
annotateSortsSpec = describe "annotateSorts" $ do
......@@ -35,23 +38,23 @@ annotateSortsSpec = describe "annotateSorts" $ do
it "correctly annotates an expression with different functors" $
annotateSorts
(Functor () (Some (Identity (Functor () (Some (Just Variable)))))) `shouldBe`
(Functor 1 (Some (Identity (Functor 2 (Some (Just Variable))))))
(Functor () (SomeFunctor (Identity (Functor () (SomeFunctor (Just Variable)))))) `shouldBe`
(Functor 1 (SomeFunctor (Identity (Functor 2 (SomeFunctor (Just Variable))))))
it "correctly annotates an expression with two argument functors" $
annotateSorts
(Functor
()
(Some
(SomeFunctor
(Twice
(Functor () (Some (Identity Variable)))
(Functor () (Some (Identity Variable)))))) `shouldBe`
(Functor () (SomeFunctor (Identity Variable)))
(Functor () (SomeFunctor (Identity Variable)))))) `shouldBe`
(Functor
1
(Some
(SomeFunctor
(Twice
(Functor 2 (Some (Identity Variable)))
(Functor 3 (Some (Identity Variable))))))
(Functor 2 (SomeFunctor (Identity Variable)))
(Functor 3 (SomeFunctor (Identity Variable))))))
sortTableSpec :: Spec
sortTableSpec = describe "sortTable" $ do
......@@ -69,60 +72,28 @@ sortTableSpec = describe "sortTable" $ do
sortTable
(Functor
1
(Some
(Twice
(Functor 3 (Some (Identity Variable)))
(Functor 2 (Some (Just Variable)))))) `shouldBe`
V.fromList [Some (Twice () ()), Some (Just ()), Some (Identity ())]
showSortsSpec :: Spec
showSortsSpec = describe "showSorts" $ do
it "works for a single Variable" $
showSorts @Identity Variable `shouldBe` ""
it "works for a single functor" $ do
showSorts (Functor 1 (Identity Variable)) `shouldBe` "1: Identity X"
it "works for two functors" $ do
showSorts (Functor 1 (Identity (Functor 2 (Identity Variable)))) `shouldBe`
"1: Identity X\n2: Identity X"
it "works for functors with multiple arguments" $ do
showSorts
(Functor
1
(Some
(SomeFunctor
(Twice
(Functor 2 (Some (Identity Variable)))
(Functor 3 (Some (Identity Variable)))))) `shouldBe`
"1: Twice X X\n2: Identity X\n3: Identity X"
-- helpers
data SomeFunctor a where
Some
:: (Traversable f, Typeable f, Eq1 f, Show1 f, PrettyPrint f)
=> f a
-> SomeFunctor a
deriving instance Functor SomeFunctor
deriving instance Foldable SomeFunctor
deriving instance Traversable SomeFunctor
instance Show1 SomeFunctor where
liftShowsPrec show' showList' prec (Some f) = liftShowsPrec show' showList' prec f
instance Show a => Show (SomeFunctor a) where
showsPrec = showsPrec1
instance Eq a => Eq (SomeFunctor a) where
(==) = eq1
instance Eq1 SomeFunctor where
liftEq eq (Some (f1 :: tf1 a)) (Some (f2 :: tf2 b)) =
case eqTypeRep (typeRep @tf1) (typeRep @tf2) of
Nothing -> False -- different types
Just HRefl -> liftEq eq f1 f2
(Functor 3 (SomeFunctor (Identity Variable)))
(Functor 2 (SomeFunctor (Just Variable)))))) `shouldBe`
V.fromList [ SomeFunctor (Twice () ())
, SomeFunctor (Just ())
, SomeFunctor (Identity ())
]
instance Printable Identity where
precedence _ = 0
printMe cfg (Identity x) = withName cfg "Identity" <> x
type instance Label Identity = ()
type instance Weight Identity = ()
type instance F1 Identity = ()
type instance F3 Identity = ()
instance RefinementInterface Identity where
init = undefined
update = undefined
instance ParseMorphism Identity where
parseMorphismPoint = undefined
data Twice a = Twice a a
deriving (Functor, Foldable, Traversable)
......@@ -130,20 +101,34 @@ data Twice a = Twice a a
instance Eq1 Twice where
liftEq f (Twice a1 b1) (Twice a2 b2) = f a1 a2 && f b1 b2
type instance Label Twice = ()
type instance Weight Twice = ()
type instance F1 Twice = ()
type instance F3 Twice = ()
instance RefinementInterface Twice where
init = undefined
update = undefined
instance ParseMorphism Twice where
parseMorphismPoint = undefined
instance Show1 Twice where
liftShowsPrec show' _ prec (Twice a b) rest
| prec > 10 = "(Twice " ++ show' 11 a (" " ++ show' 11 b (rest ++ ")"))
| otherwise = "Twice " ++ show' 11 a (" " ++ show' 11 b rest)
instance PrettyPrint Identity where
prettyPrint (Identity x) = "Identity " <> x
instance PrettyPrint SomeFunctor where
prettyPrint (Some f) = prettyPrint f
instance PrettyPrint Twice where
prettyPrint (Twice a b) = "Twice " <> a <> " " <> b
instance PrettyPrint Maybe where
prettyPrint (Just a) = "Maybe" <> a
prettyPrint Nothing = "Nothing"
liftShowsPrec = undefined
instance Printable Twice where
precedence _ = 0
printMe cfg (Twice a b) = withName cfg "Twice" <> a <> " " <> b
type instance Label Maybe = ()
type instance Weight Maybe = ()
type instance F1 Maybe = ()
type instance F3 Maybe = ()
instance RefinementInterface Maybe where
init = undefined
update = undefined
instance ParseMorphism Maybe where
parseMorphismPoint = undefined
instance Printable Maybe where
precedence _ = 0
printMe _ maybe = case maybe of
Just x -> "Just " <> x
Nothing -> "Nothing"
......@@ -41,7 +41,15 @@ printParseableFunctorSpec = describe "printParseableFunctor" $ do
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_id "X^2"
it_is_id "P(PX)"
it_is_id "PX^2"
it_is_id "P(X^2)"
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))"
it_is_eq "P(PX)" "P(PX)"
it "correctly prints a variable as X" $
printParseableFunctor @SomeFunctor Variable `shouldBe` "X"
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