symbiote 0.0.0.1 → 0.0.1

raw patch · 8 files changed

+1092/−227 lines, 8 filesdep +abidesdep +cereal-textdep +tasty-quickcheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: abides, cereal-text, tasty-quickcheck

API changes (from Hackage documentation)

Files

• src/Test/Serialization/Symbiote.hs +340/−125
• src/Test/Serialization/Symbiote/Abides.hs +533/−0
• src/Test/Serialization/Symbiote/Aeson.hs +16/−2
• src/Test/Serialization/Symbiote/Cereal.hs +17/−2
• src/Test/Serialization/Symbiote/Cereal/Lazy.hs +17/−2
• src/Test/Serialization/Symbiote/Core.hs +54/−30
• symbiote.cabal +9/−2
• test/Spec.hs +106/−64

@@ -1,14 +1,17 @@ {-# LANGUAGE-    MultiParamTypeClasses+    RankNTypes   , TypeFamilies-  , ExistentialQuantification-  , RankNTypes-  , ScopedTypeVariables+  , DeriveGeneric   , NamedFieldPuns+  , RecordWildCards   , FlexibleContexts+  , FlexibleInstances+  , OverloadedStrings   , StandaloneDeriving+  , ScopedTypeVariables   , UndecidableInstances-  , FlexibleInstances+  , MultiParamTypeClasses+  , ExistentialQuantification   #-}  {-|@@ -27,7 +30,7 @@  > {-# LANGUAGE MultiparamTypeClasses, TypeFamilies #-} >-> instance SymbioteOperation TypeA where+> instance SymbioteOperation TypeA TypeA where >   data Operation TypeA >     = F >     | G TypeA@@ -49,16 +52,18 @@ >         s <- parseJSON json >         if s == "f" >           then pure F->           else fail "Not F"+>           else typeMismatch "Operation TypeA" json >       getG = do->         x <- json .: "g"->         pure (G x)+>         o <- parseJSON json+>         G <$> o .: "g"  Next, let's make @TypeA@ an instance of 'Symbiote': -> instance Symbiote TypeA Value where+> instance Symbiote TypeA TypeA Value where >   encode = Aeson.toJSON >   decode = Aeson.parseMaybe Aeson.parseJSON+>   encodeOut _ = Aeson.toJSON+>   decodeOut _ = Aeson.parseMaybe Aeson.parseJSON >   encodeOp = Aeson.toJSON >   decodeOp = Aeson.parseMaybe Aeson.parseJSON @@ -78,13 +83,13 @@ -}  module Test.Serialization.Symbiote-  ( SymbioteOperation (..), Symbiote (..), EitherOp (..), Topic, SymbioteT, register+  ( SymbioteOperation (..), Symbiote (..), SimpleSerialization (..), Topic, SymbioteT, register   , firstPeer, secondPeer, First (..), Second (..), Generating (..), Operating (..), Failure (..)-  , defaultSuccess, defaultFailure, defaultProgress, nullProgress, simpleTest+  , defaultSuccess, defaultFailure, defaultProgress, nullProgress, simpleTest, simpleTest'   ) where  import Test.Serialization.Symbiote.Core-  ( Topic (..), newGeneration, SymbioteState (..), SymbioteT, runSymbioteT+  ( Topic (..), newGeneration, SymbioteState (..), ExistsSymbiote (..), SymbioteT, runSymbioteT   , GenerateSymbiote (..), generateSymbiote, getProgress, Symbiote (..), SymbioteOperation (..))  import Data.Map (Map)@@ -92,59 +97,75 @@ import qualified Data.Set as Set import Data.Text (unpack) import Data.Proxy (Proxy (..))+import Data.Aeson (ToJSON (..), FromJSON (..), (.=), object, (.:), Value (Object, String))+import Data.Aeson.Types (typeMismatch)+import Data.Serialize (Serialize (..))+import Data.Serialize.Put (putWord8)+import Data.Serialize.Get (getWord8) import Text.Printf (printf) import Control.Concurrent.STM   (TVar, newTVarIO, readTVarIO, writeTVar, atomically, newTChan, readTChan, writeTChan) import Control.Concurrent.Async (async, wait)+import Control.Applicative ((<|>)) import Control.Monad (void) import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) import Control.Monad.State (modify') import Control.Monad.IO.Class (MonadIO, liftIO) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)-import Test.QuickCheck.Gen (Gen)+import Test.QuickCheck.Gen (Gen, oneof)+import GHC.Generics (Generic)  --- | The most trivial serialization medium for any @a@.-newtype EitherOp a = EitherOp (Either a (Operation a))-deriving instance (Eq a, Eq (Operation a)) => Eq (EitherOp a)-deriving instance (Show a, Show (Operation a)) => Show (EitherOp a)+-- | The most trivial serialization medium for any @a@ and @o@.+data SimpleSerialization a o+  = SimpleValue a+  | SimpleOutput o+  | SimpleOperation (Operation a)+  deriving (Generic)+deriving instance (Show a, Show o, Show (Operation a)) => Show (SimpleSerialization a o)+deriving instance (Eq a, Eq o, Eq (Operation a)) => Eq (SimpleSerialization a o) -instance SymbioteOperation a => Symbiote a (EitherOp a) where-  encode = EitherOp . Left-  decode (EitherOp (Left x)) = Just x-  decode (EitherOp (Right _)) = Nothing-  encodeOp = EitherOp . Right-  decodeOp (EitherOp (Left _)) = Nothing-  decodeOp (EitherOp (Right x)) = Just x+instance SymbioteOperation a o => Symbiote a o (SimpleSerialization a o) where+  encode = SimpleValue+  decode (SimpleValue x) = Just x+  decode _ = Nothing+  encodeOut _ = SimpleOutput+  decodeOut _ (SimpleOutput x) = Just x+  decodeOut _ _ = Nothing+  encodeOp = SimpleOperation+  decodeOp (SimpleOperation x) = Just x+  decodeOp _ = Nothing   -- | Register a topic in the test suite-register :: forall a s m+register :: forall a o s m           . Arbitrary a          => Arbitrary (Operation a)-         => Symbiote a s-         => Eq a+         => Symbiote a o s+         => Eq o          => MonadIO m          => Topic          -> Int -- ^ Max size-         -> Proxy a+         -> Proxy a -- ^ Reference to datatype          -> SymbioteT s m () register t maxSize Proxy = do   generation <- liftIO (newTVarIO newGeneration)-  let newState :: SymbioteState s+  let newState :: SymbioteState a o s       newState = SymbioteState         { generate = arbitrary :: Gen a         , generateOp = arbitrary :: Gen (Operation a)-        , equal = (==) :: a -> a -> Bool+        , equal = (==) :: o -> o -> Bool         , maxSize         , generation-        , encode' = encode-        , encodeOp' = encodeOp-        , decode' = decode-        , decodeOp' = decodeOp-        , perform' = perform+        , encode'    = encode+        , encodeOut' = encodeOut (Proxy :: Proxy a)+        , encodeOp'  = encodeOp+        , decode'    = decode+        , decodeOut' = decodeOut (Proxy :: Proxy a)+        , decodeOp'  = decodeOp+        , perform'   = perform         }-  modify' (Map.insert t newState)+  modify' (Map.insert t (ExistsSymbiote newState))  -- | Messages sent by a peer during their generating phase data Generating s@@ -156,14 +177,88 @@   | YourTurn   | ImFinished   | GeneratingNoParseOperated s-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance Arbitrary s => Arbitrary (Generating s) where+  arbitrary = oneof+    [ Generated <$> arbitrary <*> arbitrary+    , BadResult <$> arbitrary+    , pure YourTurn+    , pure ImFinished+    , GeneratingNoParseOperated <$> arbitrary+    ]+instance ToJSON s => ToJSON (Generating s) where+  toJSON x = case x of+    Generated{..} -> object ["generated" .= object ["value" .= genValue, "operation" .= genOperation]]+    BadResult r -> object ["badResult" .= r]+    YourTurn -> String "yourTurn"+    ImFinished -> String "imFinished"+    GeneratingNoParseOperated r -> object ["noParseOperated" .= r]+instance FromJSON s => FromJSON (Generating s) where+  parseJSON (Object o) = generated <|> badResult <|> noParseOperated+    where+      generated = do+        o' <- o .: "generated"+        Generated <$> o' .: "value" <*> o' .: "operation"+      badResult = BadResult <$> o .: "badResult"+      noParseOperated = GeneratingNoParseOperated <$> o .: "noParseOperated"+  parseJSON x@(String s)+    | s == "imFinished" = pure ImFinished+    | s == "yourTurn" = pure YourTurn+    | otherwise = typeMismatch "Generating s" x+  parseJSON x = typeMismatch "Generating s" x+instance Serialize s => Serialize (Generating s) where+  put x = case x of+    Generated{..} -> putWord8 0 *> put genValue *> put genOperation+    BadResult r -> putWord8 1 *> put r+    YourTurn -> putWord8 2+    ImFinished -> putWord8 3+    GeneratingNoParseOperated r -> putWord8 4 *> put r+  get = do+    x <- getWord8+    case x of+      0 -> Generated <$> get <*> get+      1 -> BadResult <$> get+      2 -> pure YourTurn+      3 -> pure ImFinished+      4 -> GeneratingNoParseOperated <$> get+      _ -> fail "Generating s"  -- | Messages sent by a peer during their operating phase data Operating s   = Operated s -- ^ Serialized value after operation   | OperatingNoParseValue s   | OperatingNoParseOperation s-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance Arbitrary s => Arbitrary (Operating s) where+  arbitrary = oneof+    [ Operated <$> arbitrary+    , OperatingNoParseValue <$> arbitrary+    , OperatingNoParseOperation <$> arbitrary+    ]+instance ToJSON s => ToJSON (Operating s) where+  toJSON x = case x of+    Operated r -> object ["operated" .= r]+    OperatingNoParseValue r -> object ["noParseValue" .= r]+    OperatingNoParseOperation r -> object ["noParseOperation" .= r]+instance FromJSON s => FromJSON (Operating s) where+  parseJSON (Object o) = operated <|> noParseValue <|> noParseOperation+    where+      operated = Operated <$> o .: "operated"+      noParseValue = OperatingNoParseValue <$> o .: "noParseValue"+      noParseOperation = OperatingNoParseOperation <$> o .: "noParseOperation"+  parseJSON x = typeMismatch "Operating s" x+instance Serialize s => Serialize (Operating s) where+  put x = case x of+    Operated y -> putWord8 0 *> put y+    OperatingNoParseValue r -> putWord8 1 *> put r+    OperatingNoParseOperation r -> putWord8 2 *> put r+  get = do+    x <- getWord8+    case x of+      0 -> Operated <$> get+      1 -> OperatingNoParseValue <$> get+      2 -> OperatingNoParseOperation <$> get+      _ -> fail "Operating s"  -- | Messages sent by the first peer data First s@@ -176,7 +271,41 @@     { firstOperatingTopic :: Topic     , firstOperating :: Operating s     }-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance Arbitrary s => Arbitrary (First s) where+  arbitrary = oneof+    [ AvailableTopics <$> arbitrary+    , FirstGenerating <$> arbitrary <*> arbitrary+    , FirstOperating <$> arbitrary <*> arbitrary+    ]+instance ToJSON s => ToJSON (First s) where+  toJSON x = case x of+    AvailableTopics ts -> object ["availableTopics" .= ts]+    FirstGenerating t y -> object ["firstGenerating" .= object ["topic" .= t, "generating" .= y]]+    FirstOperating t y -> object ["firstOperating" .= object ["topic" .= t, "operating" .= y]]+instance FromJSON s => FromJSON (First s) where+  parseJSON (Object o) = availableTopics <|> firstGenerating' <|> firstOperating'+    where+      availableTopics = AvailableTopics <$> o .: "availableTopics"+      firstGenerating' = do+        o' <- o .: "firstGenerating"+        FirstGenerating <$> o' .: "topic" <*> o' .: "generating"+      firstOperating' = do+        o' <- o .: "firstOperating"+        FirstOperating <$> o' .: "topic" <*> o' .: "operating"+  parseJSON x = typeMismatch "First s" x+instance Serialize s => Serialize (First s) where+  put x = case x of+    AvailableTopics ts -> putWord8 0 *> put ts+    FirstGenerating t y -> putWord8 1 *> put t *> put y+    FirstOperating t y -> putWord8 2 *> put t *> put y+  get = do+    x <- getWord8+    case x of+      0 -> AvailableTopics <$> get+      1 -> FirstGenerating <$> get <*> get+      2 -> FirstOperating <$> get <*> get+      _ -> fail "First s"  getFirstGenerating :: First s -> Maybe (Topic, Generating s) getFirstGenerating x = case x of@@ -201,7 +330,48 @@     { secondGeneratingTopic :: Topic     , secondGenerating :: Generating s     }-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance Arbitrary s => Arbitrary (Second s) where+  arbitrary = oneof+    [ BadTopics <$> arbitrary+    , pure Start+    , SecondOperating <$> arbitrary <*> arbitrary+    , SecondGenerating <$> arbitrary <*> arbitrary+    ]+instance ToJSON s => ToJSON (Second s) where+  toJSON x = case x of+    BadTopics ts -> object ["badTopics" .= ts]+    Start -> String "start"+    SecondOperating t y -> object ["secondOperating" .= object ["topic" .= t, "operating" .= y]]+    SecondGenerating t y -> object ["secondGenerating" .= object ["topic" .= t, "generating" .= y]]+instance FromJSON s => FromJSON (Second s) where+  parseJSON (Object o) = badTopics <|> secondOperating' <|> secondGenerating'+    where+      badTopics = BadTopics <$> o .: "badTopics"+      secondOperating' = do+        o' <- o .: "secondOperating"+        SecondOperating <$> o' .: "topic" <*> o' .: "operating"+      secondGenerating' = do+        o' <- o .: "secondGenerating"+        SecondGenerating <$> o' .: "topic" <*> o' .: "generating"+  parseJSON x@(String s)+    | s == "start" = pure Start+    | otherwise = typeMismatch "Second s" x+  parseJSON x = typeMismatch "Second s" x+instance Serialize s => Serialize (Second s) where+  put x = case x of+    BadTopics ts -> putWord8 0 *> put ts+    Start -> putWord8 1+    SecondOperating t y -> putWord8 2 *> put t *> put y+    SecondGenerating t y -> putWord8 3 *> put t *> put y+  get = do+    x <- getWord8+    case x of+      0 -> BadTopics <$> get+      1 -> pure Start+      2 -> SecondOperating <$> get <*> get+      3 -> SecondGenerating <$> get <*> get+      _ -> fail "Second s"  getSecondGenerating :: Second s -> Maybe (Topic, Generating s) getSecondGenerating x = case x of@@ -255,7 +425,7 @@ defaultProgress (Topic t) p = putStrLn $ "Topic " ++ unpack t ++ ": " ++ printf "%.2f" (p * 100.0) ++ "%"  -- | Do nothing-nullProgress :: Topic -> Float -> IO ()+nullProgress :: Applicative m => Topic -> Float -> m () nullProgress _ _ = pure ()  @@ -272,7 +442,10 @@           -> m () firstPeer encodeAndSend receiveAndDecode onSuccess onFailure onProgress x = do   state <- runSymbioteT x True-  let topics = maxSize <$> state+  let topics = go <$> state+        where+          go s = case s of+            ExistsSymbiote s' -> maxSize s'   encodeAndSend (AvailableTopics topics)   shouldBeStart <- receiveAndDecode   case shouldBeStart of@@ -320,7 +493,10 @@   shouldBeAvailableTopics <- receiveAndDecode   case shouldBeAvailableTopics of     AvailableTopics topics -> do-      let myTopics = maxSize <$> state+      let myTopics = go <$> state+            where+              go s = case s of+                ExistsSymbiote s' -> maxSize s'       if myTopics /= topics         then do           encodeAndSend (BadTopics myTopics)@@ -362,7 +538,8 @@   | HasntReceivedFinished  -generating :: MonadIO m+generating :: forall s m them me+            . MonadIO m            => Show s            => (me s -> m ()) -- ^ Encode and send first messages            -> m (them s) -- ^ Receive and decode second messages@@ -377,7 +554,7 @@            -> (Failure them s -> m ()) -- ^ report topic failure            -> (Topic -> Float -> m ()) -- ^ report topic progress            -> Topic-           -> SymbioteState s+           -> ExistsSymbiote s            -> m () generating   encodeAndSend receiveAndDecode@@ -388,8 +565,8 @@   onSuccess   onFailure   onProgress-  topic symbioteState@SymbioteState{equal,encode'} = do-  mGenerated <- generateSymbiote symbioteState+  topic existsSymbiote = do -- symbioteState@SymbioteState{equal,encodeOut'} = do+  mGenerated <- generateSymbiote existsSymbiote -- symbioteState   case mGenerated of     DoneGenerating -> do       encodeAndSend $ makeGen topic ImFinished@@ -411,38 +588,50 @@           | secondOperatingTopic /= topic ->             onFailure $ WrongTopic topic secondOperatingTopic           | otherwise -> case shouldBeOperated of-              Operated operatedValueEncoded -> case decode operatedValueEncoded of-                Nothing -> do-                  encodeAndSend $ makeGen topic $ GeneratingNoParseOperated operatedValueEncoded-                  onFailure $ CantParseOperated topic operatedValueEncoded-                Just operatedValue -> case decode generatedValueEncoded of-                  Nothing -> onFailure $ CantParseLocalValue topic generatedValueEncoded-                  Just generatedValue -> case decodeOp generatedOperationEncoded of-                    Nothing -> onFailure $ CantParseLocalOperation topic generatedOperationEncoded-                    Just generatedOperation -> do-                      -- decoded operated value, generated value & operation-                      let expected = perform generatedOperation generatedValue-                      if equal expected operatedValue-                        then do-                          encodeAndSend $ makeGen topic YourTurn-                          progress <- getProgress symbioteState-                          onProgress topic progress-                          operating-                            encodeAndSend receiveAndDecode-                            makeGen makeOp-                            getGen getOp-                            hasSentFinishedVar hasReceivedFinishedVar-                            onFinished-                            onSuccess-                            onFailure-                            onProgress-                            topic symbioteState-                        else do-                          encodeAndSend $ makeGen topic $ BadResult operatedValueEncoded-                          onFailure $ SafeFailure topic (encode' expected) operatedValueEncoded+              Operated operatedValueEncoded -> case existsSymbiote of+                ExistsSymbiote symbioteState ->+                  let go :: forall a o+                          . Arbitrary a+                         => Arbitrary (Operation a)+                         => Symbiote a o s+                         => Eq o+                         => SymbioteState a o s -> m ()+                      go SymbioteState{decode',decodeOp',decodeOut',equal,encodeOut',perform'} = case decodeOut' operatedValueEncoded of+                        Nothing -> do+                          encodeAndSend $ makeGen topic $ GeneratingNoParseOperated operatedValueEncoded+                          onFailure $ CantParseOperated topic operatedValueEncoded+                        Just operatedValue -> case decode' generatedValueEncoded of+                          Nothing -> onFailure $ CantParseLocalValue topic generatedValueEncoded+                          Just generatedValue -> case decodeOp' generatedOperationEncoded of+                            Nothing -> onFailure $ CantParseLocalOperation topic generatedOperationEncoded+                            Just generatedOperation -> do+                              -- decoded operated value, generated value & operation+                              let expected :: o+                                  expected = perform' generatedOperation generatedValue+                              if  equal expected operatedValue+                                then do+                                  encodeAndSend $ makeGen topic YourTurn+                                  progress <- getProgress existsSymbiote+                                  onProgress topic progress+                                  operating+                                    encodeAndSend receiveAndDecode+                                    makeGen makeOp+                                    getGen getOp+                                    hasSentFinishedVar hasReceivedFinishedVar+                                    onFinished+                                    onSuccess+                                    onFailure+                                    onProgress+                                    topic existsSymbiote+                                else do+                                  encodeAndSend $ makeGen topic $ BadResult operatedValueEncoded+                                  onFailure $ SafeFailure topic (encodeOut' expected) operatedValueEncoded+                  in  go symbioteState               _ -> onFailure $ BadOperating topic shouldBeOperated         _ -> onFailure $ BadThem topic shouldBeOperating   where++    operatingTryFinished :: m ()     operatingTryFinished = do       hasReceivedFinished <- liftIO $ readTVarIO hasReceivedFinishedVar       case hasReceivedFinished of@@ -450,7 +639,7 @@           onSuccess topic           onFinished -- stop cycling - last generation in sequence is from second         HasntReceivedFinished -> do-          progress <- getProgress symbioteState+          progress <- getProgress existsSymbiote           onProgress topic progress           operating             encodeAndSend receiveAndDecode@@ -461,9 +650,10 @@             onSuccess             onFailure             onProgress-            topic symbioteState+            topic existsSymbiote -operating :: MonadIO m+operating :: forall s m them me+           . MonadIO m           => Show s           => (me s -> m ()) -- ^ Encode and send first messages           -> m (them s) -- ^ Receive and decode second messages@@ -478,7 +668,7 @@           -> (Failure them s -> m ()) -- ^ report topic failure           -> (Topic -> Float -> m ()) -- ^ report topic progress           -> Topic-          -> SymbioteState s+          -> ExistsSymbiote s           -> m () operating   encodeAndSend receiveAndDecode@@ -489,21 +679,56 @@   onSuccess   onFailure   onProgress-  topic symbioteState@SymbioteState{decode',decodeOp',perform',encode'} = do+  topic existsSymbiote = do -- symbioteState@SymbioteState{decode',decodeOp',perform',encode'} = do   shouldBeGenerating <- receiveAndDecode   case getGen shouldBeGenerating of     Just (secondGeneratingTopic,shouldBeGenerated)       | secondGeneratingTopic /= topic ->         onFailure $ WrongTopic topic secondGeneratingTopic-      | otherwise -> case shouldBeGenerated of-          ImFinished -> do-            liftIO $ atomically $ writeTVar hasReceivedFinishedVar HasReceivedFinished-            generatingTryFinished-          YourTurn -> do-            progress <- getProgress symbioteState-            onProgress topic progress-            generating-              encodeAndSend receiveAndDecode+      | otherwise -> case existsSymbiote of+          ExistsSymbiote symbioteState -> go symbioteState shouldBeGenerated -- case shouldBeGenerated of+    _ -> onFailure $ BadThem topic shouldBeGenerating+  where+    go :: forall a o+        . Arbitrary a+       => Arbitrary (Operation a)+       => Symbiote a o s+       => Eq o+       => SymbioteState a o s -> Generating s -> m ()+    go SymbioteState{decode',decodeOp',perform',encodeOut'} shouldBeGenerated = case shouldBeGenerated of+      ImFinished -> do+        liftIO $ atomically $ writeTVar hasReceivedFinishedVar HasReceivedFinished+        generatingTryFinished+      YourTurn -> do+        progress <- getProgress existsSymbiote+        onProgress topic progress+        generating+          encodeAndSend receiveAndDecode+          makeGen makeOp+          getGen getOp+          hasSentFinishedVar hasReceivedFinishedVar+          onFinished+          onSuccess+          onFailure+          onProgress+          topic existsSymbiote+      Generated+        { genValue = generatedValueEncoded+        , genOperation = generatedOperationEncoded+        } -> case decode' generatedValueEncoded of+        Nothing -> do+          encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedValueEncoded+          onFailure $ CantParseGeneratedValue topic generatedValueEncoded+        Just generatedValue -> case decodeOp' generatedOperationEncoded of+          Nothing -> do+            encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedOperationEncoded+            onFailure $ CantParseGeneratedOperation topic generatedOperationEncoded+          Just generatedOperation -> do+            encodeAndSend $ makeOp topic $ Operated $ encodeOut' $ perform' generatedOperation generatedValue+            -- wait for response+            operating+              encodeAndSend+              receiveAndDecode               makeGen makeOp               getGen getOp               hasSentFinishedVar hasReceivedFinishedVar@@ -511,35 +736,10 @@               onSuccess               onFailure               onProgress-              topic symbioteState-          Generated-            { genValue = generatedValueEncoded-            , genOperation = generatedOperationEncoded-            } -> case decode' generatedValueEncoded of-            Nothing -> do-              encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedValueEncoded-              onFailure $ CantParseGeneratedValue topic generatedValueEncoded-            Just generatedValue -> case decodeOp' generatedOperationEncoded of-              Nothing -> do-                encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedOperationEncoded-                onFailure $ CantParseGeneratedOperation topic generatedOperationEncoded-              Just generatedOperation -> do-                encodeAndSend $ makeOp topic $ Operated $ encode' $ perform' generatedOperation generatedValue-                -- wait for response-                operating-                  encodeAndSend-                  receiveAndDecode-                  makeGen makeOp-                  getGen getOp-                  hasSentFinishedVar hasReceivedFinishedVar-                  onFinished-                  onSuccess-                  onFailure-                  onProgress-                  topic symbioteState-          _ -> onFailure $ BadGenerating topic shouldBeGenerated-    _ -> onFailure $ BadThem topic shouldBeGenerating-  where+              topic existsSymbiote+      _ -> onFailure $ BadGenerating topic shouldBeGenerated++    generatingTryFinished :: m ()     generatingTryFinished = do       hasSentFinished <- liftIO $ readTVarIO hasSentFinishedVar       case hasSentFinished of@@ -547,7 +747,7 @@           onSuccess topic           onFinished -- stop cycling - last operation in sequence is from first         HasntSentFinished -> do-          progress <- getProgress symbioteState+          progress <- getProgress existsSymbiote           onProgress topic progress           generating             encodeAndSend receiveAndDecode@@ -558,7 +758,7 @@             onSuccess             onFailure             onProgress-            topic symbioteState+            topic existsSymbiote   -- | Prints to stdout and uses a local channel for a sanity-check - doesn't serialize.@@ -566,7 +766,22 @@            => MonadIO m            => Show s            => SymbioteT s m () -> m ()-simpleTest suite = do+simpleTest =+  simpleTest'+    (const (pure ()))+    (liftIO . defaultFailure)+    (liftIO . defaultFailure)+    nullProgress++simpleTest' :: MonadBaseControl IO m+            => MonadIO m+            => Show s+            => (Topic -> m ()) -- ^ report topic success+            -> (Failure Second s -> m ()) -- ^ report topic failure from first (sees second)+            -> (Failure First s -> m ()) -- ^ report topic failure from second (sees first)+            -> (Topic -> Float -> m ()) -- ^ report topic progress+            -> SymbioteT s m () -> m ()+simpleTest' onSuccess onFailureSecond onFailureFirst onProgress suite = do   firstChan <- liftIO $ atomically newTChan   secondChan <- liftIO $ atomically newTChan @@ -574,12 +789,12 @@     void $ runInBase $ firstPeer       (encodeAndSendChan firstChan)       (receiveAndDecodeChan secondChan)-      (const (pure ())) (liftIO . defaultFailure) (\a b -> liftIO $ nullProgress a b)+      onSuccess onFailureSecond onProgress       suite   secondPeer     (encodeAndSendChan secondChan)     (receiveAndDecodeChan firstChan)-    (const (pure ())) (liftIO . defaultFailure) (\a b -> liftIO $ nullProgress a b)+    onSuccess onFailureFirst onProgress     suite   liftIO (wait t)   where

@@ -0,0 +1,533 @@+{-# Language+    TypeFamilies+  , DeriveGeneric+  , OverloadedStrings+  , FlexibleInstances+  , StandaloneDeriving+  , MultiParamTypeClasses+  , GeneralizedNewtypeDeriving+  #-}++{-|++Module: Test.Serialization.Symbiote.Abides+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++This module provides newtypes for ensuring consistent functionality with respect to various class laws:+Monoids, SemiRing, etc are all included via the+<https://hackage.haskell.org/package/abides abides> library. Note: This only verifies the /consistency/+of behavior between platforms - if both platforms are broken (return @False@) /consistently/, the tests+will pass. Prevent this by implementing a local test suite with+<https://hackage.haskell.org/package/QuickCheck QuickCheck>, and use the abides property tests+directly.++-}++module Test.Serialization.Symbiote.Abides where++import Data.Aeson (ToJSON (..), FromJSON (..), object, (.=), (.:), Value (Object, String))+import Data.Aeson.Types (typeMismatch)+import Data.Serialize (Serialize (put,get))+import Data.Serialize.Put (putWord8)+import Data.Serialize.Get (getWord8)+import Control.Applicative ((<|>))+import qualified Test.Abides.Data.Semigroup as Semigroup+import qualified Test.Abides.Data.Monoid as Monoid+import qualified Test.Abides.Data.Eq as Eq+import qualified Test.Abides.Data.Ord as Ord+import qualified Test.Abides.Data.Enum as Enum+import qualified Test.Abides.Data.Semiring as Semiring+import qualified Test.Abides.Data.Ring as Ring+import qualified Test.Abides.Data.CommutativeRing as CommutativeRing+import qualified Test.Abides.Data.DivisionRing as DivisionRing+import qualified Test.Abides.Data.EuclideanRing as EuclideanRing+import Test.Serialization.Symbiote.Core (SymbioteOperation (Operation, perform))+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (oneof)+import GHC.Generics (Generic)+++newtype AbidesSemigroup a = AbidesSemigroup {getAbidesSemigroup :: a}+  deriving (Generic, Eq, Show, Semigroup, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesMonoid a = AbidesMonoid {getAbidesMonoid :: a}+  deriving (Generic, Eq, Show, Semigroup, Monoid, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesEq a = AbidesEq {getAbidesEq :: a}+  deriving (Generic, Eq, Show, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesOrd a = AbidesOrd {getAbidesOrd :: a}+  deriving (Generic, Eq, Show, Ord, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesEnum a = AbidesEnum {getAbidesEnum :: a}+  deriving (Generic, Eq, Ord, Show, Enum, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesSemiring a = AbidesSemiring {getAbidesSemiring :: a}+  deriving (Generic, Eq, Show, Num, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesRing a = AbidesRing {getAbidesRing :: a}+  deriving (Generic, Eq, Show, Num, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesCommutativeRing a = AbidesCommutativeRing {getAbidesCommutativeRing :: a}+  deriving (Generic, Eq, Show, Num, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesDivisionRing a = AbidesDivisionRing {getAbidesDivisionRing :: a}+  deriving (Generic, Eq, Show, Num, Fractional, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesEuclideanRing a = AbidesEuclideanRing {getAbidesEuclideanRing :: a}+  deriving (Generic, Eq, Show, Num, Arbitrary, ToJSON, FromJSON, Serialize)++newtype AbidesField a = AbidesField {getAbidesField :: a}+  deriving (Generic, Eq, Show, Num, Fractional, Arbitrary, ToJSON, FromJSON, Serialize)+++++instance (Semigroup a, Eq a) => SymbioteOperation (AbidesSemigroup a) Bool where+  data Operation (AbidesSemigroup a)+    = SemigroupAssociative (AbidesSemigroup a) (AbidesSemigroup a)+  perform op x = case op of+    SemigroupAssociative y z -> Semigroup.associative x y z+deriving instance Generic (Operation (AbidesSemigroup a))+deriving instance Show a => Show (Operation (AbidesSemigroup a))+instance Arbitrary a => Arbitrary (Operation (AbidesSemigroup a)) where+  arbitrary = SemigroupAssociative <$> arbitrary <*> arbitrary+instance ToJSON a => ToJSON (Operation (AbidesSemigroup a)) where+  toJSON op = case op of+    SemigroupAssociative y z -> object ["associative" .= object ["y" .= y, "z" .= z]]+instance FromJSON a => FromJSON (Operation (AbidesSemigroup a)) where+  parseJSON (Object o) = do+    o' <- o .: "associative"+    SemigroupAssociative <$> o' .: "y" <*> o' .: "z"+  parseJSON x = typeMismatch "Operation (AbidesSemigroup a)" x+instance Serialize a => Serialize (Operation (AbidesSemigroup a)) where+  put op = case op of+    SemigroupAssociative y z -> put y *> put z+  get = SemigroupAssociative <$> get <*> get++instance (Monoid a, Eq a) => SymbioteOperation (AbidesMonoid a) Bool where+  data Operation (AbidesMonoid a)+    = MonoidSemigroup (Operation (AbidesSemigroup a))+    | MonoidLeftIdentity+    | MonoidRightIdentity+  perform op x@(AbidesMonoid x') = case op of+    MonoidSemigroup op' -> perform op' (AbidesSemigroup x')+    MonoidLeftIdentity -> Monoid.leftIdentity x+    MonoidRightIdentity -> Monoid.rightIdentity x+deriving instance Generic (Operation (AbidesMonoid a))+deriving instance Show a => Show (Operation (AbidesMonoid a))+instance Arbitrary a => Arbitrary (Operation (AbidesMonoid a)) where+  arbitrary = oneof+    [ MonoidSemigroup <$> arbitrary+    , pure MonoidLeftIdentity+    , pure MonoidRightIdentity+    ]+instance ToJSON a => ToJSON (Operation (AbidesMonoid a)) where+  toJSON op = case op of+    MonoidSemigroup op' -> object ["semigroup" .= op']+    MonoidLeftIdentity -> String "leftIdentity"+    MonoidRightIdentity -> String "rightIdentity"+instance FromJSON a => FromJSON (Operation (AbidesMonoid a)) where+  parseJSON (Object o) = MonoidSemigroup <$> o .: "semigroup"+  parseJSON x@(String s)+    | s == "leftIdentity" = pure MonoidLeftIdentity+    | s == "rightIdentity" = pure MonoidRightIdentity+    | otherwise = typeMismatch "Operation (AbidesMonoid a)" x+  parseJSON x = typeMismatch "Operation (AbidesMonoid a)" x+instance Serialize a => Serialize (Operation (AbidesMonoid a)) where+  put op = case op of+    MonoidSemigroup op' -> putWord8 0 *> put op'+    MonoidLeftIdentity -> putWord8 1+    MonoidRightIdentity -> putWord8 2+  get = do+    x <- getWord8+    case x of+      0 -> MonoidSemigroup <$> get+      1 -> pure MonoidLeftIdentity+      2 -> pure MonoidRightIdentity+      _ -> fail "Operation (AbidesMonoid a)"++instance (Eq a) => SymbioteOperation (AbidesEq a) Bool where+  data Operation (AbidesEq a)+    = EqReflexive+    | EqSymmetry (AbidesEq a)+    | EqTransitive (AbidesEq a) (AbidesEq a)+    | EqNegation (AbidesEq a)+  perform op x = case op of+    EqReflexive -> Eq.reflexive x+    EqSymmetry y -> Eq.symmetry x y+    EqTransitive y z -> Eq.transitive x y z+    EqNegation y -> Eq.negation x y+deriving instance Generic (Operation (AbidesEq a))+deriving instance Show a => Show (Operation (AbidesEq a))+instance Arbitrary a => Arbitrary (Operation (AbidesEq a)) where+  arbitrary = oneof+    [ EqSymmetry <$> arbitrary+    , pure EqReflexive+    , EqTransitive <$> arbitrary <*> arbitrary+    , EqNegation <$> arbitrary+    ]+instance ToJSON a => ToJSON (Operation (AbidesEq a)) where+  toJSON op = case op of+    EqSymmetry y -> object ["symmetry" .= y]+    EqReflexive -> String "reflexive"+    EqTransitive y z -> object ["transitive" .= object ["y" .= y, "z" .= z]]+    EqNegation y -> object ["negation" .= y]+instance FromJSON a => FromJSON (Operation (AbidesEq a)) where+  parseJSON (Object o) = transitive <|> symmetry <|> negation+    where+      transitive = do+        o' <- o .: "transitive"+        EqTransitive <$> o' .: "y" <*> o' .: "z"+      symmetry = EqSymmetry <$> o .: "symmetry"+      negation = EqNegation <$> o .: "negation"+  parseJSON x@(String s)+    | s == "reflexive" = pure EqReflexive+    | otherwise = typeMismatch "Operation (AbidesEq a)" x+  parseJSON x = typeMismatch "Operation (AbidesEq a)" x+instance Serialize a => Serialize (Operation (AbidesEq a)) where+  put op = case op of+    EqSymmetry y -> putWord8 0 *> put y+    EqReflexive -> putWord8 1+    EqTransitive y z -> putWord8 2 *> put y *> put z+    EqNegation y -> putWord8 3 *> put y+  get = do+    x <- getWord8+    case x of+      0 -> EqSymmetry <$> get+      1 -> pure EqReflexive+      2 -> EqTransitive <$> get <*> get+      3 -> EqNegation <$> get+      _ -> fail "Operation (AbidesEq a)"++instance (Ord a) => SymbioteOperation (AbidesOrd a) Bool where+  data Operation (AbidesOrd a)+    = OrdReflexive+    | OrdAntiSymmetry (AbidesOrd a)+    | OrdTransitive (AbidesOrd a) (AbidesOrd a)+  perform op x = case op of+    OrdReflexive -> Ord.reflexive x+    OrdAntiSymmetry y -> Ord.antisymmetry x y+    OrdTransitive y z -> Ord.transitive x y z+deriving instance Generic (Operation (AbidesOrd a))+deriving instance Show a => Show (Operation (AbidesOrd a))+instance Arbitrary a => Arbitrary (Operation (AbidesOrd a)) where+  arbitrary = oneof+    [ OrdAntiSymmetry <$> arbitrary+    , pure OrdReflexive+    , OrdTransitive <$> arbitrary <*> arbitrary+    ]+instance ToJSON a => ToJSON (Operation (AbidesOrd a)) where+  toJSON op = case op of+    OrdReflexive -> String "reflexive"+    OrdAntiSymmetry y -> object ["antisymmetry" .= y]+    OrdTransitive y z -> object ["transitive" .= object ["y" .= y, "z" .= z]]+instance FromJSON a => FromJSON (Operation (AbidesOrd a)) where+  parseJSON (Object o) = transitive <|> antisymmetry+    where+      transitive = do+        o' <- o .: "transitive"+        OrdTransitive <$> o' .: "y" <*> o' .: "z"+      antisymmetry = OrdAntiSymmetry <$> o .: "antisymmetry"+  parseJSON x@(String s)+    | s == "reflexive" = pure OrdReflexive+    | otherwise = typeMismatch "Operation (AbidesOrd a)" x+  parseJSON x = typeMismatch "Operation (AbidesOrd a)" x+instance Serialize a => Serialize (Operation (AbidesOrd a)) where+  put op = case op of+    OrdReflexive -> putWord8 0+    OrdAntiSymmetry y -> putWord8 1 *> put y+    OrdTransitive y z -> putWord8 2 *> put y *> put z+  get = do+    x <- getWord8+    case x of+      0 -> pure OrdReflexive+      1 -> OrdAntiSymmetry <$> get+      2 -> OrdTransitive <$> get <*> get+      _ -> fail "Operation (AbidesOrd a)"++instance (Enum a, Ord a) => SymbioteOperation (AbidesEnum a) Bool where+  data Operation (AbidesEnum a)+    = EnumCompareHom (AbidesEnum a)+    | EnumPredSucc+    | EnumSuccPred+  perform op x = case op of+    EnumCompareHom y -> Enum.compareHom x y+    EnumPredSucc -> Enum.predsucc x+    EnumSuccPred -> Enum.succpred x+deriving instance Generic (Operation (AbidesEnum a))+deriving instance Show a => Show (Operation (AbidesEnum a))+instance Arbitrary a => Arbitrary (Operation (AbidesEnum a)) where+  arbitrary = oneof+    [ EnumCompareHom <$> arbitrary+    , pure EnumPredSucc+    , pure EnumSuccPred+    ]+instance ToJSON a => ToJSON (Operation (AbidesEnum a)) where+  toJSON op = case op of+    EnumCompareHom y -> object ["compareHom" .= y]+    EnumPredSucc -> String "predsucc"+    EnumSuccPred -> String "succpred"+instance FromJSON a => FromJSON (Operation (AbidesEnum a)) where+  parseJSON (Object o) = EnumCompareHom <$> o .: "compareHom"+  parseJSON x@(String s)+    | s == "predsucc" = pure EnumPredSucc+    | s == "succpred" = pure EnumSuccPred+    | otherwise = typeMismatch "Operation (AbidesEnum a)" x+  parseJSON x = typeMismatch "Operation (AbidesEnum a)" x+instance Serialize a => Serialize (Operation (AbidesEnum a)) where+  put op = case op of+    EnumCompareHom y -> putWord8 0 *> put y+    EnumPredSucc -> putWord8 1+    EnumSuccPred -> putWord8 2+  get = do+    x <- getWord8+    case x of+      0 -> EnumCompareHom <$> get+      1 -> pure EnumPredSucc+      2 -> pure EnumSuccPred+      _ -> fail "Operation (AbidesEnum a)"++instance (Num a, Eq a) => SymbioteOperation (AbidesSemiring a) Bool where+  data Operation (AbidesSemiring a)+    = SemiringCommutativeMonoid (AbidesSemiring a) (AbidesSemiring a)+    | SemiringMonoid (AbidesSemiring a) (AbidesSemiring a)+    | SemiringLeftDistributive (AbidesSemiring a) (AbidesSemiring a)+    | SemiringRightDistributive (AbidesSemiring a) (AbidesSemiring a)+    | SemiringAnnihilation+  perform op x = case op of+    SemiringCommutativeMonoid y z -> Semiring.commutativeMonoid x y z+    SemiringMonoid y z -> Semiring.monoid x y z+    SemiringLeftDistributive y z -> Semiring.leftDistributive x y z+    SemiringRightDistributive y z -> Semiring.rightDistributive x y z+    SemiringAnnihilation -> Semiring.annihilation x+deriving instance Generic (Operation (AbidesSemiring a))+deriving instance Show a => Show (Operation (AbidesSemiring a))+instance Arbitrary a => Arbitrary (Operation (AbidesSemiring a)) where+  arbitrary = oneof+    [ SemiringCommutativeMonoid <$> arbitrary <*> arbitrary+    , SemiringMonoid <$> arbitrary <*> arbitrary+    , SemiringLeftDistributive <$> arbitrary <*> arbitrary+    , SemiringRightDistributive <$> arbitrary <*> arbitrary+    , pure SemiringAnnihilation+    ]+instance ToJSON a => ToJSON (Operation (AbidesSemiring a)) where+  toJSON op = case op of+    SemiringCommutativeMonoid y z -> object ["commutativeMonoid" .= object ["y" .= y, "z" .= z]]+    SemiringMonoid y z -> object ["monoid" .= object ["y" .= y, "z" .= z]]+    SemiringLeftDistributive y z -> object ["leftDistributive" .= object ["y" .= y, "z" .= z]]+    SemiringRightDistributive y z -> object ["rightDistributive" .= object ["y" .= y, "z" .= z]]+    SemiringAnnihilation -> String "annihilation"+instance FromJSON a => FromJSON (Operation (AbidesSemiring a)) where+  parseJSON (Object o) = commutativeMonoid <|> monoid <|> leftDistributive <|> rightDistributive+    where+      commutativeMonoid = do+        o' <- o .: "commutativeMonoid"+        SemiringCommutativeMonoid <$> o' .: "y" <*> o' .: "z"+      monoid = do+        o' <- o .: "monoid"+        SemiringMonoid <$> o' .: "y" <*> o' .: "z"+      leftDistributive = do+        o' <- o .: "leftDistributive"+        SemiringLeftDistributive <$> o' .: "y" <*> o' .: "z"+      rightDistributive = do+        o' <- o .: "rightDistributive"+        SemiringRightDistributive <$> o' .: "y" <*> o' .: "z"+  parseJSON x@(String s)+    | s == "annihilation" = pure SemiringAnnihilation+    | otherwise = typeMismatch "Operation (AbidesSemiring a)" x+  parseJSON x = typeMismatch "Operation (AbidesSemiring a)" x+instance Serialize a => Serialize (Operation (AbidesSemiring a)) where+  put op = case op of+    SemiringCommutativeMonoid y z -> putWord8 0 *> put y *> put z+    SemiringMonoid y z -> putWord8 1 *> put y *> put z+    SemiringLeftDistributive y z -> putWord8 2 *> put y *> put z+    SemiringRightDistributive y z -> putWord8 3 *> put y *> put z+    SemiringAnnihilation -> putWord8 4+  get = do+    x <- getWord8+    case x of+      0 -> SemiringCommutativeMonoid <$> get <*> get+      1 -> SemiringMonoid <$> get <*> get+      2 -> SemiringLeftDistributive <$> get <*> get+      3 -> SemiringRightDistributive <$> get <*> get+      4 -> pure SemiringAnnihilation+      _ -> fail "Operation (AbidesSemiring a)"++instance (Num a, Eq a) => SymbioteOperation (AbidesRing a) Bool where+  data Operation (AbidesRing a)+    = RingSemiring (Operation (AbidesSemiring a))+    | RingAdditiveInverse+  perform op x@(AbidesRing x') = case op of+    RingSemiring op' -> perform op' (AbidesSemiring x')+    RingAdditiveInverse -> Ring.additiveInverse x+deriving instance Generic (Operation (AbidesRing a))+deriving instance Show a => Show (Operation (AbidesRing a))+instance Arbitrary a => Arbitrary (Operation (AbidesRing a)) where+  arbitrary = oneof+    [ RingSemiring <$> arbitrary+    , pure RingAdditiveInverse+    ]+instance ToJSON a => ToJSON (Operation (AbidesRing a)) where+  toJSON op = case op of+    RingSemiring op' -> object ["semiring" .= op']+    RingAdditiveInverse -> String "additiveInverse"+instance FromJSON a => FromJSON (Operation (AbidesRing a)) where+  parseJSON (Object o) = RingSemiring <$> o .: "semiring"+  parseJSON x@(String s)+    | s == "additiveInverse" = pure RingAdditiveInverse+    | otherwise = typeMismatch "Operation (AbidesRing a)" x+  parseJSON x = typeMismatch "Operation (AbidesRing a)" x+instance Serialize a => Serialize (Operation (AbidesRing a)) where+  put op = case op of+    RingSemiring op' -> putWord8 0 *> put op'+    RingAdditiveInverse -> putWord8 1+  get = do+    x <- getWord8+    case x of+      0 -> RingSemiring <$> get+      1 -> pure RingAdditiveInverse+      _ -> fail "Operation (AbidesRing a)"++instance (Num a, Eq a) => SymbioteOperation (AbidesCommutativeRing a) Bool where+  data Operation (AbidesCommutativeRing a)+    = CommutativeRingRing (Operation (AbidesRing a))+    | CommutativeRingCommutative (AbidesCommutativeRing a)+  perform op x@(AbidesCommutativeRing x') = case op of+    CommutativeRingRing op' -> perform op' (AbidesRing x')+    CommutativeRingCommutative y -> CommutativeRing.commutative x y+deriving instance Generic (Operation (AbidesCommutativeRing a))+deriving instance Show a => Show (Operation (AbidesCommutativeRing a))+instance Arbitrary a => Arbitrary (Operation (AbidesCommutativeRing a)) where+  arbitrary = oneof+    [ CommutativeRingRing <$> arbitrary+    , CommutativeRingCommutative <$> arbitrary+    ]+instance ToJSON a => ToJSON (Operation (AbidesCommutativeRing a)) where+  toJSON op = case op of+    CommutativeRingRing op' -> object ["ring" .= op']+    CommutativeRingCommutative y -> object ["commutative" .= y]+instance FromJSON a => FromJSON (Operation (AbidesCommutativeRing a)) where+  parseJSON (Object o) = ring <|> commutative+    where+      ring = CommutativeRingRing <$> o .: "ring"+      commutative = CommutativeRingCommutative <$> o .: "commutative"+  parseJSON x = typeMismatch "Operation (AbidesCommutativeRing a)" x+instance Serialize a => Serialize (Operation (AbidesCommutativeRing a)) where+  put op = case op of+    CommutativeRingRing op' -> putWord8 0 *> put op'+    CommutativeRingCommutative y -> putWord8 1 *> put y+  get = do+    x <- getWord8+    case x of+      0 -> CommutativeRingRing <$> get+      1 -> CommutativeRingCommutative <$> get+      _ -> fail "Operation (AbidesCommutativeRing a)"++instance (Fractional a, Eq a) => SymbioteOperation (AbidesDivisionRing a) Bool where+  data Operation (AbidesDivisionRing a)+    = DivisionRingRing (Operation (AbidesRing a))+    | DivisionRingInverse+  perform op x@(AbidesDivisionRing x') = case op of+    DivisionRingRing op' -> perform op' (AbidesRing x')+    DivisionRingInverse -> DivisionRing.inverse x+deriving instance Generic (Operation (AbidesDivisionRing a))+deriving instance Show a => Show (Operation (AbidesDivisionRing a))+instance Arbitrary a => Arbitrary (Operation (AbidesDivisionRing a)) where+  arbitrary = oneof+    [ DivisionRingRing <$> arbitrary+    , pure DivisionRingInverse+    ]+instance ToJSON a => ToJSON (Operation (AbidesDivisionRing a)) where+  toJSON op = case op of+    DivisionRingRing op' -> object ["ring" .= op']+    DivisionRingInverse -> String "inverse"+instance FromJSON a => FromJSON (Operation (AbidesDivisionRing a)) where+  parseJSON (Object o) = DivisionRingRing <$> o .: "ring"+  parseJSON x@(String s)+    | s == "inverse" = pure DivisionRingInverse+    | otherwise = typeMismatch "Operation (AbidesDivisionRing a)" x+  parseJSON x = typeMismatch "Operation (AbidesDivisionRing a)" x+instance Serialize a => Serialize (Operation (AbidesDivisionRing a)) where+  put op = case op of+    DivisionRingRing op' -> putWord8 0 *> put op'+    DivisionRingInverse -> putWord8 1+  get = do+    x <- getWord8+    case x of+      0 -> DivisionRingRing <$> get+      1 -> pure DivisionRingInverse+      _ -> fail "Operation (AbidesDivisionRing a)"++instance (Num a, Eq a) => SymbioteOperation (AbidesEuclideanRing a) Bool where+  data Operation (AbidesEuclideanRing a)+    = EuclideanRingCommutativeRing (Operation (AbidesCommutativeRing a))+    | EuclideanRingIntegralDomain (AbidesEuclideanRing a)+  perform op x@(AbidesEuclideanRing x') = case op of+    EuclideanRingCommutativeRing op' -> perform op' (AbidesCommutativeRing x')+    EuclideanRingIntegralDomain y -> EuclideanRing.integralDomain x y+deriving instance Generic (Operation (AbidesEuclideanRing a))+deriving instance Show a => Show (Operation (AbidesEuclideanRing a))+instance Arbitrary a => Arbitrary (Operation (AbidesEuclideanRing a)) where+  arbitrary = oneof+    [ EuclideanRingCommutativeRing <$> arbitrary+    , EuclideanRingIntegralDomain <$> arbitrary+    ]+instance ToJSON a => ToJSON (Operation (AbidesEuclideanRing a)) where+  toJSON op = case op of+    EuclideanRingCommutativeRing op' -> object ["commutativeRing" .= op']+    EuclideanRingIntegralDomain y -> object ["integralDomain" .= y]+instance FromJSON a => FromJSON (Operation (AbidesEuclideanRing a)) where+  parseJSON (Object o) = commutativeRing <|> integralDomain+    where+      commutativeRing = EuclideanRingCommutativeRing <$> o .: "commutativeRing"+      integralDomain = EuclideanRingIntegralDomain <$> o .: "integralDomain"+  parseJSON x = typeMismatch "Operation (AbidesEuclideanRing a)" x+instance Serialize a => Serialize (Operation (AbidesEuclideanRing a)) where+  put op = case op of+    EuclideanRingCommutativeRing op' -> putWord8 0 *> put op'+    EuclideanRingIntegralDomain y -> putWord8 1 *> put y+  get = do+    x <- getWord8+    case x of+      0 -> EuclideanRingCommutativeRing <$> get+      1 -> EuclideanRingIntegralDomain <$> get+      _ -> fail "Operation (AbidesEuclideanRing a)"++instance (Fractional a, Eq a) => SymbioteOperation (AbidesField a) Bool where+  data Operation (AbidesField a)+    = FieldDivisionRing (Operation (AbidesDivisionRing a))+    | FieldEuclideanRing (Operation (AbidesEuclideanRing a))+  perform op (AbidesField x') = case op of+    FieldDivisionRing op' -> perform op' (AbidesDivisionRing x')+    FieldEuclideanRing op' -> perform op' (AbidesEuclideanRing x')+deriving instance Generic (Operation (AbidesField a))+deriving instance Show a => Show (Operation (AbidesField a))+instance Arbitrary a => Arbitrary (Operation (AbidesField a)) where+  arbitrary = oneof+    [ FieldDivisionRing <$> arbitrary+    , FieldEuclideanRing <$> arbitrary+    ]+instance ToJSON a => ToJSON (Operation (AbidesField a)) where+  toJSON op = case op of+    FieldDivisionRing op' -> object ["divisionRing" .= op']+    FieldEuclideanRing y -> object ["euclideanRing" .= y]+instance FromJSON a => FromJSON (Operation (AbidesField a)) where+  parseJSON (Object o) = divisionRing <|> euclideanRing+    where+      divisionRing = FieldDivisionRing <$> o .: "divisionRing"+      euclideanRing = FieldEuclideanRing <$> o .: "euclideanRing"+  parseJSON x = typeMismatch "Operation (AbidesField a)" x+instance Serialize a => Serialize (Operation (AbidesField a)) where+  put op = case op of+    FieldDivisionRing op' -> putWord8 0 *> put op'+    FieldEuclideanRing y -> putWord8 1 *> put y+  get = do+    x <- getWord8+    case x of+      0 -> FieldDivisionRing <$> get+      1 -> FieldEuclideanRing <$> get+      _ -> fail "Operation (AbidesField a)"

@@ -5,6 +5,16 @@   , UndecidableInstances   #-} +{-|++Module: Test.Serialization.Symbiote.Aeson+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++-}+ module Test.Serialization.Symbiote.Aeson where  import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)@@ -14,11 +24,15 @@ instance   ( Json.ToJSON a   , Json.FromJSON a+  , Json.ToJSON o+  , Json.FromJSON o   , Json.ToJSON (Operation a)   , Json.FromJSON (Operation a)-  , SymbioteOperation a-  ) => Symbiote a Json.Value where+  , SymbioteOperation a o+  ) => Symbiote a o Json.Value where   encode = Json.toJSON   decode = Json.parseMaybe Json.parseJSON   encodeOp = Json.toJSON   decodeOp = Json.parseMaybe Json.parseJSON+  encodeOut _ = Json.toJSON+  decodeOut _ = Json.parseMaybe Json.parseJSON

@@ -5,6 +5,16 @@   , UndecidableInstances   #-} +{-|++Module: Test.Serialization.Symbiote.Cereal+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++-}+ module Test.Serialization.Symbiote.Cereal where  import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)@@ -13,14 +23,19 @@  instance   ( Cereal.Serialize a+  , Cereal.Serialize o   , Cereal.Serialize (Operation a)-  , SymbioteOperation a-  ) => Symbiote a BS.ByteString where+  , SymbioteOperation a o+  ) => Symbiote a o BS.ByteString where   encode = Cereal.encode   decode x = case Cereal.decode x of     Left _ -> Nothing     Right y -> Just y   encodeOp = Cereal.encode   decodeOp x = case Cereal.decode x of+    Left _ -> Nothing+    Right y -> Just y+  encodeOut _ = Cereal.encode+  decodeOut _ x = case Cereal.decode x of     Left _ -> Nothing     Right y -> Just y

@@ -5,6 +5,16 @@   , UndecidableInstances   #-} +{-|++Module: Test.Serialization.Symbiote.Cereal.Lazy+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++-}+ module Test.Serialization.Symbiote.Cereal.Lazy where  import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)@@ -13,14 +23,19 @@  instance   ( Cereal.Serialize a+  , Cereal.Serialize o   , Cereal.Serialize (Operation a)-  , SymbioteOperation a-  ) => Symbiote a LBS.ByteString where+  , SymbioteOperation a o+  ) => Symbiote a o LBS.ByteString where   encode = Cereal.encodeLazy   decode x = case Cereal.decodeLazy x of     Left _ -> Nothing     Right y -> Just y   encodeOp = Cereal.encodeLazy   decodeOp x = case Cereal.decodeLazy x of+    Left _ -> Nothing+    Right y -> Just y+  encodeOut _ = Cereal.encodeLazy+  decodeOut _ x = case Cereal.decodeLazy x of     Left _ -> Nothing     Right y -> Just y

@@ -1,20 +1,35 @@ {-# LANGUAGE-    ExistentialQuantification+    RankNTypes+  , TypeFamilies   , NamedFieldPuns-  , RankNTypes+  , FlexibleContexts   , ScopedTypeVariables-  , TypeFamilies   , MultiParamTypeClasses-  , FlexibleContexts+  , FunctionalDependencies+  , ExistentialQuantification   , GeneralizedNewtypeDeriving   #-} +{-|++Module: Test.Serialization.Symbiote.Core+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++-}+ module Test.Serialization.Symbiote.Core where  import Data.Text (Text) import Data.String (IsString) import Data.Map (Map) import qualified Data.Map as Map+import Data.Proxy (Proxy (..))+import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)+import Data.Serialize (Serialize)+import Data.Serialize.Text () import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Concurrent.STM   (TVar, readTVar, readTVarIO, modifyTVar', atomically)@@ -22,35 +37,38 @@ import Control.Monad.State (StateT, execStateT) import Test.QuickCheck.Arbitrary (Arbitrary) import Test.QuickCheck.Gen (Gen, resize)+import Test.QuickCheck.Instances () import qualified Test.QuickCheck.Gen as QC   -- | A type-level relation between a type and appropriate, testable operations on that type.-class SymbioteOperation a where+class SymbioteOperation a o | a -> o where   data Operation a :: *-  perform :: Operation a -> a -> a+  perform :: Operation a -> a -> o  -- | A serialization format for a particular type, and serialized data type.-class SymbioteOperation a => Symbiote a s where-  encode   :: a -> s-  decode   :: s -> Maybe a-  encodeOp :: Operation a -> s-  decodeOp :: s -> Maybe (Operation a)+class SymbioteOperation a o => Symbiote a o s | a -> o where+  encode    :: a -> s+  decode    :: s -> Maybe a+  encodeOut :: Proxy a -> o -> s+  decodeOut :: Proxy a -> s -> Maybe o+  encodeOp  :: Operation a -> s+  decodeOp  :: s -> Maybe (Operation a)   -- | Unique name of a type, for a suite of tests newtype Topic = Topic Text-  deriving (Eq, Ord, Show, IsString)+  deriving (Eq, Ord, Show, IsString, Arbitrary, ToJSON, FromJSON, ToJSONKey, FromJSONKey, Serialize)  -- | Protocol state for a particular topic data SymbioteProtocol a s   = MeGenerated-    { meGenValue :: a+    { meGenValue     :: a     , meGenOperation :: Operation a-    , meGenReceived :: Maybe s+    , meGenReceived  :: Maybe s -- ^ Remotely operated value     }   | ThemGenerating-    { themGen :: Maybe (s, s)+    { themGen :: Maybe (s, s) -- ^ Remotely generated value and operation     }   | NotStarted   | Finished@@ -69,33 +87,39 @@   -- | Internal existential state of a registered topic with type's facilities-data SymbioteState s =-  forall a-  . ( Arbitrary a-    , Arbitrary (Operation a)-    , Symbiote a s-    , Eq a-    ) =>+data SymbioteState a o s =   SymbioteState   { generate   :: Gen a   , generateOp :: Gen (Operation a)-  , equal      :: a -> a -> Bool+  , equal      :: o -> o -> Bool   , maxSize    :: Int   , generation :: TVar (SymbioteGeneration a s)   , encode'    :: a -> s+  , encodeOut' :: o -> s   , encodeOp'  :: Operation a -> s   , decode'    :: s -> Maybe a+  , decodeOut' :: s -> Maybe o   , decodeOp'  :: s -> Maybe (Operation a)-  , perform'   :: Operation a -> a -> a+  , perform'   :: Operation a -> a -> o   }  -type SymbioteT s m = ReaderT Bool (StateT (Map Topic (SymbioteState s)) m)+data ExistsSymbiote s =+  forall a o+  . ( Arbitrary a+    , Arbitrary (Operation a)+    , Symbiote a o s+    , Eq o+    ) =>+  ExistsSymbiote (SymbioteState a o s) ++type SymbioteT s m = ReaderT Bool (StateT (Map Topic (ExistsSymbiote s)) m)+ runSymbioteT :: Monad m              => SymbioteT s m ()              -> Bool -- ^ Is this the first peer to initiate the protocol?-             -> m (Map Topic (SymbioteState s))+             -> m (Map Topic (ExistsSymbiote s)) runSymbioteT x isFirst = execStateT (runReaderT x isFirst) Map.empty  @@ -107,8 +131,8 @@     }  -generateSymbiote :: forall s m. MonadIO m => SymbioteState s -> m (GenerateSymbiote s)-generateSymbiote SymbioteState{generate,generateOp,maxSize,generation} = do+generateSymbiote :: forall s m. MonadIO m => ExistsSymbiote s -> m (GenerateSymbiote s)+generateSymbiote (ExistsSymbiote SymbioteState{generate,generateOp,maxSize,generation}) = do   let go g@SymbioteGeneration{size} = g {size = size + 1}   SymbioteGeneration{size} <- liftIO $ atomically $ modifyTVar' generation go *> readTVar generation   if size >= maxSize@@ -121,7 +145,7 @@       pure GeneratedSymbiote{generatedValue,generatedOperation}  -getProgress :: MonadIO m => SymbioteState s -> m Float-getProgress SymbioteState{maxSize,generation} = do+getProgress :: MonadIO m => ExistsSymbiote s -> m Float+getProgress (ExistsSymbiote SymbioteState{maxSize,generation}) = do   SymbioteGeneration{size} <- liftIO $ readTVarIO generation   pure $ fromIntegral size / fromIntegral maxSize

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 118f84a8b5a0694dfff43f8d16ecdca761bc22eff9d85afce8dda972d41be76a+-- hash: 7e699fac6570783c54c6e19f435bab91f0c954666e5cf2cbf1c2190942ff8278  name:           symbiote-version:        0.0.0.1+version:        0.0.1 synopsis:       Data serialization, communication, and operation verification implementation description:    Please see the README on GitHub at <https://github.com/athanclark/symbiote#readme> category:       Data, Testing@@ -30,6 +30,7 @@ library   exposed-modules:       Test.Serialization.Symbiote+      Test.Serialization.Symbiote.Abides       Test.Serialization.Symbiote.Aeson       Test.Serialization.Symbiote.Cereal       Test.Serialization.Symbiote.Cereal.Lazy@@ -40,14 +41,17 @@       src   build-depends:       QuickCheck+    , abides     , aeson     , async     , base >=4.7 && <5     , bytestring     , cereal+    , cereal-text     , containers     , monad-control     , mtl+    , quickcheck-instances     , stm     , text   default-language: Haskell2010@@ -62,11 +66,13 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       QuickCheck+    , abides     , aeson     , async     , base >=4.7 && <5     , bytestring     , cereal+    , cereal-text     , containers     , monad-control     , mtl@@ -75,5 +81,6 @@     , symbiote     , tasty     , tasty-hunit+    , tasty-quickcheck     , text   default-language: Haskell2010

@@ -1,21 +1,23 @@ {-# LANGUAGE-    OverloadedStrings-  , MultiParamTypeClasses-  , TypeFamilies+    TypeFamilies+  , DeriveGeneric+  , FlexibleContexts+  , OverloadedStrings   , FlexibleInstances   , StandaloneDeriving-  , FlexibleContexts   , UndecidableInstances-  , DeriveGeneric+  , MultiParamTypeClasses   #-}  import Test.Tasty (defaultMain, testGroup, TestTree) import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty) import Test.Serialization.Symbiote-  ( SymbioteT, register, firstPeer, secondPeer, SymbioteOperation (..), Symbiote (..), EitherOp-  , First, Second, simpleTest)+  ( SymbioteT, register, firstPeer, secondPeer, SymbioteOperation (..), Symbiote (..), SimpleSerialization+  , First, Second, Generating, Operating, Topic, simpleTest, defaultSuccess, defaultFailure, defaultProgress) import Test.Serialization.Symbiote.Cereal () import Test.Serialization.Symbiote.Aeson ()+import Test.Serialization.Symbiote.Abides import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Gen (elements, oneof, scale, getSize) import Test.QuickCheck.Instances ()@@ -35,9 +37,59 @@  tests :: TestTree tests = testGroup "All Tests"-  [ simpleTests-  , bytestringTests-  , jsonTests+  [ testGroup "Symbiote Sanity Checks"+    [ simpleTests+    , bytestringTests+    , jsonTests+    ]+  , testGroup "Local Isomorphisms"+    [ testGroup "Json" $+      let go (n,p) = testProperty n (jsonIso p)+      in  [ testGroup "Abides"+            [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))+            , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))+            , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))+            , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))+            , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))+            , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))+            , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))+            , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))+            , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))+            , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))+            , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))+            ]+          , testGroup "Symbiote"+            [ go ("Generating Int", Proxy :: Proxy (Generating Int))+            , go ("Operating Int", Proxy :: Proxy (Operating Int))+            , go ("First Int", Proxy :: Proxy (First Int))+            , go ("Second Int", Proxy :: Proxy (Second Int))+            , go ("Topic", Proxy :: Proxy Topic)+            ]+          ]+    , testGroup "Cereal" $+      let go (n,p) = testProperty n (cerealIso p)+      in  [ testGroup "Abides"+            [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))+            , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))+            , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))+            , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))+            , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))+            , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))+            , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))+            , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))+            , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))+            , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))+            , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))+            ]+          , testGroup "Symbiote"+            [ go ("Generating Int", Proxy :: Proxy (Generating Int))+            , go ("Operating Int", Proxy :: Proxy (Operating Int))+            , go ("First Int", Proxy :: Proxy (First Int))+            , go ("Second Int", Proxy :: Proxy (Second Int))+            , go ("Topic", Proxy :: Proxy Topic)+            ]+          ]+    ]   ]   where     simpleTests :: TestTree@@ -48,13 +100,13 @@       , testCase "List over various" (simpleTest listSuite)       ]       where-        unitSuite :: SymbioteT (EitherOp ()) IO ()+        unitSuite :: SymbioteT (SimpleSerialization () ()) IO ()         unitSuite = register "Unit" 100 (Proxy :: Proxy ())-        intSuite :: SymbioteT (EitherOp Int) IO ()+        intSuite :: SymbioteT (SimpleSerialization Int Bool) IO ()         intSuite = register "Int" 100 (Proxy :: Proxy Int)-        doubleSuite :: SymbioteT (EitherOp Double) IO ()+        doubleSuite :: SymbioteT (SimpleSerialization Double Bool) IO ()         doubleSuite = register "Double" 100 (Proxy :: Proxy Double)-        listSuite :: SymbioteT (EitherOp [Int]) IO ()+        listSuite :: SymbioteT (SimpleSerialization [Int] (Either Bool [Int])) IO ()         listSuite = register "List" 100 (Proxy :: Proxy [Int])     bytestringTests :: TestTree     bytestringTests = testGroup "ByteString Tests"@@ -86,7 +138,7 @@         listSuite :: SymbioteT Json.Value IO ()         listSuite = register "List" 100 (Proxy :: Proxy [Int]) -instance SymbioteOperation () where+instance SymbioteOperation () () where   data Operation () = UnitId   perform UnitId () = () deriving instance Show (Operation ())@@ -94,88 +146,69 @@ instance Arbitrary (Operation ()) where   arbitrary = pure UnitId -instance SymbioteOperation Int where+instance SymbioteOperation Int Bool where   data Operation Int-    = AddInt Int-    | SubInt Int-    | DivInt Int-    | MulInt Int-    | ModInt Int+    = IntCommutativeRing (Operation (AbidesCommutativeRing Int))   perform op x = case op of-    AddInt y -> x + y-    SubInt y -> x - y-    DivInt y -> if y == 0 then 0 else x `div` y-    MulInt y -> x * y-    ModInt y -> if y == 0 then 0 else x `mod` y+    IntCommutativeRing op' -> perform op' (AbidesCommutativeRing x) deriving instance Show (Operation Int) deriving instance Generic (Operation Int) instance Cereal.Serialize (Operation Int) instance Json.ToJSON (Operation Int) instance Json.FromJSON (Operation Int) instance Arbitrary (Operation Int) where-  arbitrary = oneof-    [ AddInt <$> arbitrary-    , SubInt <$> arbitrary-    , DivInt <$> arbitrary-    , MulInt <$> arbitrary-    , ModInt <$> arbitrary-    ]+  arbitrary = IntCommutativeRing <$> arbitrary  -instance SymbioteOperation Double where+instance SymbioteOperation Double Bool where   data Operation Double-    = AddDouble Double-    | SubDouble Double-    | DivDouble Double-    | MulDouble Double-    | RecipDouble+    = DoubleField (Operation (AbidesField Double))   perform op x = case op of-    AddDouble y -> x + y-    SubDouble y -> x - y-    DivDouble y -> if y == 0.0 then 0.0 else x / y-    MulDouble y -> x * y-    RecipDouble -> if x == 0.0 then 0.0 else recip x+    DoubleField op' -> perform op' (AbidesField x) deriving instance Show (Operation Double) deriving instance Generic (Operation Double) instance Cereal.Serialize (Operation Double) instance Json.ToJSON (Operation Double) instance Json.FromJSON (Operation Double) instance Arbitrary (Operation Double) where-  arbitrary = oneof-    [ AddDouble <$> arbitrary-    , SubDouble <$> arbitrary-    , DivDouble <$> arbitrary-    , MulDouble <$> arbitrary-    , pure RecipDouble-    ]+  arbitrary = DoubleField <$> arbitrary -instance SymbioteOperation [a] where+instance Eq a => SymbioteOperation [a] (Either Bool [a]) where   data Operation [a]-    = ReverseList+    = ListMonoid (Operation (AbidesMonoid [a]))+    | ReverseList     | InitList     | TailList   perform op x = case op of-    ReverseList -> reverse x-    InitList -> if length x == 0 then [] else init x-    TailList -> if length x == 0 then [] else tail x-deriving instance Show (Operation [a])+    ListMonoid op' -> Left (perform op' (AbidesMonoid x))+    ReverseList -> Right (reverse x)+    InitList -> Right $ if null x then [] else init x+    TailList -> Right $ if null x then [] else tail x+deriving instance Show a => Show (Operation [a]) deriving instance Generic (Operation [a])-instance Cereal.Serialize (Operation [a])-instance Json.ToJSON (Operation [a])-instance Json.FromJSON (Operation [a])-instance Arbitrary (Operation [a]) where-  arbitrary = elements [ReverseList, InitList, TailList]+instance Cereal.Serialize a => Cereal.Serialize (Operation [a])+instance Json.ToJSON a => Json.ToJSON (Operation [a])+instance Json.FromJSON a => Json.FromJSON (Operation [a])+instance Arbitrary a => Arbitrary (Operation [a]) where+  arbitrary = oneof+    [ pure ReverseList+    , pure InitList+    , pure TailList+    , ListMonoid <$> arbitrary+    ] -instance SymbioteOperation Json.Value where+instance SymbioteOperation Json.Value Json.Value where   data Operation Json.Value = JsonId   perform _ x = x deriving instance Show (Operation Json.Value) deriving instance Generic (Operation Json.Value) instance Arbitrary (Operation Json.Value) where   arbitrary = pure JsonId-instance Symbiote Json.Value LBS.ByteString where+instance Symbiote Json.Value Json.Value LBS.ByteString where   encode = Json.encode   decode = Json.decode+  encodeOut _ = Json.encode+  decodeOut _ = Json.decode   encodeOp _ = "id"   decodeOp x | x == "id" = Just JsonId              | otherwise = Nothing@@ -193,3 +226,12 @@             , Json.Array <$> scale (`div` 2) arbitrary             , Json.Object <$> scale (`div` 2) arbitrary             ]++++jsonIso :: Json.ToJSON a => Json.FromJSON a => Eq a => Proxy a -> a -> Bool+jsonIso Proxy x = Json.decode (Json.encode x) == Just x+++cerealIso :: Cereal.Serialize a => Eq a => Proxy a -> a -> Bool+cerealIso Proxy x = Cereal.decode (Cereal.encode x) == Right x