Commit afc736fa authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Rename functors (N, and/or) to (Word, and/or)

This highlights the fact that they represent finite sets and the value syntax
are hexadecimal unsigned integers.
parent f77957a9
(, and)^X
(Word, and)^X
x: {x: 0xDEADFFFF, y: 0xFFFFBEEF}
y: {x: 0xDEADBEEF, y: 0xDEADBEEF}
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module implements the @M^X@ functor, where @M@ is a monoid that
-- doesn't have to be a group like in "Copar.Functors.GroupValued".
......@@ -20,11 +19,12 @@ module Copar.Functors.MonoidValued
)
where
import Data.List ( foldl' )
import Data.List ( foldl', intersperse )
import Data.Semigroup ( Max(..), Min(..) )
import Data.Functor.Classes
import Control.Monad
import Data.Foldable
import Data.Word
import qualified Data.Vector as V
import Text.Megaparsec
......@@ -47,7 +47,7 @@ import qualified Data.SumBag as SumBag
import Data.Bits.Monoid
data SlowMonoidValued m a = SlowMonoidValued a
newtype SlowMonoidValued m a = SlowMonoidValued a
instance Eq1 (SlowMonoidValued m) where
liftEq f (SlowMonoidValued a1) (SlowMonoidValued a2) = f a1 a2
......@@ -63,7 +63,7 @@ deriving instance Traversable (SlowMonoidValued m)
data MonoidValuedDescription m = MonoidValued
{ mvName :: Text
, mvDescription :: Text
, mvSet :: (Text, Text) -- (ascii, unicode)
, mvSet :: [Text] -- often [ascii, unicode]
, mvOperation :: Text
, mvTerm :: Text
}
......@@ -72,7 +72,7 @@ makeMonoidValued
:: MonoidValuedDescription m -> FunctorDescription (SlowMonoidValued m)
makeMonoidValued desc = FunctorDescription
{ name = mvName desc <> "-valued"
, syntaxExample = syntax fst <> " | " <> syntax snd
, syntaxExample = fold (intersperse " | " (map syntax (mvSet desc)))
, description = Just (makeMVHelp desc)
, functorExprParser =
prefix
......@@ -80,7 +80,7 @@ makeMonoidValued desc = FunctorDescription
-- normal if they don't contain exactly (Z, max)
( try
(L.parens
( (L.symbol (fst (mvSet desc)) <|> L.symbol (snd (mvSet desc)))
((choice (map L.symbol (mvSet desc)))
>> L.comma
>> L.symbol (mvOperation desc)
)
......@@ -89,7 +89,7 @@ makeMonoidValued desc = FunctorDescription
>> pure SlowMonoidValued
)
}
where syntax f = functorSyntax (f (mvSet desc)) (mvOperation desc)
where syntax x = functorSyntax x (mvOperation desc)
functorSyntax :: Text -> Text -> Text
functorSyntax s o = "(" <> s <> ", " <> o <> ")^X"
......@@ -104,17 +104,17 @@ makeMVHelp desc =
\asymptotically slower than for the others."
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Functor syntax:"
<+> Doc.reflow (syntax fst <> " | " <> syntax snd)
<+> Doc.reflow (fold (intersperse " | " (map syntax (mvSet desc))))
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow ("'{' X ':' " <> mvTerm desc <> ", ... '}'")
where syntax f = functorSyntax (f (mvSet desc)) (mvOperation desc)
where syntax x = functorSyntax x (mvOperation desc)
-- | The @(ℤ, max)^X@ functor
maxIntValued :: FunctorDescription (SlowMonoidValued (Max Int))
maxIntValued = makeMonoidValued $ MonoidValued
{ mvName = "Max"
, mvSet = ("Z", "ℤ")
, mvSet = ["Z", "ℤ"]
, mvOperation = "max"
, mvDescription = "the monoid (Z, max)"
, mvTerm = "int"
......@@ -124,7 +124,7 @@ maxIntValued = makeMonoidValued $ MonoidValued
minIntValued :: FunctorDescription (SlowMonoidValued (Min Int))
minIntValued = makeMonoidValued $ MonoidValued
{ mvName = "Min"
, mvSet = ("Z", "ℤ")
, mvSet = ["Z", "ℤ"]
, mvOperation = "min"
, mvDescription = "the monoid (Z, min)"
, mvTerm = "int"
......@@ -135,7 +135,7 @@ minIntValued = makeMonoidValued $ MonoidValued
maxRealValued :: FunctorDescription (SlowMonoidValued MaxDouble)
maxRealValued = makeMonoidValued $ MonoidValued
{ mvName = "Max"
, mvSet = ("R", "ℝ")
, mvSet = ["R", "ℝ"]
, mvOperation = "max"
, mvDescription = "the monoid (R, max)"
, mvTerm = "real"
......@@ -146,29 +146,29 @@ maxRealValued = makeMonoidValued $ MonoidValued
minRealValued :: FunctorDescription (SlowMonoidValued MinDouble)
minRealValued = makeMonoidValued $ MonoidValued
{ mvName = "Min"
, mvSet = ("R", "ℝ")
, mvSet = ["R", "ℝ"]
, mvOperation = "min"
, mvDescription = "the monoid (R, min)"
, mvTerm = "real"
}
-- | The @(, and)^X@ functor
andWordValued :: FunctorDescription (SlowMonoidValued (BitAnd Word))
-- | The @(Word, and)^X@ functor
andWordValued :: FunctorDescription (SlowMonoidValued (BitAnd Word64))
andWordValued = makeMonoidValued $ MonoidValued
{ mvName = "BitAnd"
, mvSet = ("N", "ℕ")
, mvSet = ["Word"]
, mvOperation = "and"
, mvDescription = "bitvectors and bitwise 'and' as monoid weight"
, mvTerm = "0xCAFE"
}
-- | The @(, or)^X@ functor
orWordValued :: FunctorDescription (SlowMonoidValued (BitOr Word))
-- | The @(Word, or)^X@ functor
orWordValued :: FunctorDescription (SlowMonoidValued (BitOr Word64))
orWordValued = makeMonoidValued $ MonoidValued
{ mvName = "BitOr"
, mvSet = ("N", "ℕ")
, mvSet = ["Word"]
, mvOperation = "or"
, mvDescription = "bitvectors and bitwise 'or' as monoid weight"
, mvTerm = "0xCAFE"
......@@ -218,10 +218,10 @@ instance ParseMorphism (SlowMonoidValued MaxDouble) where
instance ParseMorphism (SlowMonoidValued MinDouble) where
parseMorphismPoint = parseMorphismPointHelper (MinDouble <$> L.signed L.float)
instance ParseMorphism (SlowMonoidValued (BitAnd Word)) where
instance ParseMorphism (SlowMonoidValued (BitAnd Word64)) where
parseMorphismPoint = parseMorphismPointHelper L.hex
instance ParseMorphism (SlowMonoidValued (BitOr Word)) where
instance ParseMorphism (SlowMonoidValued (BitOr Word64)) where
parseMorphismPoint = parseMorphismPointHelper L.hex
......
......@@ -14,6 +14,7 @@ import Data.Semigroup ( Max(..)
import Control.Monad.ST
import Data.Proxy
import Data.Void
import Data.Word
import Test.Hspec.Megaparsec
import Data.Text ( Text )
......@@ -52,7 +53,7 @@ spec = do
maxIntParseSpec :: Spec
maxIntParseSpec = describe "maxInt parsing" $ do
makeFunctorParseSpec maxIntValued ("Z", "ℤ") "max"
makeFunctorParseSpec maxIntValued ("Z", Just "ℤ") "max"
let p = makeMorphParser @(Max Int)
......@@ -69,7 +70,7 @@ maxIntParseSpec = describe "maxInt parsing" $ do
minIntParseSpec :: Spec
minIntParseSpec = describe "minIntParse" $ do
makeFunctorParseSpec minIntValued ("Z", "ℤ") "min"
makeFunctorParseSpec minIntValued ("Z", Just "ℤ") "min"
let p = makeMorphParser @(Min Int)
......@@ -119,7 +120,7 @@ minIntRefineSpec = describe "minInt refine" $ do
maxRealParseSpec :: Spec
maxRealParseSpec = describe "maxReal parsing" $ do
makeFunctorParseSpec maxRealValued ("R", "ℝ") "max"
makeFunctorParseSpec maxRealValued ("R", Just "ℝ") "max"
let p = makeMorphParser @MaxDouble
......@@ -137,7 +138,7 @@ maxRealParseSpec = describe "maxReal parsing" $ do
minRealParseSpec :: Spec
minRealParseSpec = describe "minReal parsing" $ do
makeFunctorParseSpec minRealValued ("R", "ℝ") "min"
makeFunctorParseSpec minRealValued ("R", Just "ℝ") "min"
let p = makeMorphParser @MinDouble
......@@ -187,11 +188,11 @@ minRealRefineSpec = describe "minReal refine" $ do
andWordParseSpec :: Spec
andWordParseSpec = describe "bit-and parsing" $ do
makeFunctorParseSpec andWordValued ("N", "ℕ") "and"
makeFunctorParseSpec andWordValued ("Word", Nothing) "and"
let p = makeMorphParser @(BitAnd Word)
let p = makeMorphParser @(BitAnd Word64)
itParsesEmpty @(BitAnd Word)
itParsesEmpty @(BitAnd Word64)
it "parses a simple example"
$ p "x: {x: 0xA0, y: 0x0A}\ny: {}"
......@@ -203,8 +204,8 @@ andWordParseSpec = describe "bit-and parsing" $ do
andWordRefineSpec :: Spec
andWordRefineSpec = describe "andWord refine" $ do
let p = makeMorphParser @(BitAnd Word)
proxy = Proxy @(Desorted (SlowMonoidValued (BitAnd Word)))
let p = makeMorphParser @(BitAnd Word64)
proxy = Proxy @(Desorted (SlowMonoidValued (BitAnd Word64)))
it "it distinguishes different meets with equal sums" $ do
let Right enc = p "x: {x: 0xAA, y: 0xCC}\ny: {x: 0xBB, y: 0xBB}"
......@@ -219,11 +220,11 @@ andWordRefineSpec = describe "andWord refine" $ do
orWordParseSpec :: Spec
orWordParseSpec = describe "bit-or parsing" $ do
makeFunctorParseSpec orWordValued ("N", "ℕ") "or"
makeFunctorParseSpec orWordValued ("Word", Nothing) "or"
let p = makeMorphParser @(BitOr Word)
let p = makeMorphParser @(BitOr Word64)
itParsesEmpty @(BitOr Word)
itParsesEmpty @(BitOr Word64)
it "parses a simple example"
$ p "x: {x: 0xA0, y: 0x0A}\ny: {}"
......@@ -235,8 +236,8 @@ orWordParseSpec = describe "bit-or parsing" $ do
orWordRefineSpec :: Spec
orWordRefineSpec = describe "orWord refine" $ do
let p = makeMorphParser @(BitOr Word)
proxy = Proxy @(Desorted (SlowMonoidValued (BitOr Word)))
let p = makeMorphParser @(BitOr Word64)
proxy = Proxy @(Desorted (SlowMonoidValued (BitOr Word64)))
it "it distinguishes different joins with equal sums" $ do
let Right enc = p "x: {x: 0xAA, y: 0xCC}\ny: {x: 0xBB, y: 0xBB}"
......@@ -250,7 +251,7 @@ orWordRefineSpec = describe "orWord refine" $ do
makeFunctorParseSpec :: FunctorDescription (SlowMonoidValued m)
-> (Text, Text)
-> (Text, Maybe Text)
-> Text
-> Spec
makeFunctorParseSpec functor (setAscii, setUnicode) operation = do
......@@ -259,10 +260,13 @@ makeFunctorParseSpec functor (setAscii, setUnicode) operation = do
$ parseFunctorExpression [[functorExprParser functor]] "" expr
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
let expr = syntax setUnicode operation "X"
it ("can parse " <> T.unpack expr <> " as functor expression")
$ parseFunctorExpression [[functorExprParser functor]] "" expr
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
case setUnicode of
Nothing -> return ()
Just set -> do
let expr = syntax set operation "X"
it ("can parse " <> T.unpack expr <> " as functor expression")
$ parseFunctorExpression [[functorExprParser functor]] "" expr
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
it "nests correctly in functor expressions"
$ parseFunctorExpression [[functorExprParser functor]]
......
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