Sort all fields and add a versioning helper

guide.cabal

@@ -53,6 +53,7 @@ library
     Markdown
     JS
     View
+    SafeCopy
   build-depends:       Spock
                      , Spock-lucid == 0.3.*
                      , acid-state == 0.14.*
@@ -61,6 +62,7 @@ library
                      , base >=4.8 && <4.9
                      , base-prelude
                      , bytestring
+                     , cereal
                      , cmark == 0.5.*
                      , cmark-highlight == 0.2.*
                      , cmark-sections == 0.1.*
@@ -71,6 +73,7 @@ library
                      , ekg
                      , ekg-core
                      , exceptions
+                     , extra
                      , feed >= 0.3.11 && < 0.4
                      , filemanip == 0.3.6.*
                      , filepath
@@ -78,6 +81,7 @@ library
                      , friendly-time == 0.4.*
                      , fsnotify == 0.2.*
                      , hashable
+                     , haskell-src-meta
                      , http-types
                      , ilist
                      , iproute == 1.7.*
@@ -102,6 +106,7 @@ library
                      , text-all == 0.3.*
                      , time >= 1.5
                      , transformers
+                     , uniplate
                      , vector
                      , wai
                      , wai-middleware-metrics

lib/SafeCopy.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE
+CPP
+  #-}
+
+
+-- Hack for bug in older Cabal versions
+#ifndef MIN_VERSION_template_haskell
+#define MIN_VERSION_template_haskell(x,y,z) 1
+#endif
+
+
+module SafeCopy
+(
+  deriveSafeCopySorted,
+)
+where
+
+
+import BasePrelude hiding (Version)
+import Data.Serialize (getWord8, putWord8, label)
+import Data.SafeCopy
+import Data.SafeCopy.Internal
+import Language.Haskell.TH.Syntax
+#if MIN_VERSION_template_haskell(2,8,0)
+import Language.Haskell.TH hiding (Kind)
+#else
+import Language.Haskell.TH hiding (Kind(..))
+#endif
+
+-- | Sorts fields (but not constructors), uses 'Simple' encoding, only works
+-- on records.
+deriveSafeCopySorted :: Version a -> Name -> Name -> Q [Dec]
+deriveSafeCopySorted = internalDeriveSafeCopySorted
+
+internalDeriveSafeCopySorted :: Version a -> Name -> Name -> Q [Dec]
+internalDeriveSafeCopySorted versionId kindName tyName = do
+  info <- reify tyName
+  internalDeriveSafeCopySorted' versionId kindName tyName info
+
+internalDeriveSafeCopySorted' :: Version a -> Name -> Name -> Info -> Q [Dec]
+internalDeriveSafeCopySorted' versionId kindName tyName info = do
+  case info of
+#if MIN_VERSION_template_haskell(2,11,0)
+    TyConI (DataD context _name tyvars _kind cons _derivs)
+#else
+    TyConI (DataD context _name tyvars cons _derivs)
+#endif
+      | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++
+                                    ". The datatype must have less than 256 constructors."
+      | otherwise         -> worker context tyvars (zip [0..] cons)
+
+#if MIN_VERSION_template_haskell(2,11,0)
+    TyConI (NewtypeD context _name tyvars _kind con _derivs) ->
+#else
+    TyConI (NewtypeD context _name tyvars con _derivs) ->
+#endif
+      worker context tyvars [(0, con)]
+
+    FamilyI _ insts -> do
+      decs <- forM insts $ \inst ->
+        case inst of
+#if MIN_VERSION_template_haskell(2,11,0)
+          DataInstD context _name ty _kind cons _derivs ->
+#else
+          DataInstD context _name ty cons _derivs ->
+#endif
+              worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)
+
+#if MIN_VERSION_template_haskell(2,11,0)
+          NewtypeInstD context _name ty _kind con _derivs ->
+#else
+          NewtypeInstD context _name ty con _derivs ->
+#endif
+              worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]
+          _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)
+      return $ concat decs
+    _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)
+  where
+    worker = worker' (conT tyName)
+    worker' tyBase context tyvars cons =
+      let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]
+#if MIN_VERSION_template_haskell(2,10,0)
+          safeCopyClass args = foldl appT (conT ''SafeCopy) args
+#else
+          safeCopyClass args = classP ''SafeCopy args
+#endif
+      in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)
+                                       (conT ''SafeCopy `appT` ty)
+                                       [ mkPutCopySorted cons
+                                       , mkGetCopySorted (show tyName) cons
+                                       , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []
+                                       , valD (varP 'kind) (normalB (varE kindName)) []
+                                       , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []]
+                                       ]
+
+mkPutCopySorted :: [(Integer, Con)] -> DecQ
+mkPutCopySorted cons =
+    funD 'putCopy (map mkPutClause cons)
+  where
+    manyConstructors = length cons > 1
+    mkPutClause (conNumber, RecC recName (sortFields -> fields)) = do
+      arg <- newName "arg"
+      let putConNumber = [|putWord8 $(lift conNumber)|]
+          putField (field, _, _) = [|safePut ($(varE field) $(varE arg))|]
+          putCopyBody = varE 'contain `appE` doE (
+                          [ noBindS putConNumber | manyConstructors ] ++
+                          [ noBindS (putField f) | f <- fields ] )
+      clause [asP arg (recP recName [])] (normalB putCopyBody) []
+    mkPutClause (_, con) =
+      fail ("Only record constructors are supported: " ++ show (conName con))
+
+mkGetCopySorted :: String -> [(Integer, Con)] -> DecQ
+mkGetCopySorted tyName cons =
+    valD (varP 'getCopy) (normalB [|contain $mkLabel|]) []
+  where
+    mkLabel = [|label $(lift labelString) $getCopyBody|]
+    labelString = tyName ++ ":"
+    getCopyBody = case cons of
+      [(_, con)] -> mkGetBody con
+      _ -> do
+        tagVar <- newName "tag"
+        let conMatch (i, con) =
+              match (litP $ IntegerL i) (normalB $ mkGetBody con) []
+        let noConMatch =
+              match wildP (normalB [|fail $(errorMsg tagVar)|]) []
+        doE [ bindS (varP tagVar) [|getWord8|]
+            , noBindS $ caseE (varE tagVar)
+                              (map conMatch cons ++ [noConMatch]) ]
+    mkGetBody (RecC recName (sortFields -> fields)) = do
+      fieldVars <- mapM newName [nameBase f | (f, _, _) <- fields]
+      let getField fieldVar = bindS (varP fieldVar) [|safeGet|]
+      let makeRecord = recConE recName
+            [(f,) <$> varE v | ((f, _, _), v) <- zip fields fieldVars]
+      doE ([ getField v | v <- fieldVars ] ++
+           [ noBindS [|return $makeRecord|] ])
+    mkGetBody con =
+      fail ("Only record constructors are supported: " ++ show (conName con))
+    errorMsg tagVar = [|$(lift s1) ++ show $(varE tagVar) ++ $(lift s2)|]
+      where
+        s1, s2 :: String
+        s1 = "Could not identify tag \""
+        s2 = concat [ "\" for type "
+                    , show tyName
+                    , " that has only "
+                    , show (length cons)
+                    , " constructors. Maybe your data is corrupted?" ]
+
+sortFields :: [VarStrictType] -> [VarStrictType]
+-- We sort by length and then lexicographically, so that relative ordering
+-- would be preserved when version suffix is added – otherwise these fields
+-- would be sorted in different order after adding a suffix:
+--
+-- foo         fooBar_v3
+-- fooBar      foo_v3
+sortFields = sortOn (\(n, _, _) -> (length (nameBase n), nameBase n))

lib/Types.hs

@@ -150,6 +150,7 @@ import Data.Acid as Acid
 
 -- Local
 import Utils
+import SafeCopy
 import Markdown
 
 
@@ -215,7 +216,7 @@ data Trait = Trait {
   deriving (Show, Generic)
 
 -- See Note [acid-state]
-deriveSafeCopySimple 2 'extension ''Trait
+deriveSafeCopySorted 3 'extension ''Trait
 makeFields ''Trait
 
 instance A.ToJSON Trait where
@@ -227,18 +228,17 @@ instance A.ToJSON Trait where
 -- template for future migrations.
 --
 -- Again, see Note [acid-state].
-data Trait_v1 = Trait_v1 {
-  _traitUid_v1 :: Uid Trait,
-  _traitContent_v1 :: MarkdownInline }
+data Trait_v2 = Trait_v2 {
+  _traitUid_v2 :: Uid Trait,
+  _traitContent_v2 :: MarkdownInline }
 
--- TODO: at the next migration change this to deriveSafeCopySimple!
-deriveSafeCopy 1 'base ''Trait_v1
+deriveSafeCopySimple 2 'base ''Trait_v2
 
 instance Migrate Trait where
-  type MigrateFrom Trait = Trait_v1
-  migrate Trait_v1{..} = Trait {
-    _traitUid = _traitUid_v1,
-    _traitContent = _traitContent_v1 }
+  type MigrateFrom Trait = Trait_v2
+  migrate Trait_v2{..} = Trait {
+    _traitUid = _traitUid_v2,
+    _traitContent = _traitContent_v2 }
 
 --
 
@@ -293,7 +293,7 @@ data Item = Item {
   _itemKind        :: ItemKind }
   deriving (Show, Generic)
 
-deriveSafeCopySimple 9 'extension ''Item
+deriveSafeCopySorted 10 'extension ''Item
 makeFields ''Item
 
 instance A.ToJSON Item where
@@ -303,41 +303,39 @@ instance A.ToJSON Item where
 -- Old version, needed for safe migration. It can most likely be already
 -- deleted (if a checkpoint has been created), but it's been left here as a
 -- template for future migrations.
-data Item_v8 = Item_v8 {
-  _itemUid_v8         :: Uid Item,
-  _itemName_v8        :: Text,
-  _itemCreated_v8     :: UTCTime,
-  _itemGroup__v8      :: Maybe Text,
-  _itemDescription_v8 :: MarkdownBlock,
-  _itemPros_v8        :: [Trait],
-  _itemProsDeleted_v8 :: [Trait],
-  _itemCons_v8        :: [Trait],
-  _itemConsDeleted_v8 :: [Trait],
-  _itemEcosystem_v8   :: MarkdownBlock,
-  _itemNotes_v8       :: MarkdownBlock,
-  _itemLink_v8        :: Maybe Url,
-  _itemKind_v8        :: ItemKind }
+data Item_v9 = Item_v9 {
+  _itemUid_v9         :: Uid Item,
+  _itemName_v9        :: Text,
+  _itemCreated_v9     :: UTCTime,
+  _itemGroup__v9      :: Maybe Text,
+  _itemDescription_v9 :: MarkdownBlock,
+  _itemPros_v9        :: [Trait],
+  _itemProsDeleted_v9 :: [Trait],
+  _itemCons_v9        :: [Trait],
+  _itemConsDeleted_v9 :: [Trait],
+  _itemEcosystem_v9   :: MarkdownBlock,
+  _itemNotes_v9       :: MarkdownBlockWithTOC,
+  _itemLink_v9        :: Maybe Url,
+  _itemKind_v9        :: ItemKind }
 
-deriveSafeCopySimple 8 'base ''Item_v8
+deriveSafeCopySimple 9 'base ''Item_v9
 
 instance Migrate Item where
-  type MigrateFrom Item = Item_v8
-  migrate Item_v8{..} = Item {
-    _itemUid = _itemUid_v8,
-    _itemName = _itemName_v8,
-    _itemCreated = _itemCreated_v8,
-    _itemGroup_ = _itemGroup__v8,
-    _itemDescription = _itemDescription_v8,
-    _itemPros = _itemPros_v8,
-    _itemProsDeleted = _itemProsDeleted_v8,
-    _itemCons = _itemCons_v8,
-    _itemConsDeleted = _itemConsDeleted_v8,
-    _itemEcosystem = _itemEcosystem_v8,
-    _itemNotes = let pref = "item-notes-" <> uidToText _itemUid_v8 <> "-"
-                     md   = _itemNotes_v8 ^. mdText
-                 in toMarkdownBlockWithTOC pref md,
-    _itemLink = _itemLink_v8,
-    _itemKind = _itemKind_v8 }
+  type MigrateFrom Item = Item_v9
+  migrate Item_v9{..} = Item {
+    _itemUid = _itemUid_v9,
+    _itemName = _itemName_v9,
+    _itemCreated = _itemCreated_v9,
+    _itemGroup_ = _itemGroup__v9,
+    _itemDescription = _itemDescription_v9,
+    _itemPros = _itemPros_v9,
+    _itemProsDeleted = _itemProsDeleted_v9,
+    _itemCons = _itemCons_v9,
+    _itemConsDeleted = _itemConsDeleted_v9,
+    _itemEcosystem = _itemEcosystem_v9,
+    _itemNotes = _itemNotes_v9,
+    _itemLink = _itemLink_v9,
+    _itemKind = _itemKind_v9 }
 
 --
 
@@ -450,7 +448,7 @@ data Category = Category {
   _categoryItemsDeleted :: [Item] }
   deriving (Show, Generic)
 
-deriveSafeCopySimple 7 'extension ''Category
+deriveSafeCopySorted 8 'extension ''Category
 makeFields ''Category
 
 instance A.ToJSON Category where
@@ -464,35 +462,35 @@ categorySlug category =
 -- Old version, needed for safe migration. It can most likely be already
 -- deleted (if a checkpoint has been created), but it's been left here as a
 -- template for future migrations.
-data Category_v6 = Category_v6 {
-  _categoryUid_v6 :: Uid Category,
-  _categoryTitle_v6 :: Text,
-  _categoryGroup_v6 :: Text,
-  _categoryCreated_v6 :: UTCTime,
-  _categoryStatus_v6 :: CategoryStatus,
-  _categoryNotes_v6 :: MarkdownBlock,
-  _categoryGroups_v6 :: Map Text Hue,
-  _categoryItems_v6 :: [Item],
-  _categoryItemsDeleted_v6 :: [Item] }
+data Category_v7 = Category_v7 {
+  _categoryUid_v7 :: Uid Category,
+  _categoryTitle_v7 :: Text,
+  _categoryGroup__v7 :: Text,
+  _categoryProsConsEnabled_v7 :: Bool,
+  _categoryEcosystemEnabled_v7 :: Bool,
+  _categoryCreated_v7 :: UTCTime,
+  _categoryStatus_v7 :: CategoryStatus,
+  _categoryNotes_v7 :: MarkdownBlock,
+  _categoryGroups_v7 :: Map Text Hue,
+  _categoryItems_v7 :: [Item],
+  _categoryItemsDeleted_v7 :: [Item] }
 
-deriveSafeCopySimple 6 'base ''Category_v6
+deriveSafeCopySimple 7 'base ''Category_v7
 
 instance Migrate Category where
-  type MigrateFrom Category = Category_v6
-  migrate Category_v6{..} = Category {
-    _categoryUid = _categoryUid_v6,
-    _categoryTitle = _categoryTitle_v6,
-    _categoryGroup_ = _categoryGroup_v6,
-    -- _categoryProsConsEnabled = _categoryProsConsEnabled_v6,
-    _categoryProsConsEnabled = True,
-    -- _categoryEcosystemEnabled = _categoryEcosystemEnabled_v6,
-    _categoryEcosystemEnabled = True,
-    _categoryCreated = _categoryCreated_v6,
-    _categoryStatus = _categoryStatus_v6,
-    _categoryNotes = _categoryNotes_v6,
-    _categoryGroups = _categoryGroups_v6,
-    _categoryItems = _categoryItems_v6,
-    _categoryItemsDeleted = _categoryItemsDeleted_v6 }
+  type MigrateFrom Category = Category_v7
+  migrate Category_v7{..} = Category {
+    _categoryUid = _categoryUid_v7,
+    _categoryTitle = _categoryTitle_v7,
+    _categoryGroup_ = _categoryGroup__v7,
+    _categoryProsConsEnabled = _categoryProsConsEnabled_v7,
+    _categoryEcosystemEnabled = _categoryEcosystemEnabled_v7,
+    _categoryCreated = _categoryCreated_v7,
+    _categoryStatus = _categoryStatus_v7,
+    _categoryNotes = _categoryNotes_v7,
+    _categoryGroups = _categoryGroups_v7,
+    _categoryItems = _categoryItems_v7,
+    _categoryItemsDeleted = _categoryItemsDeleted_v7 }
 
 -- Edits
 
@@ -716,22 +714,21 @@ data EditDetails = EditDetails {
   editId   :: Int }
   deriving (Eq, Show)
 
-deriveSafeCopySimple 2 'extension ''EditDetails
+deriveSafeCopySorted 3 'extension ''EditDetails
 
-data EditDetails_v1 = EditDetails_v1 {
-  editIP_v1   :: Maybe IP,
-  editDate_v1 :: UTCTime,
-  editId_v1   :: Int }
+data EditDetails_v2 = EditDetails_v2 {
+  editIP_v2   :: Maybe IP,
+  editDate_v2 :: UTCTime,
+  editId_v2   :: Int }
 
--- TODO: at the next migration change this to deriveSafeCopySimple!
-deriveSafeCopy 1 'base ''EditDetails_v1
+deriveSafeCopySimple 2 'base ''EditDetails_v2
 
 instance Migrate EditDetails where
-  type MigrateFrom EditDetails = EditDetails_v1
-  migrate EditDetails_v1{..} = EditDetails {
-    editIP = editIP_v1,
-    editDate = editDate_v1,
-    editId = editId_v1 }
+  type MigrateFrom EditDetails = EditDetails_v2
+  migrate EditDetails_v2{..} = EditDetails {
+    editIP = editIP_v2,
+    editDate = editDate_v2,
+    editId = editId_v2 }
 
 data Action
   = Action'MainPageVisit
@@ -754,7 +751,24 @@ data ActionDetails = ActionDetails {
   actionUserAgent :: Maybe Text }
   deriving (Show)
 
-deriveSafeCopySimple 1 'base ''ActionDetails
+deriveSafeCopySorted 2 'extension ''ActionDetails
+
+data ActionDetails_v1 = ActionDetails_v1 {
+  actionIP_v1        :: Maybe IP,
+  actionDate_v1      :: UTCTime,
+  actionReferrer_v1  :: Maybe Referrer,
+  actionUserAgent_v1 :: Maybe Text }
+  deriving (Show)
+
+deriveSafeCopySimple 1 'base ''ActionDetails_v1
+
+instance Migrate ActionDetails where
+  type MigrateFrom ActionDetails = ActionDetails_v1
+  migrate ActionDetails_v1{..} = ActionDetails {
+    actionIP = actionIP_v1,
+    actionDate = actionDate_v1,
+    actionReferrer = actionReferrer_v1,
+    actionUserAgent = actionUserAgent_v1 }
 
 -- See Note [acid-state]
 
@@ -770,27 +784,28 @@ data GlobalState = GlobalState {
   _dirty :: Bool }
   deriving (Show)
 
-deriveSafeCopySimple 5 'extension ''GlobalState
+deriveSafeCopySorted 6 'extension ''GlobalState
 makeLenses ''GlobalState
 
-data GlobalState_v4 = GlobalState_v4 {
-  _categories_v4 :: [Category],
-  _categoriesDeleted_v4 :: [Category],
-  _actions_v4 :: [(Action, ActionDetails)],
-  _pendingEdits_v4 :: [(Edit, EditDetails)],
-  _editIdCounter_v4 :: Int }
+data GlobalState_v5 = GlobalState_v5 {
+  _categories_v5 :: [Category],
+  _categoriesDeleted_v5 :: [Category],
+  _actions_v5 :: [(Action, ActionDetails)],
+  _pendingEdits_v5 :: [(Edit, EditDetails)],
+  _editIdCounter_v5 :: Int,
+  _dirty_v5 :: Bool }
 
-deriveSafeCopySimple 4 'base ''GlobalState_v4
+deriveSafeCopySimple 5 'base ''GlobalState_v5
 
 instance Migrate GlobalState where
-  type MigrateFrom GlobalState = GlobalState_v4
-  migrate GlobalState_v4{..} = GlobalState {
-    _categories = _categories_v4,
-    _categoriesDeleted = _categoriesDeleted_v4,
-    _actions = _actions_v4,
-    _pendingEdits = _pendingEdits_v4,
-    _editIdCounter = _editIdCounter_v4,
-    _dirty = True }
+  type MigrateFrom GlobalState = GlobalState_v5
+  migrate GlobalState_v5{..} = GlobalState {
+    _categories = _categories_v5,
+    _categoriesDeleted = _categoriesDeleted_v5,
+    _actions = _actions_v5,
+    _pendingEdits = _pendingEdits_v5,
+    _editIdCounter = _editIdCounter_v5,
+    _dirty = _dirty_v5 }
 
 addGroupIfDoesNotExist :: Text -> Map Text Hue -> Map Text Hue
 addGroupIfDoesNotExist g gs

lib/Utils.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE
+ScopedTypeVariables,
+QuasiQuotes,
 OverloadedStrings,
 GeneralizedNewtypeDeriving,
 FlexibleContexts,
@@ -45,7 +47,13 @@ module Utils
   -- * Spock
   atomFeed,
 
+  -- * Template Haskell
+  hs,
+  dumpSplices,
+
   -- * Safecopy
+  Change(..),
+  changelog,
   GenConstructor(..),
   genVer,
   MigrateConstructor(..),
@@ -58,6 +66,8 @@ where
 
 
 import BasePrelude
+-- Lists
+import Data.List.Extra (stripSuffix)
 -- Lenses
 import Lens.Micro.Platform hiding ((&))
 -- Monads and monad transformers
@@ -65,6 +75,8 @@ import Control.Monad.Trans
 import Control.Monad.Catch
 -- Containers
 import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Map (Map)
 -- Hashable (needed for Uid)
 import Data.Hashable
 -- Randomness
@@ -78,7 +90,7 @@ import qualified Data.Aeson as A
 import qualified Network.Socket as Network
 import Data.IP
 -- Web
-import Lucid
+import Lucid hiding (for_)
 import Web.Spock
 import Text.HTML.SanitizeXSS (sanitaryURI)
 import Web.PathPieces
@@ -90,6 +102,10 @@ import qualified Text.XML.Light.Output as XML
 import Data.SafeCopy
 -- Template Haskell
 import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as TH (lift)
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.Meta (parseExp)
+import Data.Generics.Uniplate.Data (transform)
 
 
 -- | Move the -1st element that satisfies the predicate- up.
@@ -206,6 +222,168 @@ atomFeed feed = do
   setHeader "Content-Type" "application/atom+xml; charset=utf-8"
   bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))
 
