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)



{-

class Versioned a where
    typeVersion :: a -> Int

data Test1 a = Test1 a
data Test2 a = Test2 a

data Sub1 = Sub1 Int; instance Versioned Sub1 where typeVersion _ = 1
data Sub2 = Sub2 String; instance Versioned Sub2 where typeVersion _ = 2

showVersion (Test1 s) = typeVersion s
-}
{-
class HotSwap a where
    hotVersion :: Version a
    hotVersion = 0
    destruct :: a -> (Int,ArgList)
    construct :: (Int,ArgList) -> a

data Test = Test Sub1 Sub2
data Sub1 = Sub1
data Sub2 = Sub2

data ArgList = Nil | forall a. HotSwap a => a :+: ArgList

infixr 5 :+:

instance HotSwap Test where
    destruct (Test a b) = (1, a :+: b :+: Nil)
    construct (1, a :+: b :+: Nil) = Test (fromHot a) (fromHot b)

instance HotSwap Sub1 where
    destruct Sub1 = (1,Nil)
    construct (1,Nil) = Sub1
instance HotSwap Sub2 where
    destruct Sub2= (1,Nil)
    construct (1,Nil) = Sub2

fromHot :: (HotSwap a, HotSwap b) => a -> b
fromHot = undefined

{-
hotSwap :: forall a b. (HotSwap a, HotSwap b) => a -> b
hotSwap inp
    = let inpVersion = hotVersion :: Version a
          outVersion = hotVersion :: Version b
      in 
-}
-}