compiler: Remove instance Binary Charwip/no-binary-char

It is generally not a good idea to serialise strings as [Char] into interface files,
as upon deserialisation each of these would be turned into a highly memory inefficient
structure mostly composed of cons cells and pointers.

If you really want to serialise a Char, use the SerialisableChar newtype.

2 files changed, 26 insertions, 10 deletions

diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 7534d65918..6ee06274d3 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -1,5 +1,7 @@
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -81,7 +83,7 @@ module GHC.Utils.Binary
    FSTable, initFSTable, getDictFastString, putDictFastString,
 
    -- * Newtype wrappers
-   BinSpan(..), BinSrcSpan(..), BinLocated(..)
+   BinSpan(..), BinSrcSpan(..), BinLocated(..), SerialisableChar(..)
   ) where
 
 import GHC.Prelude
@@ -125,6 +127,8 @@ import qualified Data.IntMap as IntMap
 import GHC.ForeignPtr           ( unsafeWithForeignPtr )
 #endif
 
+import GHC.TypeError
+
 type BinArray = ForeignPtr Word8
 
 #if !MIN_VERSION_base(4,15,0)
@@ -675,9 +679,20 @@ instance Binary Bool where
     put_ bh b = putByte bh (fromIntegral (fromEnum b))
     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 
-instance Binary Char where
-    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
-    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance (TypeError (Text "No instance for Binary Char"
+                :$$: Text "We don't want to serialise Strings into interface files"
+                :$$: Text "Use a compact representation like " :<>: ShowType FastString :<>: Text " instead"
+                :$$: Text "If you really want to serialise you can use " :<>: ShowType SerialisableChar)
+                )
+               => Binary Char where
+    put_ = undefined
+    get = undefined
+
+newtype SerialisableChar = SerialisableChar { getSerialisedChar :: Char }
+
+instance Binary SerialisableChar where
+    put_  bh (SerialisableChar c) = put_ bh (fromIntegral (ord c) :: Word32)
+    get  bh   = do x <- get bh; return $! (SerialisableChar $ chr (fromIntegral (x :: Word32)))
 
 instance Binary Int where
     put_ bh i = put_ bh (fromIntegral i :: Int64)
diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs
index 5734905ebd..bc2dd7da48 100644
--- a/compiler/GHC/Utils/Binary/Typeable.hs
+++ b/compiler/GHC/Utils/Binary/Typeable.hs
@@ -17,6 +17,7 @@ where
 import GHC.Prelude
 
 import GHC.Utils.Binary
+import GHC.Data.FastString
 
 import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
 #if __GLASGOW_HASKELL__ >= 901
@@ -32,13 +33,13 @@ import Data.Kind (Type)
 
 instance Binary TyCon where
     put_ bh tc = do
-        put_ bh (tyConPackage tc)
-        put_ bh (tyConModule tc)
-        put_ bh (tyConName tc)
+        put_ bh (mkFastString $ tyConPackage tc)
+        put_ bh (mkFastString $ tyConModule tc)
+        put_ bh (mkFastString $ tyConName tc)
         put_ bh (tyConKindArgs tc)
         put_ bh (tyConKindRep tc)
     get bh =
-        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+        mkTyCon <$> (unpackFS <$> get bh) <*> (unpackFS <$> get bh) <*> (unpackFS <$> get bh) <*> get bh <*> get bh
 
 getSomeTypeRep :: BinHandle -> IO SomeTypeRep
 getSomeTypeRep bh = do
@@ -157,7 +158,7 @@ instance Binary KindRep where
     put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
     put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
     put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
-    put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
+    put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh (mkFastString r)
 
     get bh = do
         tag <- getByte bh
@@ -167,7 +168,7 @@ instance Binary KindRep where
           2 -> KindRepApp <$> get bh <*> get bh
           3 -> KindRepFun <$> get bh <*> get bh
           4 -> KindRepTYPE <$> get bh
-          5 -> KindRepTypeLit <$> get bh <*> get bh
+          5 -> KindRepTypeLit <$> get bh <*> (unpackFS <$> get bh)
           _ -> fail "Binary.putKindRep: invalid tag"
 
 instance Binary TypeLitSort where