Datatype versioning using type families

gistfile1.hs

{-# LANGUAGE EmptyDataDecls
           , TypeFamilies
           , MultiParamTypeClasses
           , FlexibleContexts
           , FlexibleInstances
           , UndecidableInstances
           , ScopedTypeVariables
           #-}

import Control.Applicative


-- * Helpers


-- Maybe lifted to the type level.
data Nothing
data Just a

-- Type proxy, used to pass a type to a function.
data Proxy a = Proxy

-- A mapping from a type to the previous version of it.
type family PrevVersion a :: * -- Maybe *

-- Migrations between types.
class Migrate a b where
  migrate :: a -> b

-- We can migrate every type to itself.
instance Migrate a a where
  migrate = id

-- A total (safe) version of 'read'.
readMay :: Read a => String -> Maybe a
readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
              [x] -> Just x
              _   -> Nothing


-- * Pattern matching on the Maybe kind.


-- 'a' is (Maybe (PrevVersion r)), 'r' is the result of the read.
class ReadVersioned a r where
  readVersioned' :: Proxy a -> String -> Maybe r

-- If there is no previous version, we can't do anything.
instance ReadVersioned Nothing r where
  readVersioned' _ _ = Nothing

-- We try to read the 'a', which is PrevVersion r. If that doesn't
-- work, we recurse trying to read older versions of 'a'. Finally, we
-- migrate the 'a' to an 'r'.
instance (Read a, Migrate a r, ReadVersioned (PrevVersion a) a) => ReadVersioned (Just a) r where
  readVersioned' _ str = migrate <$> (readMay str <|> readVersioned' prevProxy str :: Maybe a)
    where
      prevProxy = Proxy :: Proxy (PrevVersion a)


-- * The top level function


readVersioned :: forall a. (Read a, ReadVersioned (PrevVersion a) a) => String -> Maybe a
readVersioned str = readVersioned' proxy str
  where
    proxy = Proxy :: Proxy (Just a)


-- * Some examples and tests


data User0 = User0
  { name0     :: String
  , password0 :: String
  } deriving (Show, Read, Eq)

type instance PrevVersion User0 = Nothing

data User1 = User1
  { name1     :: String
  , password1 :: String
  , admin1    :: Bool
  } deriving (Show, Read, Eq)

type instance PrevVersion User1 = Just User0
instance Migrate User0 User1 where
  migrate u0 = User1
    { name1     = name0 u0
    , password1 = password0 u0
    , admin1    = False
    }

newtype Name = Name String deriving (Show, Read, Eq)
newtype Password = Password String deriving (Show, Read, Eq)
data Role = NormalUser | PowerUser | Admin deriving (Show, Read, Eq)

data User2 = User2
  { name2     :: Name
  , password2 :: Password
  , role2     :: Role
  } deriving (Show, Read, Eq)

type instance PrevVersion User2 = Just User1
instance Migrate User1 User2 where
  migrate u1 = User2
    { name2     = Name (name1 u1)
    , password2 = Password (password1 u1)
    , role2     = if admin1 u1 then Admin else NormalUser
    }

user0  = User0 { name0 = "Erik Hesselink", password0 = "password" }
user1  = User1 { name1 = "Erik Hesselink", password1 = "password", admin1 = False }
user1' = User1 { name1 = "Erik Hesselink", password1 = "password", admin1 = True }
user2  = User2 { name2 = Name "Erik Hesselink", password2 = Password "password", role2 = NormalUser }
user2' = User2 { name2 = Name "Erik Hesselink", password2 = Password "password", role2 = Admin }

test0 = readVersioned (show user0) == Just user1
test1 = readVersioned (show user0) == Just user2
test2 = readVersioned (show user1) == Just user2
test3 = readVersioned (show user1') == Just user2'
tests = (test0, test1, test2, test3)