Add SafeCopy instances

bovinespirit · Nov 6, 2013 · d4cfd8f · d4cfd8f
1 parent 8bd7775
commit d4cfd8f
Show file tree

Hide file tree

Showing 8 changed files with 133 additions and 6 deletions.
diff --git a/Data/EnumMapMap/Base.hs b/Data/EnumMapMap/Base.hs
@@ -85,6 +85,7 @@ import           Data.Bits
 import           Data.Default
 import qualified Data.Foldable as FOLD
 import           Data.Maybe (fromMaybe)
+import           Data.SafeCopy
 import           Data.Semigroup
 import           Data.Traversable (Traversable(traverse))
 import           Data.Typeable
@@ -791,6 +792,8 @@ instance (NFData k, NFData t) => NFData (k :& t)
     where
       rnf (k :& t) = rnf k `seq` rnf t
 
+-- Foldable
+
 instance (FOLD.Foldable (EnumMapMap t), Enum k, Eq k, IsKey t, HasSKey t) =>
     FOLD.Foldable (EnumMapMap (k :& t)) where
         fold (KCC emm) = go emm
@@ -809,12 +812,28 @@ instance (IsKey k, FOLD.Foldable (EnumMapMap k)) =>
     Traversable (EnumMapMap k) where
         traverse f = traverseWithKey (\_ -> f)
 
+-- Default
+
 instance (IsKey k) => Default (EnumMapMap k v) where
     def = empty
 
+-- Typeable
+
 deriving instance Typeable2 (:&)
 deriving instance Typeable2 EnumMapMap
 
+-- SafeCopy
+
+instance (Enum a, SafeCopy b) => SafeCopy (a :& b) where
+    getCopy = contain $ do
+                a <- safeGet
+                b <- safeGet
+                return (toEnum a :& b)
+    putCopy (a :& b) = contain $ do
+                         safePut $ fromEnum a
+                         safePut b
+    errorTypeName _ = "(:&)"
+
 {--------------------------------------------------------------------
   Nat conversion
 --------------------------------------------------------------------}

diff --git a/Data/EnumMapMap/Lazy.hs b/Data/EnumMapMap/Lazy.hs
@@ -35,7 +35,8 @@
   MultiParamTypeClasses,
   StandaloneDeriving,
   TypeFamilies,
