Commit 89199390 authored by Bastian Kauschke's avatar Bastian Kauschke Committed by Bastian Kauschke
Browse files

use FunctorDescription precedence

parent a5d8af4a
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
module Copar.FunctorDescription
( DynFunctorDescription(..)
, FunctorParser(..)
, FunctorDescription(..)
, Suitable
, ToDynFunctorDescription(..)
, formatFunctorDescription
, formatFunctorDescriptions
, dynPrecedence
, dynFunctorDescription
, dynFunctorExprParser
)
where
import Control.DeepSeq (NFData(..))
import Data.Functor.Classes
import Data.Text ( Text )
import Data.Text.Prettyprint ( Doc
, (<+>)
......@@ -22,28 +27,50 @@ import qualified Data.Text.Prettyprint as Doc
import Data.Proxy
import Type.Reflection
import Copar.FunctorExpression.Printable
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
, Printable 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
dynFunctorDescription :: forall f. FunctorDescription f => DynFunctorDescription
dynFunctorDescription :: forall f. Suitable f => DynFunctorDescription
dynFunctorDescription = DynFunctorDescription (Proxy :: Proxy f)
class ToDynFunctorDescription f where
toDynFunctorDescription :: f a -> DynFunctorDescription
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))
......
......@@ -38,10 +38,4 @@ defaultPrintConfig = PrintConfig {
}
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
......@@ -7,6 +7,7 @@ import Data.Text.Lazy.Builder as Build
import Copar.FunctorExpression.Printable
import Copar.FunctorExpression.Sorts (Sort, formatSortAsScope)
import Copar.FunctorExpression.Type (FunctorExpression (..))
import Copar.FunctorDescription
printFunctor :: (Printable f, Foldable f, Functor f) => FunctorExpression f Sort -> T.Text
printFunctor (Functor _ f') = Lazy.toStrict (Build.toLazyText (printTree inner f'))
......@@ -26,19 +27,21 @@ 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 :: (ToDynFunctorDescription f, Printable f, Foldable f, Functor f) => FunctorExpression f 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 = \_ -> "" }
printInner :: (Printable f, Foldable f, Functor f) => Int -> FunctorExpression f Sort -> Build.Builder
functorPrecedence :: ToDynFunctorDescription f => f a -> Int
functorPrecedence = dynPrecedence . toDynFunctorDescription
printInner :: (ToDynFunctorDescription f, Printable f, Foldable f, Functor f) => Int -> FunctorExpression f Sort -> Build.Builder
printInner _ Variable = "X"
printInner prec (Functor _ inner) =
let inner_prec = precedence inner
let inner_prec = dynPrecedence (toDynFunctorDescription inner)
in if inner_prec > prec
then print (fmap (printInner inner_prec) inner)
else "(" <> print (fmap (printInner inner_prec) inner) <> ")"
printParseableFunctor Variable = "X"
......@@ -50,7 +50,9 @@ import Copar.RefinementInterface
import Copar.Functors.Polynomial hiding ( PolyF1(..) )
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,20 +63,24 @@ 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 f) 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
instance (ToDynFunctorDescription f, Printable f) => Printable (AbsorbingPolynomial f) where
printMe 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
Absorbed inner -> if dynPrecedence (toDynFunctorDescription inner) > 10 && name == mempty
then printMe cfg inner
else "(" <> printMe cfg inner <> ")"
) <$> poly)
......
......@@ -33,8 +33,6 @@ 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
......
......@@ -29,8 +29,6 @@ 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
......
......@@ -55,24 +55,16 @@ 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
......
......@@ -39,7 +39,6 @@ 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(..)
......@@ -56,33 +55,21 @@ 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
......
......@@ -95,8 +95,6 @@ $(deriveShow1 ''Factor)
$(deriveShow1 ''Polynomial)
instance Printable Polynomial where
precedence _ = 10
printMe cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
......
......@@ -36,8 +36,6 @@ $(deriveShow1 ''Powerset)
$(deriveEq1 ''Powerset)
instance Printable Powerset where
precedence _ = 50
printMe cfg (Powerset x) = withName cfg "Powerset" <> "P" <> x
instance FunctorDescription Powerset where
......
......@@ -10,6 +10,8 @@ module Copar.Functors.SomeFunctor
( SomeFunctor(..)
, Suitable
, transformInner
, someFunctorExprParser
, dynFunctorExprParser
, SomeWeight(..)
, SomeLabel
, SomeF1
......@@ -25,6 +27,7 @@ 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
......@@ -32,23 +35,11 @@ import qualified Data.Text as T
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
, Typeable f
, Traversable f
, Show1 f
, NFData (F1 f)
, NFData (Label f)
, PrettyShow (Label f)
, PrettyShow (F1 f))
import Copar.FunctorDescription
data SomeFunctor a where
......@@ -57,6 +48,15 @@ data SomeFunctor a where
=> f a
-> SomeFunctor a
someFunctorExprParser :: DynFunctorDescription -> FunctorParser SomeFunctor
someFunctorExprParser (DynFunctorDescription (Proxy :: Proxy f)) = transParser SomeFunctor (functorExprParser @f)
instance ToDynFunctorDescription SomeFunctor where
toDynFunctorDescription (SomeFunctor (_ :: f a)) = DynFunctorDescription (Proxy :: Proxy f)
dynFunctorExprParser :: DynFunctorDescription -> FunctorParser SomeFunctor
dynFunctorExprParser (DynFunctorDescription (Proxy :: Proxy f)) = transParser SomeFunctor (functorExprParser @f)
deriving instance Functor SomeFunctor
deriving instance Foldable SomeFunctor
deriving instance Traversable SomeFunctor
......@@ -78,8 +78,6 @@ 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'.
......
......@@ -43,9 +43,12 @@ import Copar.FunctorExpression.Desorting
import Copar.FunctorExpression.Type
import Copar.FunctorDescription
import Copar.Functors.Polynomial
import Copar.Functors.SomeFunctor ( SomeFunctor(SomeFunctor) )
import Copar.Functors.SomeFunctor ( SomeFunctor(SomeFunctor), dynFunctorExprParser )
import Copar.RewriteFunctors
-- | Creates a functor expression parser for the given list of functor parser,
--
-- This expects the `FunctorParser`s to already be sorted by precedence.
functorExpressionParser
:: (Traversable f, ParseMorphism f)
=> FunctorExpression f Precedence
......
......@@ -82,7 +82,6 @@ sortTableSpec = describe "sortTable" $ do
]
instance Printable Identity where
precedence _ = 0
printMe cfg (Identity x) = withName cfg "Identity" <> x
type instance Label Identity = ()
......@@ -114,7 +113,6 @@ instance Show1 Twice where
liftShowsPrec = undefined
instance Printable Twice where
precedence _ = 0
printMe cfg (Twice a b) = withName cfg "Twice" <> a <> " " <> b
type instance Label Maybe = ()
......@@ -128,7 +126,6 @@ instance ParseMorphism Maybe where
parseMorphismPoint = undefined
instance Printable Maybe where
precedence _ = 0
printMe _ maybe = case maybe of
Just x -> "Just " <> x
Nothing -> "Nothing"
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