+hs :: QuasiQuoter
+hs = QuasiQuoter {
+  quoteExp  = either fail TH.lift . parseExp,
+  quotePat  = fail "hs: can't parse patterns",
+  quoteType = fail "hs: can't parse types",
+  quoteDec  = fail "hs: can't parse declarations" }
+
+dumpSplices :: DecsQ -> DecsQ
+dumpSplices x = do
+  ds <- x
+  -- “reportWarning (pprint ds)” doesn't work in Emacs because of
+  -- haskell-mode's parsing of compiler messages
+  mapM_ (reportWarning . pprint) ds
+  return ds
+
+{- |
+A change from one version of a record (one constructor, several fields) to another version. We only record the latest version, so we have to be able to reconstruct the previous version knowing the current version and a list of 'Change's.
+-}
+data Change
+  -- | A field with a particular name and type was removed
+  = Removed String (Q Type)
+  -- | A field with a particular name and default value was added. We don't
+  -- have to record the type since it's already known (remember, we know what
+  -- the final version of the record is)
+  | Added String Exp
+
+{- |
+Generate previous version of the type.
+
+Assume that the new type and the changelog are, respectively:
+
+    -- version 4
+    data Foo = FooRec {
+      b :: Bool,
+      c :: Int }
+
+    changelog ''Foo 4 [
+      Removed "a" [t|String|],
+      Added "c" [|if null a then 0 else 1|] ]
+
+Then we will generate a type called Foo_v3:
+
+    data Foo_v3 = FooRec_v3 {
+      a_v3 :: String,
+      b_v3 :: Bool }
+
+We'll also generate a migration instance:
+
+    instance Migrate Foo where
+      type MigrateFrom Foo = Foo_v3
+      migrate old = FooRec {
+        b = b_v3 old,
+        c = if null (a_v3 old) then 0 else 1 }
+
+Note that you must use 'deriveSafeCopySorted' for types that use 'changelog' because otherwise fields will be parsed in the wrong order. Specifically, imagine that you have created a type with fields “b” and “a” and then removed “b”. 'changelog' has no way of knowing from “the current version has field “a”” and “the previous version also had field “b”” that the previous version had fields “b, a” and not “a, b”. Usual 'deriveSafeCopy' or 'deriveSafeCopySimple' care about field order and thus will treat “b, a” and “a, b” as different types.
+-}
+changelog
+  :: Name           -- ^ Type (without version suffix)
+  -> Int            -- ^ New version
+  -> [Change]       -- ^ List of changes between this version and previous one
+  -> DecsQ
+changelog tyName newVer changes = do
+  -- Get information about the new version of the datatype
+  TyConI (DataD _cxt _name _vars cons _deriving) <- reify tyName
+  -- Do some checks first – we only have to handle simple types for now, but
+  -- if/when we need to handle more complex ones, we want to be warned
+  unless (null _cxt) $
+    fail "changelog: can't yet work with types with context"
+  unless (null _vars) $
+    fail "changelog: can't yet work with types with variables"
+  con <- case cons of
+    [x] -> return x
+    []  -> fail "changelog: the type has to have at least one constructor"
+    _   -> fail "changelog: the type has to have only one constructor"
+  -- Check that the type is a record and that there are no strict fields
+  -- (which we cannot handle yet); when done, make a list of fields that is
+  -- easier to work with
+  (recName :: Name, fields :: [(Name, Type)]) <- case con of
+    RecC cn fs
+      | all (== NotStrict) (fs^..each._2) ->
+          return (cn, [(n, t) | (n,_,t) <- fs])
+      | otherwise -> fail "changelog: can't work with strict/unpacked fields"
+    _             -> fail "changelog: the type must be a record"
+  -- This will only be needed on newer GHC:
+  --     let normalBang = Bang NoSourceUnpackedness NoSourceStrictness
+  -- Check that all 'Added' fields are actually present in the new type
+  for_ (M.keys added) $ \n -> do
+    unless (n `elem` map (nameBase . fst) fields) $ fail $
+      printf "changelog: field %s isn't present in %s" (show n) (show tyName)
+
+  -- Now we can generate the old type based on the new type and the
+  -- changelog. First we determine the list of fields (and types) we'll have
+  -- by taking 'fields' from the new type, adding 'Removed' fields and
+  -- removing 'Added' fields:
+  let oldFields :: Map Name (Q Type)
+      oldFields = let f (Added x _) = M.delete x
+                      f (Removed n t) = M.insert n t
+                      m = M.fromList [(nameBase n, return t)
+                                       | (n,t) <- fields]
+                  in M.mapKeys (old . mkName) $ foldr f m changes
+  -- Then we construct the record constructor:
+  --   FooRec_v3 { a_v3 :: String, b_v3 :: Bool }
+  let oldRec = recC (old recName)
+                    [varStrictType fName
+                                   (strictType notStrict fType)
+                    | (fName, fType) <- M.toList oldFields]
+  -- And the data type:
+  --   data Foo_v3 = FooRec_v3 {...}
+  let oldTypeDecl = dataD (cxt [])       -- no context
+                          (old tyName)   -- name of old type
+                          []             -- no variables
+                          [oldRec]       -- one constructor
+                          []             -- not deriving anything
+
+  -- Next we generate the migration instance. It has two inner declarations.
+  -- First declaration – “type MigrateFrom Foo = Foo_v3”:
+  let migrateFromDecl =
+        tySynInstD ''MigrateFrom
+                   (tySynEqn [conT tyName] (conT (old tyName)))
+  -- Second declaration:
+  --   migrate old = FooRec {
+  --     b = b_v3 old,
+  --     c = if null (a_v3 old) then 0 else 1 }
+  migrateArg <- newName "old"
+  -- This function replaces accessors in an expression – “a” turns into
+  -- “(a_vN old)” if 'a' is one of the fields in the old type
+  let replaceAccessors = transform f
+        where f (VarE x) | old x `elem` M.keys oldFields =
+                AppE (VarE (old x)) (VarE migrateArg)
+              f x = x
+  let migrateDecl = funD 'migrate [
+        clause [varP migrateArg]
+          (normalB $ recConE recName $ do
+             (newField, _) <- fields
+             let content = case M.lookup (nameBase newField) added of
+                   Nothing -> appE (varE (old newField)) (varE migrateArg)
+                   Just e  -> return (replaceAccessors e)
+             return $ (newField,) <$> content)
+          []
+        ]
+
+  let migrateInstanceDecl =
+        instanceD
+          (cxt [])                        -- no context
+          [t|Migrate $(conT tyName)|]     -- Migrate Foo
+          [migrateFromDecl, migrateDecl]  -- associated type & migration func
+
+  -- Return everything
+  sequence [oldTypeDecl, migrateInstanceDecl]
+
+  where
+    oldVer = newVer - 1
+    -- Convert a new name to an old name by adding “_vN” to it or replacing
+    -- it if the name already has a “_v” suffix
+    old :: Name -> Name
+    old (nameBase -> n) =
+      let suffixless = fromMaybe n $ stripSuffix ("_v" ++ show newVer) n
+      in mkName (suffixless ++ "_v" ++ show oldVer)
+    -- List of 'Added' fields
+    added :: Map String Exp
+    added = M.fromList [(n, e) | Added n e <- changes]
+
 data GenConstructor = Copy Name | Custom String [(String, Name)]
 
 genVer :: Name -> Int -> [GenConstructor] -> Q [Dec]