safecopy (empty) → 0.1
raw patch · 6 files changed
+307/−0 lines, 6 filesdep +basedep +binarydep +mtlbuild-type:Customsetup-changed
Dependencies added: base, binary, mtl
Files
- LICENSE +35/−0
- Setup.hs +2/−0
- safecopy.cabal +14/−0
- src/Data/SafeCopy.hs +8/−0
- src/Data/SafeCopy/Instances.hs +151/−0
- src/Data/SafeCopy/Types.hs +97/−0
+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2007, David Himmelstrup+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++ * Redistributions of source code must retain+ the above copyright notice, this list of+ conditions and the following disclaimer.+ * Redistributions in binary form must reproduce+ the above copyright notice, this list of+ conditions and the following disclaimer in the+ documentation and/or other materials provided+ with the distribution.+ * Neither the name of David Himmelstrup nor the+ names of other contributors may be used to+ endorse or promote products derived from this+ software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ safecopy.cabal view
@@ -0,0 +1,14 @@+Name: safecopy+Version: 0.1+Description: Project description+License: BSD3+License-file: LICENSE+Author: David Himmelstrup+Maintainer: lemmih@gmail.com+Build-Depends: base, mtl, binary+ghc-options: -O -fglasgow-exts+Hs-Source-Dirs: src+Exposed-Modules:+ Data.SafeCopy+ Data.SafeCopy.Types+ Data.SafeCopy.Instances
+ src/Data/SafeCopy.hs view
@@ -0,0 +1,8 @@+module Data.SafeCopy+ ( module Data.SafeCopy.Types+ , module Data.SafeCopy.Instances+ ) where++import Data.SafeCopy.Types+import Data.SafeCopy.Instances+
+ src/Data/SafeCopy/Instances.hs view
@@ -0,0 +1,151 @@+module Data.SafeCopy.Instances where++import Data.SafeCopy.Types++import Data.Word+import Data.Int+import Data.Maybe+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.Set as Set++import qualified Data.ByteString.Lazy.Char8 as L++import Control.Monad++++instance SafeCopy a => SafeCopy [a] where+ mode = Primitive+ getCopy = contain $+ do n <- get+ getSafeGet >>= replicateM n+ putCopy lst+ = contain $+ do put (length lst)+ getSafePut >>= forM_ lst++instance SafeCopy a => SafeCopy (Maybe a) where+ mode = Primitive+ getCopy = contain $ do n <- get+ if n then liftM Just safeGet+ else return Nothing+ putCopy (Just a) = contain $ put True >> safePut a+ putCopy Nothing = contain $ put False++instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where+ getCopy = contain $ fmap Set.fromList safeGet+ putCopy = contain . safePut . Set.toList++instance (SafeCopy a,SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where+ getCopy = contain $ fmap Map.fromList safeGet+ putCopy = contain . safePut . Map.toList++instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where+ getCopy = contain $ fmap IntMap.fromList safeGet+ putCopy = contain . safePut . IntMap.toList+++instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where+ mode = Primitive+ getCopy = contain $ liftM2 (,) safeGet safeGet+ putCopy (a,b) = contain $ safePut a >> safePut b+instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where+ mode = Primitive+ getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet+ putCopy (a,b,c) = contain $ safePut a >> safePut b >> safePut c+instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d) => SafeCopy (a,b,c,d) where+ mode = Primitive+ getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet+ putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d++instance SafeCopy Int where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Integer where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Float where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Double where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy L.ByteString where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Char where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Word8 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Word16 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Word32 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Word64 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Ordering where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Int8 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Int16 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Int32 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Int64 where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy () where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance SafeCopy Bool where+ mode = Primitive; getCopy = contain $ get; putCopy = contain . put+instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where+ mode = Primitive+ getCopy = contain $ do n <- get+ if n then liftM Right safeGet+ else liftM Left safeGet+ putCopy (Right a) = contain $ put True >> safePut a+ putCopy (Left a) = contain $ put False >> safePut a+++data Test1 = Test1 deriving (Read,Show)+data Test2 = Test2 [Int] deriving (Read,Show)+data Test3 = Test3 [Integer] deriving (Read,Show)+data Test4 = Test4 [Sub2] deriving (Read,Show)+data Sub1 = Sub1 Integer deriving (Read,Show)+data Sub2 = Sub2 Int deriving (Read,Show)+instance SafeCopy Test1 where getCopy = contain $ return Test1; putCopy _ = contain $ return ()+instance SafeCopy Test2 where+ version = 2+ mode = Extension (mkPrevious (Proxy :: Proxy Test1))+ getCopy = contain $ fmap Test2 get+ putCopy (Test2 lst) = contain $ put lst+instance Migrate Test1 Test2 where+ migrate Test1 = Test2 []++instance SafeCopy Test3 where+ version = 3+ mode = Extension (mkPrevious (Proxy :: Proxy Test2))+ getCopy = contain $ fmap Test3 get+ putCopy (Test3 lst) = contain $ put lst+instance Migrate Test2 Test3 where+ migrate (Test2 lst) = Test3 (map fromIntegral lst)++instance SafeCopy Test4 where+ version = 4+ mode = Extension (mkPrevious (Proxy :: Proxy Test3))+ getCopy = contain $ fmap Test4 safeGet+ putCopy (Test4 lst) = contain $ safePut lst+instance Migrate Test3 Test4 where+ migrate (Test3 lst) = Test4 (map Sub2 $ map fromIntegral lst)++instance SafeCopy Sub1 where+ getCopy = contain $ fmap Sub1 get+ putCopy (Sub1 n) = contain $ put n++instance Migrate Sub1 Sub2 where+ migrate (Sub1 n) = Sub2 (fromIntegral n)+instance SafeCopy Sub2 where+ version = 2+ mode = Extension (mkPrevious (Proxy :: Proxy Sub1))+ getCopy = contain $ fmap Sub2 get+ putCopy (Sub2 n) = contain $ put n++
+ src/Data/SafeCopy/Types.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS -fglasgow-exts #-}+module Data.SafeCopy.Types+ ( SafeCopy(..)+ , Migrate(..)+ , Mode(..)+ , Contained+ , contain+ , Proxy(..)+ , mkProxy+ , Previous+ , mkPrevious+-- , version+ , getSafeGet+ , getSafePut+ , safePut+ , safeGet+ , safeGetVersioned+ ) where++import Data.Binary as B+import Data.Binary.Put as B+import Data.Binary.Get as B+import qualified Data.ByteString.Lazy.Char8 as L+import Control.Monad++data Contained a = Contained {unsafeUnPack :: a}++contain :: a -> Contained a+contain = Contained++data Proxy a = Proxy++mkProxy :: a -> Proxy a+mkProxy _ = Proxy++asProxyType :: a -> Proxy a -> a+asProxyType a _ = a++class Migrate a b where+ migrate :: a -> b++data Previous a = forall b. (SafeCopy b, Migrate b a) => Previous (Proxy b)++mkPrevious :: forall a b. (SafeCopy b, Migrate b a) => Proxy b -> Previous a+mkPrevious Proxy = Previous (Proxy :: Proxy b)++newtype Version a = Version {unVersion :: Int} deriving (Num,Read,Show,Eq)++data Mode a = Primitive+ | Base+ | Extension (Previous a)++class SafeCopy a where+ version :: Version a+ version = 0+ mode :: Mode a+ mode = Base+ getCopy :: Contained (Get a)+ putCopy :: a -> Contained Put++instance Binary (Version a) where+ get = liftM Version get+ put = put . unVersion++getSafeGet :: forall a. SafeCopy a => Get (Get a)+getSafeGet = case mode :: Mode a of+ Primitive -> return (unsafeUnPack getCopy)+ _ -> + do v <- get+ return (safeGetVersioned v)++getSafePut :: forall a. SafeCopy a => PutM (a -> Put)+getSafePut = case mode :: Mode a of+ Primitive -> return (unsafeUnPack . putCopy)+ _ -> do B.put (version :: Version a)+ return (unsafeUnPack . putCopy)+++safePut :: forall a. SafeCopy a => a -> Put+safePut val = do fn <- getSafePut+ fn val++safeGet :: forall a. SafeCopy a => Get a+safeGet = join getSafeGet++safeGetVersioned :: forall a b. SafeCopy b => Version a -> B.Get b+safeGetVersioned v = case compareVersions v (version :: Version b) of+ GT -> error $ "Version tag too large: " ++ show v+ EQ -> unsafeUnPack getCopy+ LT -> case mode of+ Extension (Previous (_ :: Proxy f) :: Previous b)+ -> do old <- safeGetVersioned v :: B.Get f+ return $ migrate old+ _ -> error $ "No previous version"++compareVersions :: Version a -> Version b -> Ordering+compareVersions v1 v2 = compare (unVersion v1) (unVersion v2)