Working with all past data types that ever existed using typed versions + type classes (Example)

Past.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}


-- | past: Compile-time checked backwards compatibility
--         Dealing with data types from the past, forever.
--
module Main where


-- | Expresses that a can be automatically be migrated to b.
class Migrate a b where
  migrate :: a -> b


-- * Sum type of what we send, with version tag each.

data Packet = Packet1 User1
            | Packet2 User2
            | Packet3 User3
            | Packet4 User4
            | Packet5 User5


-- * Versioned datatypes

data User1 = User1 { name_1 :: String }
data User2 = User2 { name_2 :: String, enabled_2 :: Bool }
data User3 = User3 { name_3 :: String, age_3 :: Int }


data Account1 = Account1 { balance_1 :: Int }
data Files1 = Files1 { fileList_1 :: [String] }

data User4 = User4 { name_4 :: String, account_4 :: Account1, files_4 :: Files1 }


data Account2 = Account2 { balance_2 :: Int, currency_2 :: String }

data User5 = User5 { name_5 :: String, account_5 :: Account2, files_5 :: Files1 }


-- * Migrations

instance Migrate User1 User2 where
  migrate (User1 name) = User2 name True

instance Migrate User3 User4 where
  migrate (User3 name _age) = User4 name (Account1 0) (Files1 [])

instance Migrate Account1 Account2 where
  migrate (Account1 balance) = Account2 balance "USD"

instance Migrate User4 User5 where
  migrate (User4 name account files) = User5 name (migrate account) files


-- * Use

class HasReport a where
  report :: a -> String


instance HasReport User1 where
  report (User1 name) = name

instance HasReport User2 where
  report (User2 name enabled) = name ++ if enabled then " (enabled)" else " (disabled)"

instance HasReport User3 where
  report (User3 name age) = name ++ ", " ++ show age ++ " years old"


class HasRenderAccount a where
  renderAccount :: a -> String

class HasRenderFiles a where
  renderFiles :: a -> String

instance HasRenderAccount Account1 where
  renderAccount (Account1 balance) = "{ balance: " ++ show balance ++ " }"

instance HasRenderFiles Files1 where
  renderFiles (Files1 fileList) = show fileList


reportWithAccountsAndFiles :: (HasRenderFiles a1, HasRenderAccount a) => [Char] -> a -> a1 -> [Char]
reportWithAccountsAndFiles name account files = name ++ ": { account: " ++ renderAccount account ++ ", files: " ++ renderFiles files

instance HasReport User4 where
  report (User4 name account files) = reportWithAccountsAndFiles name account files


instance HasRenderAccount Account2 where
  renderAccount (Account2 balance currency) = "{ balance: " ++ show balance ++ " " ++ currency ++ " }"

instance HasReport User5 where
  report (User5 name account files) = reportWithAccountsAndFiles name account files

-- By using reportWithAccountsAndFiles we can share the code of "HasReport User4" and "HasReport User5".

-- All code in the hiearchy between the changed data type (Account2) and the top level (UserN) had to be upgraded (with trivial functions).


-- * Top-level packet processing function; enumerates all versions we support.
-- If we forget to handle a version, we get a warning.
-- (At least with -W, -Wall, or -fwarn-incomplete-patterns.)

process :: Packet -> IO ()
process p = putStrLn $ case p of
  Packet1 u -> report u
  Packet2 u -> report u
  Packet3 u -> report u
  Packet4 u -> report u
  -- Packet5 u -> report u


-- * Some runtime examples

main :: IO ()
main = do
  process . Packet1 $ User1 "Niklas"
  process . Packet2 $ User2 "Niklas" True
  process . Packet3 $ User3 "Niklas" 21
  process . Packet4 $ User4 "Niklas" (Account1 100) (Files1 [])

  let user_4 = User4 "Niklas" (Account1 100) (Files1 [])
      upgraded_4_5 = migrate user_4 :: User5

  process . Packet5 $ upgraded_4_5
  process . Packet5 $ User5 "Niklas" (Account2 200 "SGD") (Files1 [])


-- * Making sure production code uses the most recent version

-- | Denotes the latest version of something.
--
-- As a reward, you get the function `versionGuard`, which you can stick
-- in front of your data types to get a compile-time notification when somebody
-- upgrades the version and you are using an older one.
--
-- Example:
--
--    User_v3 { name_v3 = "...", age_v3 = "..." }
--
-- This will go unnotified if the most recent version is changed to User_v3
--
--    versionGuard $ User_v3 { name_v3 = "...", age_v3 = "..." }
--
-- This will give a compile time error.
-- You can then decide to explicitly keep the old version or upgrade to User_v4.
class CurrentVersion a where
    versionGuard :: a -> a
    versionGuard = id