use FunctorDescription precedence

src/Copar/FunctorDescription.hs

 {-# 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))

src/Copar/FunctorExpression/Printable.hs

@@ -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

src/Copar/FunctorPrinter.hs

@@ -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"
-

src/Copar/Functors/AbsorbingPolynomial.hs

@@ -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)

src/Copar/Functors/Bag.hs

@@ -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

src/Copar/Functors/Distribution.hs

@@ -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

src/Copar/Functors/GroupValued.hs

@@ -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
 
 

src/Copar/Functors/MonoidValued.hs

@@ -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

src/Copar/Functors/Polynomial.hs

@@ -95,8 +95,6 @@ $(deriveShow1 ''Factor)
 $(deriveShow1 ''Polynomial)
 
 instance Printable Polynomial where
-  precedence _ = 10
-
   printMe cfg poly = withName cfg "Polynomial" <> printPolynomial cfg poly
     
 

src/Copar/Functors/Powerset.hs

@@ -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

src/Copar/Functors/SomeFunctor.hs

@@ -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'.

src/Copar/Parser.hs

@@ -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

tests/Copar/FunctorExpression/SortsSpec.hs

@@ -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"