[commit: ghc] wip/ttypeable: Clarify serialization errors (3cb0a1f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/ttypeable
Link       : http://ghc.haskell.org/trac/ghc/changeset/3cb0a1f1c0550faca70832ed78598d95d21e4873/ghc

>---------------------------------------------------------------

commit 3cb0a1f1c0550faca70832ed78598d95d21e4873
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Fri Jul 8 14:56:38 2016 +0200

    Clarify serialization errors


>---------------------------------------------------------------

3cb0a1f1c0550faca70832ed78598d95d21e4873
 compiler/utils/Binary.hs         | 33 ++++++++++++++++++++++++++-------
 libraries/ghci/GHCi/TH/Binary.hs | 33 ++++++++++++++++++++++++++-------
 2 files changed, 52 insertions(+), 14 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 29d3049..2282230 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -598,7 +598,7 @@ putTypeRep bh (TRApp f x) = do
     put_ bh (4 :: Word8)
     putTypeRep bh f
     putTypeRep bh x
-putTypeRep _ _ = fail "putTypeRep: Impossible"
+putTypeRep _ _ = fail "Binary.putTypeRep: Impossible"
 
 getTypeRepX :: BinHandle -> IO TypeRepX
 getTypeRepX bh = do
@@ -611,7 +611,10 @@ getTypeRepX bh = do
                 TypeRepX rep_k <- getTypeRepX bh
                 case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
                     Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
-                    Nothing    -> fail "getTypeRepX: Kind mismatch"
+                    Nothing    -> failure "Kind mismatch in constructor application"
+                                          [ "    Type constructor: " ++ show con
+                                          , "    Applied to type : " ++ show rep_k
+                                          ]
 
         4 -> do TypeRepX f <- getTypeRepX bh
                 TypeRepX x <- getTypeRepX bh
@@ -620,17 +623,33 @@ getTypeRepX bh = do
                         case arg `eqTypeRep` typeRepKind x of
                             Just HRefl ->
                                 pure $ TypeRepX $ mkTrApp f x
-                            _ -> fail "getTypeRepX: Kind mismatch"
-                    _ -> fail "getTypeRepX: Applied non-arrow type"
-        _ -> fail "getTypeRepX: Invalid TypeRepX"
+                            _ -> failure "Kind mismatch in type application"
+                                         [ "    Found argument of kind: " ++ show (typeRepKind x)
+                                         , "    Where the constructor:  " ++ show f
+                                         , "    Expects kind:           " ++ show arg
+                                         ]
+                    _ -> failure "Applied non-arrow"
+                                 [ "    Applied type: " ++ show f
+                                 , "    To argument:  " ++ show x
+                                 ]
+        _ -> failure "Invalid TypeRepX" []
+  where
+    failure description info =
+        fail $ unlines $ [ "Binary.getTypeRepX: "++description ]
+                      ++ map ("    "++) info
 
 instance Typeable a => Binary (TypeRep (a :: k)) where
     put_ = putTypeRep
     get bh = do
         TypeRepX rep <- getTypeRepX bh
-        case rep `eqTypeRep` (typeRep :: TypeRep a) of
+        case rep `eqTypeRep` expected of
             Just HRefl -> pure rep
-            Nothing    -> fail "Binary: Type mismatch"
+            Nothing    -> fail $ unlines
+                               [ "Binary: Type mismatch"
+                               , "    Deserialized type: " ++ show rep
+                               , "    Expected type:     " ++ show expected
+                               ]
+     where expected = typeRep :: TypeRep a
 
 instance Binary TypeRepX where
     put_ bh (TypeRepX rep) = putTypeRep bh rep
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index c60b513..e8a7a77 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -101,7 +101,7 @@ putTypeRep (TRApp f x) = do
     put (4 :: Word8)
     putTypeRep f
     putTypeRep x
-putTypeRep _ = fail "putTypeRep: Impossible"
+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"
 
 getTypeRepX :: Get TypeRepX
 getTypeRepX = do
@@ -114,7 +114,10 @@ getTypeRepX = do
                 TypeRepX rep_k <- getTypeRepX
                 case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
                     Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
-                    Nothing    -> fail "getTypeRepX: Kind mismatch"
+                    Nothing    -> failure "Kind mismatch"
+                                          [ "Type constructor: " ++ show con
+                                          , "Applied to type:  " ++ show rep_k
+                                          ]
 
         4 -> do TypeRepX f <- getTypeRepX
                 TypeRepX x <- getTypeRepX
@@ -123,17 +126,33 @@ getTypeRepX = do
                         case arg `eqTypeRep` typeRepKind x of
                             Just HRefl ->
                                 pure $ TypeRepX $ mkTrApp f x
-                            _ -> fail "getTypeRepX: Kind mismatch"
-                    _ -> fail "getTypeRepX: Applied non-arrow type"
-        _ -> fail "getTypeRepX: Invalid TypeRepX"
+                            _ -> failure "Kind mismatch"
+                                         [ "Found argument of kind:      " ++ show (typeRepKind x)
+                                         , "Where the constructor:       " ++ show f
+                                         , "Expects an argument of kind: " ++ show arg
+                                         ]
+                    _ -> failure "Applied non-arrow type"
+                                 [ "Applied type: " ++ show f
+                                 , "To argument:  " ++ show x
+                                 ]
+        _ -> failure "Invalid TypeRepX" []
+  where
+    failure description info =
+        fail $ unlines $ [ "GHCi.TH.Binary.getTypeRepX: "++description ]
+                      ++ map ("    "++) info
 
 instance Typeable a => Binary (TypeRep (a :: k)) where
     put = putTypeRep
     get = do
         TypeRepX rep <- getTypeRepX
-        case rep `eqTypeRep` (typeRep :: TypeRep a) of
+        case rep `eqTypeRep` expected of
             Just HRefl -> pure rep
-            Nothing    -> fail "Binary: Type mismatch"
+            Nothing    -> fail $ unlines
+                               [ "GHCi.TH.Binary: Type mismatch"
+                               , "    Deserialized type: " ++ show rep
+                               , "    Expected type:     " ++ show expected
+                               ]
+     where expected = typeRep :: TypeRep a
 
 instance Binary TypeRepX where
     put (TypeRepX rep) = putTypeRep rep