Commit e5e572ff authored by Bastian Kauschke's avatar Bastian Kauschke
Browse files

change FunctorDescription to a type class

parent 5aa9b0c5
......@@ -113,6 +113,8 @@ executable copar
hs-source-dirs: src/main
other-modules: Hardwired
, Stats
default-extensions: ScopedTypeVariables
, TypeApplications
default-language: Haskell2010
build-depends: copar
, containers
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Copar.FunctorDescription
( FunctorParser(..)
( DynFunctorDescription(..)
, FunctorParser(..)
, FunctorDescription(..)
, formatFunctorDescription
, formatFunctorDescriptions
, dynPrecedence
, dynFunctorExprParser
)
where
......@@ -14,22 +19,37 @@ import Data.Text.Prettyprint ( Doc
)
import qualified Data.Text.Prettyprint as Doc
import Data.Proxy
import Copar.FunctorExpression.Parser
import Copar.Functors.SomeFunctor
class (Suitable f) => FunctorDescription f where
name :: Text
syntaxExample :: Text
description :: Maybe (Doc AnsiStyle)
precedence :: Int
functorExprParser :: FunctorParser f
dynFunctorDescription :: DynFunctorDescription
dynFunctorDescription = DynFunctorDescription (Proxy :: Proxy f)
data DynFunctorDescription where
DynFunctorDescription :: FunctorDescription 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)
data FunctorDescription f = FunctorDescription
{ name :: Text
, syntaxExample :: Text
, description :: Maybe (Doc AnsiStyle)
, functorExprParser :: FunctorParser f
}
formatFunctorDescription :: FunctorDescription f -> Doc AnsiStyle
formatFunctorDescription functor = Doc.vsep
[ Doc.annotate (Doc.bold <> Doc.underlined) (Doc.pretty (name functor))
<+> Doc.parens (Doc.pretty (syntaxExample functor))
, maybe mempty ((Doc.line <>) . Doc.indent 4) (description functor)
formatFunctorDescription :: FunctorDescription f => Proxy f -> Doc AnsiStyle
formatFunctorDescription (Proxy :: Proxy f)= Doc.vsep
[ Doc.annotate (Doc.bold <> Doc.underlined) (Doc.pretty (name @f))
<+> Doc.parens (Doc.pretty (syntaxExample @f))
, maybe mempty ((Doc.line <>) . Doc.indent 4) (description @f)
, ""
]
formatFunctorDescriptions :: [FunctorDescription f] -> Doc AnsiStyle
formatFunctorDescriptions = Doc.vsep . map formatFunctorDescription
formatFunctorDescriptions :: [DynFunctorDescription] -> Doc AnsiStyle
formatFunctorDescriptions = Doc.vsep . map (\(DynFunctorDescription proxy) -> formatFunctorDescription proxy)
......@@ -50,16 +50,13 @@ newtype Precedence = Precedence Int
deriving (Num, Bounded, Enum, Integral, Real, Ord, Eq, Show)
functorsParser :: forall f m. [FunctorParser f] -> ParserT m (FunctorExpression f Precedence)
functorsParser = functorsParser'
functorsParser' :: forall f m. [FunctorParser f] -> ParserT m (FunctorExpression f Precedence)
functorsParser' functors = parseLevel (zip (reverse functors) [1..])
functorsParser functors = parseLevel (zip (reverse functors) [1..])
where
parseLevel :: [(FunctorParser f, Precedence)] -> ParserT m (FunctorExpression f Precedence)
parseLevel ((FunctorParser f, i):functors) = f (parseLevel functors) >>= \case
Left a -> return a
Right fa -> return (Functor i fa)
parseLevel [] = variable <|> L.parens (functorsParser' functors)
parseLevel [] = variable <|> L.parens (functorsParser functors)
variable :: ParserT m (FunctorExpression f Precedence)
variable = L.symbol "X" >> return Variable
......
......@@ -4,42 +4,37 @@ module Copar.Functors (registeredFunctors) where
import Prelude hiding ( product )
import Data.Ratio
import Data.Word
import Data.Float.Utils
import Data.Bits.Monoid
import Data.Semigroup ( Max(..), Min(..) )
import Copar.FunctorDescription
import Copar.Functors.Bag ( bag )
import Copar.Functors.Distribution ( distribution )
import Copar.Functors.GroupValued ( intValued
, realValued
, complexValued
, rationalValued
)
import Copar.Functors.Polynomial ( polynomial )
import Copar.Functors.Powerset ( powerset )
import Copar.Functors.MonoidValued ( maxIntValued
, minIntValued
, maxRealValued
, minRealValued
, andWordValued
, orWordValued
)
import Copar.Functors.SomeFunctor
registeredFunctors :: [[FunctorDescription SomeFunctor]]
registeredFunctors = -- precedence:
[ [ someFunctor maxIntValued -- 250
, someFunctor minIntValued -- 240
, someFunctor maxRealValued -- 230
, someFunctor minRealValued -- 220
, someFunctor andWordValued -- 210
, someFunctor orWordValued -- 200
]
, [ someFunctor intValued -- 150
, someFunctor realValued -- 140
, someFunctor complexValued -- 130
, someFunctor rationalValued -- 120
]
, [someFunctor powerset -- 50
, someFunctor bag -- 40
, someFunctor distribution -- 30
]
, [someFunctor polynomial] -- 10
import Copar.Functors.Bag ( Bag )
import Copar.Functors.Distribution ( Distribution )
import Copar.Functors.GroupValued ( GroupValued, OrderedComplex )
import Copar.Functors.Polynomial ( Polynomial )
import Copar.Functors.Powerset ( Powerset )
import Copar.Functors.MonoidValued ( SlowMonoidValued )
registeredFunctors :: [DynFunctorDescription]
registeredFunctors =
[ dynFunctorDescription @(SlowMonoidValued (Max Int))
, dynFunctorDescription @(SlowMonoidValued (Min Int))
, dynFunctorDescription @(SlowMonoidValued (MaxDouble))
, dynFunctorDescription @(SlowMonoidValued (MinDouble))
, dynFunctorDescription @(SlowMonoidValued (BitAnd Word64))
, dynFunctorDescription @(SlowMonoidValued (BitOr Word64))
, dynFunctorDescription @(GroupValued Int)
, dynFunctorDescription @(GroupValued EqDouble)
, dynFunctorDescription @(GroupValued OrderedComplex)
, dynFunctorDescription @(GroupValued (Ratio Int))
, dynFunctorDescription @Powerset
, dynFunctorDescription @Bag
, dynFunctorDescription @Distribution
, dynFunctorDescription @Polynomial
]
......@@ -10,10 +10,7 @@
--
-- Coalgebras for this functor correspond to nondeterministic (unlabeled)
-- transition systems.
module Copar.Functors.Bag
( Bag(..)
, bag
) where
module Copar.Functors.Bag (Bag(..)) where
import Prelude hiding (init)
......@@ -40,13 +37,12 @@ instance Printable Bag where
printMe cfg (Bag x) = withName cfg "Bag" <> "B" <> x
bag :: FunctorDescription Bag
bag = FunctorDescription
{ name = "Bag"
, syntaxExample = "BX | ƁX"
, description = Just bagHelp
, functorExprParser = prefix ((L.symbol "B" <|> L.symbol "Ɓ") >> pure Bag)
}
instance FunctorDescription Bag where
name = "Bag"
syntaxExample = "BX | ƁX"
description = Just bagHelp
precedence = 40
functorExprParser = prefix ((L.symbol "B" <|> L.symbol "Ɓ") >> pure Bag)
bagHelp :: Doc.Doc Doc.AnsiStyle
bagHelp =
......
......@@ -3,10 +3,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
module Copar.Functors.Distribution
( distribution
, Distribution(..)
) where
module Copar.Functors.Distribution (Distribution(..)) where
import Prelude hiding (init)
import Control.Monad (when)
......@@ -36,14 +33,13 @@ instance Printable Distribution where
printMe cfg (Distribution x) = withName cfg "Distribution" <> "D" <> x
distribution :: FunctorDescription Distribution
distribution = FunctorDescription
{ name = "Distribution"
, syntaxExample = "DX | ƊX"
, description = Just distHelp
, functorExprParser = prefix ((L.symbol "D" <|> L.symbol "Ɗ")
>> pure Distribution)
}
instance FunctorDescription Distribution where
name = "Distribution"
syntaxExample = "DX | ƊX"
description = Just distHelp
precedence = 30
functorExprParser = prefix ((L.symbol "D" <|> L.symbol "Ɗ")
>> pure Distribution)
distHelp :: Doc.Doc Doc.AnsiStyle
distHelp =
......
......@@ -10,11 +10,7 @@
-- fashion over any type that satisfies the 'Num' constraint, but concrete
-- parsers only exist for integers and reals.
module Copar.Functors.GroupValued
( intValued
, realValued
, complexValued
, rationalValued
, GroupValued(..)
( GroupValued(..)
, IsGroupF3(..)
, OrderedComplex(..)
) where
......@@ -76,14 +72,13 @@ instance Printable (GroupValued (Ratio Int)) where
printMe cfg (GroupValued x) = withName cfg "Rational-valued" <> "Q^" <> x
intValued :: FunctorDescription (GroupValued Int)
intValued = FunctorDescription
{ name = "Integer-valued"
, syntaxExample = "Z^X | ℤ^X"
, description = Just intHelp
, functorExprParser =
instance FunctorDescription (GroupValued Int) where
name = "Integer-valued"
syntaxExample = "Z^X | ℤ^X"
description = Just intHelp
precedence = 150
functorExprParser =
prefix ((L.symbol "Z" <|> L.symbol "ℤ") >> L.symbol "^" >> pure GroupValued)
}
intHelp :: Doc.Doc Doc.AnsiStyle
intHelp =
......@@ -95,14 +90,13 @@ intHelp =
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow "'{' X ':' int, ... '}'"
realValued :: FunctorDescription (GroupValued EqDouble)
realValued = FunctorDescription
{ name = "Real-valued"
, syntaxExample = "R^X | ℝ^X"
, description = Just realHelp
, functorExprParser = prefix
instance FunctorDescription (GroupValued EqDouble) where
name = "Real-valued"
syntaxExample = "R^X | ℝ^X"
description = Just realHelp
precedence = 140
functorExprParser = prefix
((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure GroupValued)
}
realHelp :: Doc.Doc Doc.AnsiStyle
realHelp =
......@@ -114,14 +108,13 @@ realHelp =
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow "'{' X ':' real, ... '}'"
rationalValued :: FunctorDescription (GroupValued (Ratio Int))
rationalValued = FunctorDescription
{ name = "Rational-valued"
, syntaxExample = "Q^X | ℚ^X"
, description = Just rationalHelp
, functorExprParser = prefix
instance FunctorDescription (GroupValued (Ratio Int)) where
name = "Rational-valued"
syntaxExample = "Q^X | ℚ^X"
description = Just rationalHelp
precedence = 120
functorExprParser = prefix
((L.symbol "Q" <|> L.symbol "ℚ") >> L.symbol "^" >> pure GroupValued)
}
rationalHelp :: Doc.Doc Doc.AnsiStyle
rationalHelp =
......@@ -143,14 +136,13 @@ instance Ord OrderedComplex where
compare (OrderedComplex a) (OrderedComplex b) = case (a, b) of
(r1 :+ i1, r2 :+ i2) -> compare r1 r2 <> compare i1 i2
complexValued :: FunctorDescription (GroupValued OrderedComplex)
complexValued = FunctorDescription
{ name = "Complex-valued"
, syntaxExample = "C^X | ℂ^X"
, description = Just complexHelp
, functorExprParser = prefix
instance FunctorDescription (GroupValued OrderedComplex) where
name = "Complex-valued"
syntaxExample = "C^X | ℂ^X"
description = Just complexHelp
precedence = 130
functorExprParser = prefix
((L.symbol "C" <|> L.symbol "ℂ") >> L.symbol "^" >> pure GroupValued)
}
complexHelp :: Doc.Doc Doc.AnsiStyle
complexHelp =
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -8,15 +9,7 @@
-- The 'RefinementInterface' implementation for such functors doesn't fulfil the
-- same runtime complexity criteria as the other functors and it also uses tons
-- of space, but it works and satisfies the axioms.
module Copar.Functors.MonoidValued
( SlowMonoidValued(..)
, maxIntValued
, minIntValued
, maxRealValued
, minRealValued
, andWordValued
, orWordValued
)
module Copar.Functors.MonoidValued (SlowMonoidValued(..))
where
import Data.List ( foldl', intersperse )
......@@ -38,6 +31,7 @@ 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(..)
......@@ -47,6 +41,8 @@ import Data.SumBag (SumBag)
import qualified Data.SumBag as SumBag
import Data.Bits.Monoid
import Data.Proxy
newtype SlowMonoidValued m a = SlowMonoidValued a
......@@ -93,43 +89,41 @@ deriving instance Functor (SlowMonoidValued m)
deriving instance Foldable (SlowMonoidValued m)
deriving instance Traversable (SlowMonoidValued m)
data MonoidValuedDescription m = MonoidValued
{ mvName :: Text
, mvDescription :: Text
, mvSet :: [Text] -- often [ascii, unicode]
, mvOperation :: Text
, mvTerm :: Text
}
makeMonoidValued
:: MonoidValuedDescription m -> FunctorDescription (SlowMonoidValued m)
makeMonoidValued desc = FunctorDescription
{ name = mvName desc <> "-valued"
, syntaxExample = fold (intersperse " | " (map syntax (mvSet desc)))
, description = Just (makeMVHelp desc)
, functorExprParser =
class (Suitable (SlowMonoidValued m)) => MonoidValuedDescription m where
mvName :: Text
mvDescription :: Text
mvSet :: [Text] -- often [ascii, unicode]
mvOperation :: Text
mvTerm :: Text
mvPrecedence :: Int
instance MonoidValuedDescription m => FunctorDescription (SlowMonoidValued m) where
name = mvName @m <> "-valued"
syntaxExample = fold (intersperse " | " (map syntax (mvSet @m)))
where syntax x = functorSyntax x (mvOperation @m)
description = Just (makeMVHelp (Proxy :: Proxy m))
precedence = 200 + mvPrecedence @m
functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
-- normal if they don't contain exactly (Z, max)
( try
(L.parens
((choice (map L.symbol (mvSet desc)))
((choice (map L.symbol (mvSet @m)))
>> L.comma
>> L.symbol (mvOperation desc)
>> L.symbol (mvOperation @m)
)
)
>> L.symbol "^"
>> pure SlowMonoidValued
>> L.symbol "^"
>> pure SlowMonoidValued
)
}
where syntax x = functorSyntax x (mvOperation desc)
functorSyntax :: Text -> Text -> Text
functorSyntax s o = "(" <> s <> ", " <> o <> ")^X"
makeMVHelp :: MonoidValuedDescription m -> Doc.Doc Doc.AnsiStyle
makeMVHelp desc =
Doc.reflow ("Weighted systems with " <> mvDescription desc)
makeMVHelp :: MonoidValuedDescription m => Proxy m -> Doc.Doc Doc.AnsiStyle
makeMVHelp (Proxy :: Proxy m) =
Doc.reflow ("Weighted systems with " <> mvDescription @m)
<> Doc.line <> Doc.line
<> Doc.reflow "This is similar to all the group valued functors (int, real, \
\etc) but isn't actually a group as it lacks an inverse. Thus \
......@@ -137,75 +131,68 @@ makeMVHelp desc =
\asymptotically slower than for the others."
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Functor syntax:"
<+> Doc.reflow (fold (intersperse " | " (map syntax (mvSet desc))))
<+> Doc.reflow (fold (intersperse " | " (map syntax (mvSet @m))))
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow ("'{' X ':' " <> mvTerm desc <> ", ... '}'")
where syntax x = functorSyntax x (mvOperation desc)
<+> Doc.reflow ("'{' X ':' " <> mvTerm @m <> ", ... '}'")
where syntax x = functorSyntax x (mvOperation @m)
-- | The @(ℤ, max)^X@ functor
maxIntValued :: FunctorDescription (SlowMonoidValued (Max Int))
maxIntValued = makeMonoidValued $ MonoidValued
{ mvName = "Max"
, mvSet = ["Z", "ℤ"]
, mvOperation = "max"
, mvDescription = "the monoid (Z, max)"
, mvTerm = "int"
}
instance MonoidValuedDescription (Max Int) where
mvName = "Max"
mvSet = ["Z", "ℤ"]
mvOperation = "max"
mvDescription = "the monoid (Z, max)"
mvPrecedence = 50
mvTerm = "int"
-- | The @(ℤ, min)^X@ functor
minIntValued :: FunctorDescription (SlowMonoidValued (Min Int))
minIntValued = makeMonoidValued $ MonoidValued
{ mvName = "Min"
, mvSet = ["Z", "ℤ"]
, mvOperation = "min"
, mvDescription = "the monoid (Z, min)"
, mvTerm = "int"
}
instance MonoidValuedDescription (Min Int) where
mvName = "Min"
mvSet = ["Z", "ℤ"]
mvOperation = "min"
mvDescription = "the monoid (Z, min)"
mvPrecedence = 40
mvTerm = "int"
-- | The @(ℝ, max)^X@ functor
maxRealValued :: FunctorDescription (SlowMonoidValued MaxDouble)
maxRealValued = makeMonoidValued $ MonoidValued
{ mvName = "Max"
, mvSet = ["R", "ℝ"]
, mvOperation = "max"
, mvDescription = "the monoid (R, max)"
, mvTerm = "real"
}
instance MonoidValuedDescription MaxDouble where
mvName = "Max"
mvSet = ["R", "ℝ"]
mvOperation = "max"
mvDescription = "the monoid (R, max)"
mvPrecedence = 30
mvTerm = "real"
-- | The @(ℝ, min)^X@ functor
minRealValued :: FunctorDescription (SlowMonoidValued MinDouble)
minRealValued = makeMonoidValued $ MonoidValued
{ mvName = "Min"
, mvSet = ["R", "ℝ"]
, mvOperation = "min"
, mvDescription = "the monoid (R, min)"
, mvTerm = "real"
}
instance MonoidValuedDescription MinDouble where
mvName = "Min"
mvSet = ["R", "ℝ"]
mvOperation = "min"
mvDescription = "the monoid (R, min)"
mvPrecedence = 20
mvTerm = "real"
-- | The @(Word, and)^X@ functor
andWordValued :: FunctorDescription (SlowMonoidValued (BitAnd Word64))
andWordValued = makeMonoidValued $ MonoidValued
{ mvName = "BitAnd"
, mvSet = ["Word"]
, mvOperation = "and"
, mvDescription = "bitvectors and bitwise 'and' as monoid weight"
, mvTerm = "0xCAFE"
}
instance MonoidValuedDescription (BitAnd Word64) where
mvName = "BitAnd"
mvSet = ["Word"]
mvOperation = "and"
mvDescription = "bitvectors and bitwise 'and' as monoid weight"
mvPrecedence = 10
mvTerm = "0xCAFE"
-- | The @(Word, or)^X@ functor
orWordValued :: FunctorDescription (SlowMonoidValued (BitOr Word64))
orWordValued = makeMonoidValued $ MonoidValued
{ mvName = "BitOr"
, mvSet = ["Word"]
, mvOperation = "or"
, mvDescription = "bitvectors and bitwise 'or' as monoid weight"
, mvTerm = "0xCAFE"
}
instance MonoidValuedDescription (BitOr Word64) where
mvName = "BitOr"
mvSet = ["Word"]
mvOperation = "or"
mvDescription = "bitvectors and bitwise 'or' as monoid weight"
mvPrecedence = 00
mvTerm = "0xCAFE"
type instance Label (SlowMonoidValued m) = m
......
......@@ -9,9 +9,7 @@
-- | Polynomial functor with co-products, products, exponentials and constants
module Copar.Functors.Polynomial
( -- * Functor expression parser
polynomial
, printPolynomial
( printPolynomial
-- * Types exported for easier testing
, Polynomial(..)
, Sum(..)
......@@ -146,14 +144,12 @@ instance Show1 Sum where
prec
(NonEmpty.toList summands)
polynomial :: FunctorDescription Polynomial
polynomial = FunctorDescription
{ name = "Polynomial"
, syntaxExample = "2xX + X^3 | {a, b}xX + X^{c, d, e}"
, description = Just polynomialHelp
, functorExprParser = polynomialp
}
instance FunctorDescription Polynomial where
name = "Polynomial"
syntaxExample = "2xX + X^3 | {a, b}xX + X^{c, d, e}"
description = Just polynomialHelp
precedence = 10
functorExprParser = polynomialp
polynomialHelp :: Doc.Doc Doc.AnsiStyle
polynomialHelp =
......
......@@ -3,7 +3,6 @@
module Copar.Functors.Powerset
( Powerset(..)
, powerset
-- * For testing
, packWeight
, unpackWeight
......@@ -41,14 +40,13 @@ instance Printable Powerset where