-  TypeOperators #-}
+  TypeOperators,
+  UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.EnumMapMap.Lazy (
@@ -113,6 +114,7 @@ import           Control.Applicative ((<$>))
 import           Control.DeepSeq (NFData(rnf))
 import           Data.Bits
 import qualified Data.Foldable as FOLD
+import           Data.SafeCopy
 import           Data.Semigroup
 import           Data.Typeable
 
@@ -304,6 +306,20 @@ instance HasSKey (K k) where
 
 deriving instance Typeable1 K
 
+instance (Enum k) => SafeCopy (K k) where
+    getCopy = contain $ do
+                k <- safeGet
+                return $ K $ toEnum k
+    putCopy (K k) = contain $ safePut $ fromEnum k
+    errorTypeName _ = "K"
+
+-- We put this here so that it doesn't interfere with EnumMapSet version
+instance (SafeCopy k, SafeCopy v, IsKey k, Result k k v ~ v, SubKey k k v) =>
+    SafeCopy (EnumMapMap k v) where
+        getCopy = contain $ fmap fromList safeGet
+        putCopy = contain . safePut . toList
+        errorTypeName _ = "EnumMapMap"
+
 {---------------------------------------------------------------------
  Split/Join Keys
 ---------------------------------------------------------------------}

diff --git a/Data/EnumMapMap/Strict.hs b/Data/EnumMapMap/Strict.hs
@@ -36,7 +36,8 @@
   MultiParamTypeClasses,
   StandaloneDeriving,
   TypeFamilies,
-  TypeOperators #-}
+  TypeOperators,
+  UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 
@@ -115,6 +116,7 @@ import           Control.Applicative ((<$>))
 import           Control.DeepSeq (NFData(rnf))
 import           Data.Bits
 import qualified Data.Foldable as FOLD
+import           Data.SafeCopy
 import           Data.Semigroup
 import           Data.Typeable
 
@@ -306,6 +308,19 @@ instance HasSKey (K k) where
 
 deriving instance Typeable1 K
 
+instance (Enum k) => SafeCopy (K k) where
+    getCopy = contain $ do
+                k <- safeGet
+                return $ K $ toEnum k
+    putCopy (K k) = contain $ safePut $ fromEnum k
+    errorTypeName _ = "K"
+
+instance (SafeCopy k, SafeCopy v, IsKey k, Result k k v ~ v, SubKey k k v) =>
+    SafeCopy (EnumMapMap k v) where
+        getCopy = contain $ fmap fromList safeGet
+        putCopy = contain . safePut . toList
+        errorTypeName _ = "EnumMapMap"
+
 {---------------------------------------------------------------------
  Split/Join Keys
 ---------------------------------------------------------------------}

diff --git a/Data/EnumMapSet.hs b/Data/EnumMapSet.hs
@@ -27,6 +27,9 @@
 module Data.EnumMapSet (
             EnumMapSet,
             S(..), (:&)(..),
+            Result,
+            IsKey,
+            SubKey,
             -- * Query
             EMS.null,
             size,

diff --git a/Data/EnumMapSet/Base.hs b/Data/EnumMapSet/Base.hs
@@ -23,12 +23,16 @@
   MultiParamTypeClasses,
   StandaloneDeriving,
   TypeFamilies,
-  TypeOperators #-}
+  TypeOperators,
+  UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.EnumMapSet.Base (
             EnumMapSet,
             S(..), (:&)(..),
+            EMM.Result,
+            EMM.IsKey,
+            EMM.SubKey,
             -- * Query
             null,
             size,
@@ -72,6 +76,7 @@ import           Prelude hiding (lookup, map, filter, foldr, foldl,
 import           Data.Bits
 import qualified Data.List as List
 import           Data.Maybe (fromMaybe)
+import           Data.SafeCopy
 import           Data.Typeable
 import           GHC.Exts (Word(..), Int(..))
 import           GHC.Prim (indexInt8OffAddr#)
@@ -499,6 +504,21 @@ instance (Show v) => Show (EnumMapMap (S k) v) where
 
 deriving instance Typeable1 S
 
+instance (Enum s) => SafeCopy (S s) where
+    getCopy = contain $ do
+                s <- safeGet
+                return $ S $ toEnum s
+    putCopy (S s) = contain $ safePut $ fromEnum s
+    errorTypeName _ = "S"
+
+-- This can't live in EnumMapMap.Base because it calls the undefined toList and
+-- fromList functions
+instance (SafeCopy k, EMM.IsKey k, EMM.Result k k () ~ (), EMM.SubKey k k ()) =>
+    SafeCopy (EnumMapSet k) where
+        getCopy = contain $ fmap fromList safeGet
+        putCopy = contain . safePut . toList
+        errorTypeName _ = "EnumMapSet"
+
 {---------------------------------------------------------------------
   Helper functions
 ---------------------------------------------------------------------}

diff --git a/enummapmap.cabal b/enummapmap.cabal
@@ -25,6 +25,7 @@ Library
                     data-default,
                     deepseq >= 1.2 && < 1.4,
                     ghc-prim,
+                    safecopy >= 0.8 && < 0.9,
                     semigroups >= 0.8
    ghc-options:     -Wall -O2
    default-language: Haskell2010
@@ -40,7 +41,9 @@ Test-Suite test-enummapmap-lazy
                       QuickCheck >= 2,
                       hspec >= 1.3,
                       hspec-expectations,
+                      cereal >= 0.4,
                       deepseq >= 1.2 && < 1.4,
+                      safecopy >= 0.8 && < 0.9,
                       semigroups >= 0.8,
                       enummapmap
     cpp-options:      -DTESTING -DLAZY
@@ -72,7 +75,9 @@ Test-Suite test-enummapmap-strict
                       QuickCheck >= 2,
                       hspec >= 1.3,
                       hspec-expectations,
+                      cereal >= 0.4,
                       deepseq >= 1.2 && < 1.4,
+                      safecopy >= 0.8 && < 0.9,
                       semigroups >= 0.8,
                       enummapmap
     cpp-options:      -DTESTING -DSTRICT
@@ -104,7 +109,9 @@ Test-Suite test-enummapset
                       QuickCheck >= 2,
                       hspec >= 1.3,
                       hspec-expectations,
+                      cereal >= 0.4,
                       deepseq >= 1.2 && < 1.4,
+                      safecopy >= 0.8 && < 0.9,
                       containers >= 0.4.2,
                       enummapmap
 

diff --git a/test/UnitEnumMapMap.hs b/test/UnitEnumMapMap.hs
@@ -13,14 +13,19 @@
 import           Control.Exception
 import           Control.Monad (liftM, liftM2)
 import qualified Data.Foldable as Foldable
+import           Data.SafeCopy
+import           Data.Serialize.Get (runGet)
+import           Data.Serialize.Put (runPut)
 import           Data.Semigroup
 import           Data.Typeable
+
 import           Test.Hspec.Expectations
 import           Test.Hspec.HUnit ()
 import           Test.Hspec
 import           Test.Hspec.QuickCheck (prop)
 import           Test.HUnit
 import           Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf)
+
 import qualified Data.EnumMapSet as EMS
 
 #ifdef LAZY
@@ -430,3 +435,10 @@ main =
          ((typeOf l1IDtens) == (typeOf l1tens)) @?= False
       it "TypeOf is unique when different levels" $
          ((typeOf l2tens) == (typeOf l1tens)) @?= False
+
+    describe "SafeCopy instance" $ do
+      let testEq :: TestEmm3 -> Bool
+          testEq emm = op == Right emm
+              where
+                op = runGet safeGet $ runPut $ safePut emm
+      prop "Leaves data intact" testEq
diff --git a/test/UnitEnumMapSet.hs b/test/UnitEnumMapSet.hs
@@ -1,31 +1,53 @@
 {-# LANGUAGE
   CPP,
   DeriveDataTypeable,
+  FlexibleInstances,
   GeneralizedNewtypeDeriving,
-  TypeOperators #-}
+  TypeFamilies,
+  TypeOperators,
+  TypeSynonymInstances,
+  UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 import           Test.Hspec.Expectations
 import           Test.Hspec.HUnit ()
 import           Test.Hspec.QuickCheck (prop)
 import           Test.Hspec
 import           Test.HUnit
+import           Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf)
 
+import           Control.Monad (liftM, liftM2)
 import qualified Data.List as List
+import           Data.SafeCopy
+import           Data.Serialize.Get (runGet)
+import           Data.Serialize.Put (runPut)
 import           Data.Typeable
 
 import           Data.EnumMapSet (EnumMapSet, (:&)(..), S(..))
 import qualified Data.EnumMapSet as EMS
 
 newtype ID1 = ID1 Int
-    deriving (Show, Enum, Eq, Num, Typeable)
+    deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)
 newtype ID2 = ID2 Int
-    deriving (Show, Enum, Eq, Num, Typeable)
+    deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)
 
 type TestKey1 = S ID1
 type TestEms1 = EnumMapSet TestKey1
 type TestKey2 = ID2 :& S ID1
 type TestEms2 = EnumMapSet TestKey2
 
+instance (Arbitrary a, Arbitrary b) => Arbitrary (a :& b) where
+    arbitrary = liftM2 (:&) arbitrary arbitrary
+    shrink (x :& y) =    [ x' :& y | x' <- shrink x ]
+                      ++ [ x :& y' | y' <- shrink y ]
+
+instance (Arbitrary s) => Arbitrary (S s) where
+    arbitrary = liftM S arbitrary
+
+instance (Arbitrary k, EMS.Result k k () ~ (), EMS.IsKey k, EMS.SubKey k k ()) =>
+    Arbitrary (EnumMapSet k) where
+        arbitrary = fmap EMS.fromList $ listOf arbitrary
+
 tens :: [Int]
 tens = [1, 10, 100, 1000, 10000, 100000, 1000000]
 
@@ -62,9 +84,22 @@ main =
               EMS.all f (EMS.fromList list') == List.all f list'
       prop "is equivalent to List.all" prop_list
 
+    describe "toList and fromList" $ do
+      let testEq :: TestEms2 -> Bool
+          testEq emm = op == emm
+              where
+                op = EMS.fromList $ EMS.toList emm
+      prop "Leaves data intact" testEq
 
     describe "Typeable Instance" $ do
       it "TypeOf is unique when ID types differ" $
          ((typeOf l1IDtens) == (typeOf l1tens)) @?= False
       it "TypeOf is unique when different levels" $
          ((typeOf l2tens) == (typeOf l1tens)) @?= False
+
+    describe "SafeCopy Instance" $ do
+      let testEq :: TestEms2 -> Bool
+          testEq ems = op == Right ems
+              where
+                op = runGet safeGet $ runPut $ safePut ems
+      prop "Leaves data intact" testEq