module Data.SafeCopy.Types
( SafeCopy(..)
, Migrate(..)
, Mode(..)
, Contained
, contain
, Proxy(..)
, mkProxy
, Previous
, mkPrevious
, 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)