{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.SafeCopy.Migrate
(
deriveSafeCopySorted,
Change(..),
changelog,
hs,
GenConstructor(..),
genVer,
MigrateConstructor(..),
migrateVer,
TypeVersion(..),
)
where
import BasePrelude hiding (Version, (&))
import Data.Serialize (getWord8, putWord8, label)
import Data.SafeCopy
import qualified Data.SafeCopy.Internal as S
import Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH hiding (Kind)
import Language.Haskell.TH.Datatype
import Language.Haskell.Meta (parseExp)
import qualified Data.Map as M
import Data.Map (Map)
import Lens.Micro
import Control.Monad.Extra (whenM)
import Data.Generics.Uniplate.Data (transform)
import Data.List.Extra (stripSuffix)
deriveSafeCopySorted :: Version a -> Name -> Name -> Q [Dec]
deriveSafeCopySorted = internalDeriveSafeCopySorted
data Change
= Removed String (Q Type)
| Added String Exp
data TypeVersion = Current Int | Past Int
deriving (Show)
changelog
:: Name
-> (TypeVersion, TypeVersion)
-> [Change]
-> DecsQ
changelog _ (_newVer, Current _) _ =
fail "changelog: old version can't be 'Current'"
changelog bareTyName (newVer, Past oldVer) changes = do
let mkBare :: Name -> String
mkBare n = case newVer of
Current _ -> nameBase n
Past v ->
let suff = ("_v" ++ show v)
in case stripSuffix suff (nameBase n) of
Just n' -> n'
Nothing -> error $
printf "changelog: %s doesn't have suffix %s"
(show n) (show suff)
let mkOld, mkNew :: String -> Name
mkOld n = mkName (n ++ "_v" ++ show oldVer)
mkNew n = case newVer of
Current _ -> mkName n
Past v -> mkName (n ++ "_v" ++ show v)
let newTyName = mkNew (nameBase bareTyName)
let oldTyName = mkOld (nameBase bareTyName)
whenM (isNothing <$> lookupTypeName (nameBase newTyName)) $
fail (printf "changelog: %s not found" (show newTyName))
whenM (isJust <$> lookupTypeName (nameBase oldTyName)) $
fail (printf "changelog: %s is already present" (show oldTyName))
let added :: Map String Exp
added = M.fromList [(n, e) | Added n e <- changes]
let removed :: Map String (Q Type)
removed = M.fromList [(n, t) | Removed n t <- changes]
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- do
mbReallyTyName <- lookupTypeName (nameBase newTyName)
case mbReallyTyName of
Just reallyTyName -> reify reallyTyName
Nothing -> fail $ printf "changelog: type %s not found" (show newTyName)
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"
unless (isNothing _kind) $
fail "changelog: can't yet work with types with kinds"
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"
(recName :: String, fields :: [(String, Type)]) <- case con of
RecC cn fs
| all (== _NotStrict) (fs^..each._2) ->
return (mkBare cn, [(mkBare n, t) | (n,_,t) <- fs])
| otherwise -> fail "changelog: can't work with strict/unpacked fields"
_ -> fail "changelog: the type must be a record"
for_ (M.keys added) $ \n ->
unless (n `elem` map fst fields) $ fail $
printf "changelog: field %s isn't present in %s"
(show (mkNew n)) (show newTyName)
for_ (M.keys removed) $ \n ->
when (n `elem` map fst fields) $ fail $
printf "changelog: field %s is present in %s \
\but was supposed to be removed"
(show (mkNew n)) (show newTyName)
let oldFields :: Map String (Q Type)
oldFields = fmap return (M.fromList fields)
`M.union` removed
`M.difference` added
let oldRec = recC (mkOld recName)
[varBangType (mkOld fName)
(bangType _notStrict fType)
| (fName, fType) <- M.toList oldFields]
let oldTypeDecl = dataDCompat (cxt [])
oldTyName
[]
[oldRec]
[]
let migrateFromDecl =
tySynInstD ''MigrateFrom (tySynEqn [conT newTyName] (conT oldTyName))
migrateArg <- newName "old"
let replaceAccessors = transform f
where f (VarE x) | nameBase x `elem` M.keys oldFields =
AppE (VarE (mkOld (nameBase x))) (VarE migrateArg)
f x = x
let migrateDecl = funD 'migrate [
clause [varP migrateArg]
(normalB $ recConE (mkNew recName) $ do
(field, _) <- fields
let content = case M.lookup field added of
Nothing -> appE (varE (mkOld field)) (varE migrateArg)
Just e -> return (replaceAccessors e)
return $ (mkNew field,) <$> content)
[]
]
let migrateInstanceDecl =
instanceD
(cxt [])
[t|Migrate $(conT newTyName)|]
[migrateFromDecl, migrateDecl]
sequence [oldTypeDecl, migrateInstanceDecl]
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" }
data GenConstructor
= Copy Name
| Custom String [(String, Q Type)]
genVer
:: Name
-> Int
-> [GenConstructor]
-> Q [Dec]
genVer tyName ver constructors = do
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
unless (null _cxt) $
fail "genVer: can't yet work with types with context"
unless (null _vars) $
fail "genVer: can't yet work with types with variables"
unless (isNothing _kind) $
fail "genVer: can't yet work with types with kinds"
let oldName n = mkName (nameBase n ++ "_v" ++ show ver)
let copyConstructor conName =
case [c | c@(RecC n _) <- cons, n == conName] of
[] -> fail ("genVer: couldn't find a record constructor " ++
show conName)
[RecC _ fields] ->
recC (oldName conName)
(map return (fields & each._1 %~ oldName))
other -> fail ("genVer: copyConstructor: got " ++ show other)
let customConstructor conName fields =
recC (oldName (mkName conName))
[varBangType (oldName (mkName fName))
(bangType _notStrict fType)
| (fName, fType) <- fields]
cons' <- for constructors $ \genCons ->
case genCons of
Copy conName -> copyConstructor conName
Custom conName fields -> customConstructor conName fields
decl <- dataDCompat
(cxt [])
(oldName tyName)
[]
(map return cons')
[]
return [decl]
data MigrateConstructor
= CopyM Name
| CustomM String ExpQ
migrateVer
:: Name
-> Int
-> [MigrateConstructor]
-> Q Exp
migrateVer tyName ver constructors = do
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
unless (null _cxt) $
fail "migrateVer: can't yet work with types with context"
unless (null _vars) $
fail "migrateVer: can't yet work with types with variables"
unless (isNothing _kind) $
fail "migrateVer: can't yet work with types with kinds"
let oldName n = mkName (nameBase n ++ "_v" ++ show ver)
arg <- newName "x"
let copyConstructor conName =
case [c | c@(RecC n _) <- cons, n == conName] of
[] -> fail ("migrateVer: couldn't find a record constructor " ++
show conName)
[RecC _ fields] -> do
let getField f = varE (oldName (f ^. _1)) `appE` varE arg
match (recP (oldName conName) [])
(normalB (appsE (conE conName : map getField fields)))
[]
other -> fail ("migrateVer: copyConstructor: got " ++ show other)
let customConstructor conName res =
match (recP (oldName (mkName conName)) [])
(normalB (res `appE` varE arg))
[]
branches' <- for constructors $ \genCons ->
case genCons of
CopyM conName -> copyConstructor conName
CustomM conName res -> customConstructor conName res
lam1E (varP arg) (caseE (varE arg) (map return branches'))
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 =
case info of
TyConI (DataD context _name tyvars _kind cons _derivs)
| 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)
TyConI (NewtypeD context _name tyvars _kind con _derivs) ->
worker context tyvars [(0, con)]
FamilyI _ insts -> do
decs <- forM insts $ \inst ->
case inst of
DataInstD context _name ty _kind cons _derivs ->
worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)
NewtypeInstD context _name ty _kind con _derivs ->
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 $ S.tyVarName var | var <- tyvars ]
safeCopyClass args = foldl appT (conT ''SafeCopy) args
in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ S.tyVarName var] | var <- tyvars] ++ map return context)
(conT ''SafeCopy `appT` ty)
[ mkPutCopySorted cons
, mkGetCopySorted (show tyName) cons
, valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ S.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 (S.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 (S.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]
sortFields = sortOn (\(n, _, _) -> (length (nameBase n), nameBase n))
_NotStrict :: Bang
_NotStrict = Bang NoSourceUnpackedness NoSourceStrictness
_notStrict :: Q Bang
_notStrict = bang noSourceUnpackedness noSourceStrictness