Add one unit test of deriveSafeCopy output

safecopy.cabal

@@ -49,6 +49,9 @@ Library
                        generic-data >= 0.3.0.0,
                        containers >= 0.3 && < 0.8,
                        old-time < 1.2,
+                       pretty,
+                       regex-tdfa,
+                       syb,
                        template-haskell >= 2.11.0.0 && < 2.23,
                        text < 1.3 || >= 2.0 && < 2.2,
                        time >= 1.6.0.1 && < 1.15,
@@ -73,9 +76,11 @@ Test-suite instances
                        containers, time, array, vector, lens >= 4.7 && < 6,
                        lens-action
                      , tasty
+                     , tasty-hunit
                      , tasty-quickcheck
                      , quickcheck-instances
                      , QuickCheck >= 2.8.2 && < 3
+                     , th-orphans
 
 Test-suite generic
   Default-language:    Haskell2010

src/Data/SafeCopy/Derive.hs

@@ -7,10 +7,17 @@ import Data.SafeCopy.SafeCopy
 
 import Language.Haskell.TH hiding (Kind)
 import Control.Monad
+import Data.Data (Data)
+import Data.Generics (everywhere, mkT)
 import Data.Maybe (fromMaybe)
 #ifdef __HADDOCK__
 import Data.Word (Word8) -- Haddock
 #endif
+import Debug.Trace (traceShowId)
+import Language.Haskell.TH.PprLib (Doc, to_HPJ_Doc)
+import Language.Haskell.TH.Syntax
+import qualified Text.PrettyPrint as HPJ
+import Text.Regex.TDFA ((=~), MatchResult(MR))
 
 -- | Derive an instance of 'SafeCopy'.
 --
@@ -251,26 +258,27 @@ internalDeriveSafeCopy' deriveType versionId kindName tyName info = do
               worker' (return nty) context [] [(0, con)]
 #else
           DataInstD context _name ty _kind cons _derivs ->
-              worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)
+              worker' (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons)
 
           NewtypeInstD context _name ty _kind con _derivs ->
-              worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]
+              worker' (foldl AppT (ConT tyName) ty) context [] [(0, con)]
 #endif
           _ -> 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 = worker' (ConT tyName)
     worker' tyBase context tyvars cons =
-      let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]
+      let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ]
+          typeNameStr = pprWithoutSuffixes ppr (ConT tyName)
           safeCopyClass args = foldl appT (conT ''SafeCopy) args
       in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)
-                                       (conT ''SafeCopy `appT` ty)
+                                       (pure (ConT ''SafeCopy `AppT` ty))
                                        [ mkPutCopy deriveType cons
-                                       , mkGetCopy deriveType (show tyName) cons
+                                       , mkGetCopy deriveType typeNameStr 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 typeNameStr) []]
                                        ]
 
 internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
@@ -437,3 +445,80 @@ typeName ListT       = "List"
 typeName (AppT t u)  = typeName t ++ typeName u
 typeName (SigT t _k) = typeName t
 typeName _           = "_"
