Types.hs

{-# 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)