safecopy 0.7.0 → 0.7.1

raw patch · 2 files changed

+11/−16 lines, 2 files

Files

• safecopy.cabal +1/−1
• src/Data/SafeCopy/Derive.hs +10/−15

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.7.0+Version:             0.7.1  -- A short (one-line) description of the package. Synopsis:            Binary serialization with version control.

@@ -9,7 +9,7 @@     , deriveSafeCopyHappstackDataIndexedType     ) where -import Data.Serialize (getWord8, putWord8)+import Data.Serialize (getWord8, putWord8, label) import Data.SafeCopy.SafeCopy  import Language.Haskell.TH hiding (Kind(..))@@ -231,24 +231,16 @@       | otherwise         -> worker context tyvars (zip [0..] cons)     TyConI (NewtypeD context _name tyvars con _derivs) ->       worker context tyvars [(0, con)]-    FamilyI _ insts -> do-      decs <- forM insts $ \inst ->-        case inst of-          DataInstD context _name ty cons _derivs ->-            worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)-          NewtypeInstD context _name ty 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+    typeName = show tyName     worker = worker' (conT tyName)     worker' tyBase context tyvars cons =       let ty = foldl appT tyBase [ varT var | PlainTV var <- tyvars ]       in (:[]) <$> instanceD (cxt $ [classP ''SafeCopy [varT var] | PlainTV var <- tyvars] ++ map return context)                                        (conT ''SafeCopy `appT` ty)                                        [ mkPutCopy deriveType cons-                                       , mkGetCopy deriveType tyName cons+                                       , mkGetCopy deriveType typeName 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)) []]@@ -276,15 +268,16 @@       return $ concat decs     _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)   where+    typeName = unwords $ map show (tyName:tyIndex')     worker' tyBase context tyvars cons =       let ty = foldl appT tyBase [ varT var | PlainTV var <- tyvars ]       in (:[]) <$> instanceD (cxt $ [classP ''SafeCopy [varT var] | PlainTV var <- tyvars] ++ map return context)                                        (conT ''SafeCopy `appT` ty)                                        [ mkPutCopy deriveType cons-                                       , mkGetCopy deriveType tyName cons+                                       , mkGetCopy deriveType typeName 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)) []]+                                       , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeName) []]                                        ]  mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ@@ -304,9 +297,11 @@                                    [ noBindS $ varE 'return `appE` tupE [] ])                clause [putClause] (normalB putCopyBody) [] -mkGetCopy :: DeriveType -> Name -> [(Integer, Con)] -> DecQ-mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` getCopyBody) []+mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ+mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) []     where+      mkLabel = varE 'label `appE` litE (stringL labelString) `appE` getCopyBody+      labelString = tyName ++ ":"       getCopyBody           = case cons of               [(_, con)] | not (forceTag deriveType) -> mkGetBody con