+
+-- | Apply the TH pretty printer to a value after stripping any added
+-- suffixes from its names.  This may make it uncompilable, but it
+-- eliminates a source of randomness in the expected and actual test
+-- case results.
+pprWithoutSuffixes :: Data a => (a -> Doc) -> a -> String
+pprWithoutSuffixes pretty decs =
+  fixNames $
+  HPJ.renderStyle (HPJ.style {HPJ.lineLength = 1000000 {-HPJ.mode = HPJ.OneLineMode-}}) $
+  to_HPJ_Doc $
+  pretty $
+  everywhere (mkT unsafeName) $
+  {-fixText-} decs
+
+-- | Turn this:
+-- @@
+--   (Name (mkOccName "AppraisalValue")
+--     (NameG TcClsName (mkPkgName "appra_B8Hqp4MOZTzG2RIYHT6sPz")
+--        (mkModName "Appraisal.ReportTH")))
+-- @@
+-- into this:
+-- @@
+--   $(lift 'Appraisal.ReportTH.AppraisalValue).
+-- @@
+-- This is applied to all declarations in the generated splice file.
+fixNames :: String -> String
+fixNames s =
+    let s' = fixStrings s in
+    case (s' =~ "\\(Name \\(mkOccName \\\"([^\"]*)\"\\) \\((NameG ([^ ]*) \\(mkPkgName \\\"([^\"]*)\\\"\\) \\(mkModName \\\"([^\"]*)\\\"\\)|NameU [0-9]*)\\)\\)" :: MatchResult String) of
+      MR before _ after [name, _, "", "", ""] _ -> before <> "(mkName " <> show name <> ") " <> fixNames after
+      MR before _ after [name, _, "VarName", _, _modpath] _ -> before <>  "'" <> name <> fixNames after
+      MR before _ after [name, _, "DataName", _, _modpath] _ -> before <>  "''" <> name <> fixNames after
+      MR before _ after [name, _, "TcClsName", _, _modpath] _ -> before <>  "''" <> name <> fixNames after -- I think this is right
+      MR before _ _ _ _ -> before
+
+fixStrings :: String -> String
+fixStrings s =
+    let MR before _ after xs _ = s =~ ("\\[((" <> ws <> ch <> ")*" <> ws <> ")\\]") :: MatchResult String in
+    case xs of
+      [] -> s -- eof
+      ["", _, _, _, _] -> before <> "[]" <> fixStrings after -- empty list
+      [cs, _, _, _, _] -> before <> "\"" <> fixChars cs <> "\"" <> fixStrings after
+      _ -> error "Regular expression failure"
+
+fixChars :: String -> String
+fixChars "" = ""
+fixChars s =
+    let MR before _ after [_, c, _] _ = s =~ (ws <> ch <> ws) :: MatchResult String in before <> fixChar c <> fixChars after
+    where
+      fixChar "\\'" = "'"
+      fixChar s' = s'
+
+-- | Names with the best chance of compiling when prettyprinted:
+--    * Remove all package and module names
+--    * Remove suffixes on all constructor names
+--    * Remove suffixes on the four ids we export
+--    * Leave suffixes on all variables and type variables
+safeName :: Name -> Name
+safeName (Name oc (NameG _ns _pn _mn)) = traceShowId $ Name oc NameS
+safeName (Name oc (NameQ _mn)) = traceShowId $ Name oc NameS
+safeName (Name oc@(OccName _) (NameU _)) = traceShowId $ Name oc NameS
+safeName name@(Name _ (NameL _)) = traceShowId $ name -- Not seeing any of these
+safeName name@(Name _ NameS) = traceShowId $ name
+
+-- This will probably make the expression invalid, but it
+-- removes random elements that will make tests fail.
+unsafeName :: Name -> Name
+unsafeName (Name oc (NameG _ns _pn _mn)) = Name oc NameS
+unsafeName (Name oc (NameQ _mn)) = Name oc NameS
+unsafeName (Name oc@(OccName _) (NameU _)) = Name oc NameS
+unsafeName name@(Name _ (NameL _)) = name -- Not seeing any of these
+unsafeName name@(Name _ NameS) = name
+
+ws :: String
+ws = "(\t|\r|\n| |,)*"
+ch :: String
+ch = "'([^'\\\\]|\\\\')'"

test/instances.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -15,12 +16,15 @@ import Data.Data.Lens         (template)
 import Data.Fixed (Fixed, E1)
 import Data.List
 import Data.SafeCopy
+import Data.SafeCopy.Internal (pprWithoutSuffixes)
 import Data.Serialize (runPut, runGet)
 import Data.Time (UniversalTime(..), ZonedTime(..))
 import Data.Tree (Tree)
 import Language.Haskell.TH
+import Language.Haskell.TH.Instances ()
 import Language.Haskell.TH.Syntax
 import Test.Tasty
+import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck hiding (Fixed, (===))
 import qualified Data.Vector as V
 import qualified Data.Vector.Primitive as VP
@@ -111,4 +115,15 @@ do let a = conT ''Int
 main :: IO ()
 main = defaultMain $ testGroup "SafeCopy instances"
     [ testGroup "decode is the inverse of encode" inversions
+    , testGroup "deriveSafeCopy'"
+      [ testCase "deriveSafeCopy 0 'base ''(,,,,,,,)" $ do
+          let decs = $(lift =<< deriveSafeCopy 0 'base ''(,,,,,,,))
+          pprWithoutSuffixes ppr decs @?= intercalate "\n"
+                                    ["instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => SafeCopy ((,,,,,,,) a b c d e f g h)",
+                                     "    where putCopy ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) = contain (do {safePut_a <- getSafePut; safePut_b <- getSafePut; safePut_c <- getSafePut; safePut_d <- getSafePut; safePut_e <- getSafePut; safePut_f <- getSafePut; safePut_g <- getSafePut; safePut_h <- getSafePut; safePut_a a1; safePut_b a2; safePut_c a3; safePut_d a4; safePut_e a5; safePut_f a6; safePut_g a7; safePut_h a8; return ()})",
+                                     "          getCopy = contain (label \"(,,,,,,,):\" (do {safeGet_a <- getSafeGet; safeGet_b <- getSafeGet; safeGet_c <- getSafeGet; safeGet_d <- getSafeGet; safeGet_e <- getSafeGet; safeGet_f <- getSafeGet; safeGet_g <- getSafeGet; safeGet_h <- getSafeGet; (((((((return (,,,,,,,) <*> safeGet_a) <*> safeGet_b) <*> safeGet_c) <*> safeGet_d) <*> safeGet_e) <*> safeGet_f) <*> safeGet_g) <*> safeGet_h}))",
+                                     "          version = 0",
+                                     "          kind = base",
+                                     "          errorTypeName _ = \"(,,,,,,,)\""]
+      ]
     ]