Split GHC.Driver.Types

I was working on making DynFlags stateless (#17957), especially by
storing loaded plugins into HscEnv instead of DynFlags. It turned out to
be complicated because HscEnv is in GHC.Driver.Types but LoadedPlugin
isn't: it is in GHC.Driver.Plugins which depends on GHC.Driver.Types. I
didn't feel like introducing yet another hs-boot file to break the loop.

Additionally I remember that while we introduced the module hierarchy
(#13009) we talked about splitting GHC.Driver.Types because it contained
various unrelated types and functions, but we never executed. I didn't
feel like making GHC.Driver.Types bigger with more unrelated Plugins
related types, so finally I bit the bullet and split GHC.Driver.Types.

As a consequence this patch moves a lot of things. I've tried to put
them into appropriate modules but nothing is set in stone.

Several other things moved to avoid loops.

* Removed Binary instances from GHC.Utils.Binary for random compiler
  things
* Moved Typeable Binary instances into GHC.Utils.Binary.Typeable: they
  import a lot of things that users of GHC.Utils.Binary don't want to
  depend on.
* put everything related to Units/Modules under GHC.Unit:
  GHC.Unit.Finder, GHC.Unit.Module.{ModGuts,ModIface,Deps,etc.}
* Created several modules under GHC.Types: GHC.Types.Fixity, SourceText,
  etc.
* Split GHC.Utils.Error (into GHC.Types.Error)
* Finally removed GHC.Driver.Types

Note that this patch doesn't put loaded plugins into HscEnv. It's left
for another patch.

Bump haddock submodule

5 files changed, 267 insertions, 637 deletions

diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 2975ab2d0d..dbc2cdc195 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -77,7 +77,6 @@ import GHC.Utils.Panic.Plain
 import GHC.Types.Unique.FM
 import GHC.Data.FastMutInt
 import GHC.Utils.Fingerprint
-import GHC.Types.Basic
 import GHC.Types.SrcLoc
 
 import Control.DeepSeq
@@ -90,16 +89,11 @@ import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Time
 import Data.List (unfoldr)
-import Type.Reflection
-import Type.Reflection.Unsafe
-import Data.Kind (Type)
-import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
 import Control.Monad            ( when, (<$!>), unless )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
-import GHC.Serialized
 
 type BinArray = ForeignPtr Word8
 
@@ -870,184 +864,7 @@ instance Binary (Bin a) where
   put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)
   get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))
 
--- -----------------------------------------------------------------------------
--- Instances for Data.Typeable stuff
-
-instance Binary TyCon where
-    put_ bh tc = do
-        put_ bh (tyConPackage tc)
-        put_ bh (tyConModule tc)
-        put_ bh (tyConName tc)
-        put_ bh (tyConKindArgs tc)
-        put_ bh (tyConKindRep tc)
-    get bh =
-        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-
-instance Binary VecCount where
-    put_ bh = putByte bh . fromIntegral . fromEnum
-    get bh = toEnum . fromIntegral <$> getByte bh
-
-instance Binary VecElem where
-    put_ bh = putByte bh . fromIntegral . fromEnum
-    get bh = toEnum . fromIntegral <$> getByte bh
-
-instance Binary RuntimeRep where
-    put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b
-    put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
-    put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps
-    put_ bh LiftedRep       = putByte bh 3
-    put_ bh UnliftedRep     = putByte bh 4
-    put_ bh IntRep          = putByte bh 5
-    put_ bh WordRep         = putByte bh 6
-    put_ bh Int64Rep        = putByte bh 7
-    put_ bh Word64Rep       = putByte bh 8
-    put_ bh AddrRep         = putByte bh 9
-    put_ bh FloatRep        = putByte bh 10
-    put_ bh DoubleRep       = putByte bh 11
-    put_ bh Int8Rep         = putByte bh 12
-    put_ bh Word8Rep        = putByte bh 13
-    put_ bh Int16Rep        = putByte bh 14
-    put_ bh Word16Rep       = putByte bh 15
-#if __GLASGOW_HASKELL__ >= 809
-    put_ bh Int32Rep        = putByte bh 16
-    put_ bh Word32Rep       = putByte bh 17
-#endif
-
-    get bh = do
-        tag <- getByte bh
-        case tag of
-          0  -> VecRep <$> get bh <*> get bh
-          1  -> TupleRep <$> get bh
-          2  -> SumRep <$> get bh
-          3  -> pure LiftedRep
-          4  -> pure UnliftedRep
-          5  -> pure IntRep
-          6  -> pure WordRep
-          7  -> pure Int64Rep
-          8  -> pure Word64Rep
-          9  -> pure AddrRep
-          10 -> pure FloatRep
-          11 -> pure DoubleRep
-          12 -> pure Int8Rep
-          13 -> pure Word8Rep
-          14 -> pure Int16Rep
-          15 -> pure Word16Rep
-#if __GLASGOW_HASKELL__ >= 809
-          16 -> pure Int32Rep
-          17 -> pure Word32Rep
-#endif
-          _  -> fail "Binary.putRuntimeRep: invalid tag"
-
-instance Binary KindRep where
-    put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
-    put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
-    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
-
-    get bh = do
-        tag <- getByte bh
-        case tag of
-          0 -> KindRepTyConApp <$> get bh <*> get bh
-          1 -> KindRepVar <$> get bh
-          2 -> KindRepApp <$> get bh <*> get bh
-          3 -> KindRepFun <$> get bh <*> get bh
-          4 -> KindRepTYPE <$> get bh
-          5 -> KindRepTypeLit <$> get bh <*> get bh
-          _ -> fail "Binary.putKindRep: invalid tag"
-
-instance Binary TypeLitSort where
-    put_ bh TypeLitSymbol = putByte bh 0
-    put_ bh TypeLitNat = putByte bh 1
-    get bh = do
-        tag <- getByte bh
-        case tag of
-          0 -> pure TypeLitSymbol
-          1 -> pure TypeLitNat
-          _ -> fail "Binary.putTypeLitSort: invalid tag"
-
-putTypeRep :: BinHandle -> TypeRep a -> IO ()
--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
--- relations.
--- See Note [Mutually recursive representations of primitive types]
-putTypeRep bh rep
-  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
-  = put_ bh (0 :: Word8)
-putTypeRep bh (Con' con ks) = do
-    put_ bh (1 :: Word8)
-    put_ bh con
-    put_ bh ks
-putTypeRep bh (App f x) = do
-    put_ bh (2 :: Word8)
-    putTypeRep bh f
-    putTypeRep bh x
-putTypeRep bh (Fun arg res) = do
-    put_ bh (3 :: Word8)
-    putTypeRep bh arg
-    putTypeRep bh res
-
-getSomeTypeRep :: BinHandle -> IO SomeTypeRep
-getSomeTypeRep bh = do
-    tag <- get bh :: IO Word8
-    case tag of
-        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
-        1 -> do con <- get bh :: IO TyCon
-                ks <- get bh :: IO [SomeTypeRep]
-                return $ SomeTypeRep $ mkTrCon con ks
-
-        2 -> do SomeTypeRep f <- getSomeTypeRep bh
-                SomeTypeRep x <- getSomeTypeRep bh
-                case typeRepKind f of
-                  Fun arg res ->
-                      case arg `eqTypeRep` typeRepKind x of
-                        Just HRefl ->
-                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
-                              Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
-                              _ -> failure "Kind mismatch in type application" []
-                        _ -> 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
-                       ]
-        3 -> do SomeTypeRep arg <- getSomeTypeRep bh
-                SomeTypeRep res <- getSomeTypeRep bh
-                if
-                  | App argkcon _ <- typeRepKind arg
-                  , App reskcon _ <- typeRepKind res
-                  , Just HRefl <- argkcon `eqTypeRep` tYPErep
-                  , Just HRefl <- reskcon `eqTypeRep` tYPErep
-                  -> return $ SomeTypeRep $ Fun arg res
-                  | otherwise -> failure "Kind mismatch" []
-        _ -> failure "Invalid SomeTypeRep" []
-  where
-    tYPErep :: TypeRep TYPE
-    tYPErep = typeRep
 
-    failure description info =
-        fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
-                      ++ map ("    "++) info
-
-instance Typeable a => Binary (TypeRep (a :: k)) where
-    put_ = putTypeRep
-    get bh = do
-        SomeTypeRep rep <- getSomeTypeRep bh
-        case rep `eqTypeRep` expected of
-            Just HRefl -> pure rep
-            Nothing    -> fail $ unlines
-                               [ "Binary: Type mismatch"
-                               , "    Deserialized type: " ++ show rep
-                               , "    Expected type:     " ++ show expected
-                               ]
-     where expected = typeRep :: TypeRep a
-
-instance Binary SomeTypeRep where
-    put_ bh (SomeTypeRep rep) = putTypeRep bh rep
-    get = getSomeTypeRep
 
 -- -----------------------------------------------------------------------------
 -- Lazy reading/writing
@@ -1212,207 +1029,10 @@ instance Binary FastString where
 deriving instance Binary NonDetFastString
 deriving instance Binary LexicalFastString
 
--- Here to avoid loop
-instance Binary LeftOrRight where
-   put_ bh CLeft  = putByte bh 0
-   put_ bh CRight = putByte bh 1
-
-   get bh = do { h <- getByte bh
-               ; case h of
-                   0 -> return CLeft
-                   _ -> return CRight }
-
-instance Binary PromotionFlag where
-   put_ bh NotPromoted = putByte bh 0
-   put_ bh IsPromoted  = putByte bh 1
-
-   get bh = do
-       n <- getByte bh
-       case n of
-         0 -> return NotPromoted
-         1 -> return IsPromoted
-         _ -> fail "Binary(IsPromoted): fail)"
-
 instance Binary Fingerprint where
   put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
   get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
 
-instance Binary FunctionOrData where
-    put_ bh IsFunction = putByte bh 0
-    put_ bh IsData     = putByte bh 1
-    get bh = do
-        h <- getByte bh
-        case h of
-          0 -> return IsFunction
-          1 -> return IsData
-          _ -> panic "Binary FunctionOrData"
-
-instance Binary TupleSort where
-    put_ bh BoxedTuple      = putByte bh 0
-    put_ bh UnboxedTuple    = putByte bh 1
-    put_ bh ConstraintTuple = putByte bh 2
-    get bh = do
-      h <- getByte bh
-      case h of
-        0 -> do return BoxedTuple
-        1 -> do return UnboxedTuple
-        _ -> do return ConstraintTuple
-
-instance Binary Activation where
-    put_ bh NeverActive = do
-            putByte bh 0
-    put_ bh FinalActive = do
-            putByte bh 1
-    put_ bh AlwaysActive = do
-            putByte bh 2
-    put_ bh (ActiveBefore src aa) = do
-            putByte bh 3
-            put_ bh src
-            put_ bh aa
-    put_ bh (ActiveAfter src ab) = do
-            putByte bh 4
-            put_ bh src
-            put_ bh ab
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return NeverActive
-              1 -> do return FinalActive
-              2 -> do return AlwaysActive
-              3 -> do src <- get bh
-                      aa <- get bh
-                      return (ActiveBefore src aa)
-              _ -> do src <- get bh
-                      ab <- get bh
-                      return (ActiveAfter src ab)
-
-instance Binary InlinePragma where
-    put_ bh (InlinePragma s a b c d) = do
-            put_ bh s
-            put_ bh a
-            put_ bh b
-            put_ bh c
-            put_ bh d
-
-    get bh = do
-           s <- get bh
-           a <- get bh
-           b <- get bh
-           c <- get bh
-           d <- get bh
-           return (InlinePragma s a b c d)
-
-instance Binary RuleMatchInfo where
-    put_ bh FunLike = putByte bh 0
-    put_ bh ConLike = putByte bh 1
-    get bh = do
-            h <- getByte bh
-            if h == 1 then return ConLike
-                      else return FunLike
-
-instance Binary InlineSpec where
-    put_ bh NoUserInlinePrag = putByte bh 0
-    put_ bh Inline           = putByte bh 1
-    put_ bh Inlinable        = putByte bh 2
-    put_ bh NoInline         = putByte bh 3
-
-    get bh = do h <- getByte bh
-                case h of
-                  0 -> return NoUserInlinePrag
-                  1 -> return Inline
-                  2 -> return Inlinable
-                  _ -> return NoInline
-
-instance Binary RecFlag where
-    put_ bh Recursive = do
-            putByte bh 0
-    put_ bh NonRecursive = do
-            putByte bh 1
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return Recursive
-              _ -> do return NonRecursive
-
-instance Binary OverlapMode where
-    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
-    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
-    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
-    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
-    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> (get bh) >>= \s -> return $ NoOverlap s
-            1 -> (get bh) >>= \s -> return $ Overlaps s
-            2 -> (get bh) >>= \s -> return $ Incoherent s
-            3 -> (get bh) >>= \s -> return $ Overlapping s
-            4 -> (get bh) >>= \s -> return $ Overlappable s
-            _ -> panic ("get OverlapMode" ++ show h)
-
-
-instance Binary OverlapFlag where
-    put_ bh flag = do put_ bh (overlapMode flag)
-                      put_ bh (isSafeOverlap flag)
-    get bh = do
-        h <- get bh
-        b <- get bh
-        return OverlapFlag { overlapMode = h, isSafeOverlap = b }
-
-instance Binary FixityDirection where
-    put_ bh InfixL = do
-            putByte bh 0
-    put_ bh InfixR = do
-            putByte bh 1
-    put_ bh InfixN = do
-            putByte bh 2
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return InfixL
-              1 -> do return InfixR
-              _ -> do return InfixN
-
-instance Binary Fixity where
-    put_ bh (Fixity src aa ab) = do
-            put_ bh src
-            put_ bh aa
-            put_ bh ab
-    get bh = do
-          src <- get bh
-          aa <- get bh
-          ab <- get bh
-          return (Fixity src aa ab)
-
-instance Binary WarningTxt where
-    put_ bh (WarningTxt s w) = do
-            putByte bh 0
-            put_ bh s
-            put_ bh w
-    put_ bh (DeprecatedTxt s d) = do
-            putByte bh 1
-            put_ bh s
-            put_ bh d
-
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do s <- get bh
-                      w <- get bh
-                      return (WarningTxt s w)
-              _ -> do s <- get bh
-                      d <- get bh
-                      return (DeprecatedTxt s d)
-
-instance Binary StringLiteral where
-  put_ bh (StringLiteral st fs) = do
-            put_ bh st
-            put_ bh fs
-  get bh = do
-            st <- get bh
-            fs <- get bh
-            return (StringLiteral st fs)
-
 instance Binary a => Binary (Located a) where
     put_ bh (L l x) = do
             put_ bh l
@@ -1488,27 +1108,3 @@ instance Binary SrcSpan where
                     return (RealSrcSpan ss sb)
             _ -> do s <- get bh
                     return (UnhelpfulSpan s)
-
-instance Binary Serialized where
-    put_ bh (Serialized the_type bytes) = do
-        put_ bh the_type
-        put_ bh bytes
-    get bh = do
-        the_type <- get bh
-        bytes <- get bh
-        return (Serialized the_type bytes)
-
-instance Binary SourceText where
-  put_ bh NoSourceText = putByte bh 0
-  put_ bh (SourceText s) = do
-        putByte bh 1
-        put_ bh s
-
-  get bh = do
-    h <- getByte bh
-    case h of
-      0 -> return NoSourceText
-      1 -> do
-        s <- get bh
-        return (SourceText s)
-      _ -> panic $ "Binary SourceText:" ++ show h
diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs
new file mode 100644
index 0000000000..580b245ded
--- /dev/null
+++ b/compiler/GHC/Utils/Binary/Typeable.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+
+{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | Orphan Binary instances for Data.Typeable stuff
+module GHC.Utils.Binary.Typeable
+   ( getSomeTypeRep
+   )
+where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Utils.Binary
+
+import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
+import GHC.Serialized
+
+import Foreign
+import Type.Reflection
+import Type.Reflection.Unsafe
+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 (tyConKindArgs tc)
+        put_ bh (tyConKindRep tc)
+    get bh =
+        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+getSomeTypeRep :: BinHandle -> IO SomeTypeRep
+getSomeTypeRep bh = do
+    tag <- get bh :: IO Word8
+    case tag of
+        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
+        1 -> do con <- get bh :: IO TyCon
+                ks <- get bh :: IO [SomeTypeRep]
+                return $ SomeTypeRep $ mkTrCon con ks
+
+        2 -> do SomeTypeRep f <- getSomeTypeRep bh
+                SomeTypeRep x <- getSomeTypeRep bh
+                case typeRepKind f of
+                  Fun arg res ->
+                      case arg `eqTypeRep` typeRepKind x of
+                        Just HRefl ->
+                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
+                              Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
+                              _ -> failure "Kind mismatch in type application" []
+                        _ -> 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
+                       ]
+        3 -> do SomeTypeRep arg <- getSomeTypeRep bh
+                SomeTypeRep res <- getSomeTypeRep bh
+                if
+                  | App argkcon _ <- typeRepKind arg
+                  , App reskcon _ <- typeRepKind res
+                  , Just HRefl <- argkcon `eqTypeRep` tYPErep
+                  , Just HRefl <- reskcon `eqTypeRep` tYPErep
+                  -> return $ SomeTypeRep $ Fun arg res
+                  | otherwise -> failure "Kind mismatch" []
+        _ -> failure "Invalid SomeTypeRep" []
+  where
+    tYPErep :: TypeRep TYPE
+    tYPErep = typeRep
+
+    failure description info =
+        fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
+                      ++ map ("    "++) info
+
+instance Binary SomeTypeRep where
+    put_ bh (SomeTypeRep rep) = putTypeRep bh rep
+    get = getSomeTypeRep
+
+instance Typeable a => Binary (TypeRep (a :: k)) where
+    put_ = putTypeRep
+    get bh = do
+        SomeTypeRep rep <- getSomeTypeRep bh
+        case rep `eqTypeRep` expected of
+            Just HRefl -> pure rep
+            Nothing    -> fail $ unlines
+                               [ "Binary: Type mismatch"
+                               , "    Deserialized type: " ++ show rep
+                               , "    Expected type:     " ++ show expected
+                               ]
+     where expected = typeRep :: TypeRep a
+
+
+instance Binary VecCount where
+    put_ bh = putByte bh . fromIntegral . fromEnum
+    get bh = toEnum . fromIntegral <$> getByte bh
+
+instance Binary VecElem where
+    put_ bh = putByte bh . fromIntegral . fromEnum
+    get bh = toEnum . fromIntegral <$> getByte bh
+
+instance Binary RuntimeRep where
+    put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b
+    put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
+    put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps
+    put_ bh LiftedRep       = putByte bh 3
+    put_ bh UnliftedRep     = putByte bh 4
+    put_ bh IntRep          = putByte bh 5
+    put_ bh WordRep         = putByte bh 6
+    put_ bh Int64Rep        = putByte bh 7
+    put_ bh Word64Rep       = putByte bh 8
+    put_ bh AddrRep         = putByte bh 9
+    put_ bh FloatRep        = putByte bh 10
+    put_ bh DoubleRep       = putByte bh 11
+    put_ bh Int8Rep         = putByte bh 12
+    put_ bh Word8Rep        = putByte bh 13
+    put_ bh Int16Rep        = putByte bh 14
+    put_ bh Word16Rep       = putByte bh 15
+#if __GLASGOW_HASKELL__ >= 809
+    put_ bh Int32Rep        = putByte bh 16
+    put_ bh Word32Rep       = putByte bh 17
+#endif
+
+    get bh = do
+        tag <- getByte bh
+        case tag of
+          0  -> VecRep <$> get bh <*> get bh
+          1  -> TupleRep <$> get bh
+          2  -> SumRep <$> get bh
+          3  -> pure LiftedRep
+          4  -> pure UnliftedRep
+          5  -> pure IntRep
+          6  -> pure WordRep
+          7  -> pure Int64Rep
+          8  -> pure Word64Rep
+          9  -> pure AddrRep
+          10 -> pure FloatRep
+          11 -> pure DoubleRep
+          12 -> pure Int8Rep
+          13 -> pure Word8Rep
+          14 -> pure Int16Rep
+          15 -> pure Word16Rep
+#if __GLASGOW_HASKELL__ >= 809
+          16 -> pure Int32Rep
+          17 -> pure Word32Rep
+#endif
+          _  -> fail "Binary.putRuntimeRep: invalid tag"
+
+instance Binary KindRep where
+    put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
+    put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
+    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
+
+    get bh = do
+        tag <- getByte bh
+        case tag of
+          0 -> KindRepTyConApp <$> get bh <*> get bh
+          1 -> KindRepVar <$> get bh
+          2 -> KindRepApp <$> get bh <*> get bh
+          3 -> KindRepFun <$> get bh <*> get bh
+          4 -> KindRepTYPE <$> get bh
+          5 -> KindRepTypeLit <$> get bh <*> get bh
+          _ -> fail "Binary.putKindRep: invalid tag"
+
+instance Binary TypeLitSort where
+    put_ bh TypeLitSymbol = putByte bh 0
+    put_ bh TypeLitNat = putByte bh 1
+    get bh = do
+        tag <- getByte bh
+        case tag of
+          0 -> pure TypeLitSymbol
+          1 -> pure TypeLitNat
+          _ -> fail "Binary.putTypeLitSort: invalid tag"
+
+putTypeRep :: BinHandle -> TypeRep a -> IO ()
+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
+-- relations.
+-- See Note [Mutually recursive representations of primitive types]
+putTypeRep bh rep
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
+  = put_ bh (0 :: Word8)
+putTypeRep bh (Con' con ks) = do
+    put_ bh (1 :: Word8)
+    put_ bh con
+    put_ bh ks
+putTypeRep bh (App f x) = do
+    put_ bh (2 :: Word8)
+    putTypeRep bh f
+    putTypeRep bh x
+putTypeRep bh (Fun arg res) = do
+    put_ bh (3 :: Word8)
+    putTypeRep bh arg
+    putTypeRep bh res
+
+instance Binary Serialized where
+    put_ bh (Serialized the_type bytes) = do
+        put_ bh the_type
+        put_ bh bytes
+    get bh = do
+        the_type <- get bh
+        bytes <- get bh
+        return (Serialized the_type bytes)
+
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 1bd3e57f56..2db4672f07 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -58,24 +58,27 @@ module GHC.Utils.Error (
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
-        traceCmd
+        traceCmd,
+
+        -- * Compilation errors and warnings
+        printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning
     ) where
 
 #include "HsVersions.h"
 
 import GHC.Prelude
 
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+import qualified GHC.Driver.CmdLine as CmdLine
+
 import GHC.Data.Bag
 import GHC.Utils.Exception
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
-import qualified GHC.Utils.Ppr.Colour as Col
+import GHC.Types.SourceError
+import GHC.Types.Error
 import GHC.Types.SrcLoc as SrcLoc
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Data.FastString (unpackFS)
-import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
-import GHC.Utils.Json
 
 import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
@@ -91,12 +94,9 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Catch as MC (handle)
 import System.IO
-import System.IO.Error  ( catchIOError )
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
--------------------------
-type MsgDoc  = SDoc
 
 -------------------------
 data Validity
@@ -126,209 +126,6 @@ orValid _       v = v
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
 
-type Messages        = (WarningMessages, ErrorMessages)
-type WarningMessages = Bag WarnMsg
-type ErrorMessages   = Bag ErrMsg
-
-unionMessages :: Messages -> Messages -> Messages
-unionMessages (warns1, errs1) (warns2, errs2) =
-  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
-
-data ErrMsg = ErrMsg {
-        errMsgSpan        :: SrcSpan,
-        errMsgContext     :: PrintUnqualified,
-        errMsgDoc         :: ErrDoc,
-        -- | This has the same text as errDocImportant . errMsgDoc.
-        errMsgShortString :: String,
-        errMsgSeverity    :: Severity,
-        errMsgReason      :: WarnReason
-        }
-        -- The SrcSpan is used for sorting errors into line-number order
-
-
--- | Categorise error msgs by their importance.  This is so each section can
--- be rendered visually distinct.  See Note [Error report] for where these come
--- from.
-data ErrDoc = ErrDoc {
-        -- | Primary error msg.
-        errDocImportant     :: [MsgDoc],
-        -- | Context e.g. \"In the second argument of ...\".
-        errDocContext       :: [MsgDoc],
-        -- | Supplementary information, e.g. \"Relevant bindings include ...\".
-        errDocSupplementary :: [MsgDoc]
-        }
-
-errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
-errDoc = ErrDoc
-
-mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc
-mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)
-
-type WarnMsg = ErrMsg
-
-data Severity
-  = SevOutput
-  | SevFatal
-  | SevInteractive
-
-  | SevDump
-    -- ^ Log message intended for compiler developers
-    -- No file\/line\/column stuff
-
-  | SevInfo
-    -- ^ Log messages intended for end users.
-    -- No file\/line\/column stuff.
-
-  | SevWarning
-  | SevError
-    -- ^ SevWarning and SevError are used for warnings and errors
-    --   o The message has a file\/line\/column heading,
-    --     plus "warning:" or "error:",
-    --     added by mkLocMessags
-    --   o Output is intended for end users
-  deriving Show
-
-
-instance ToJson Severity where
-  json s = JSString (show s)
-
-instance Show ErrMsg where
-    show em = errMsgShortString em
-
-pprMessageBag :: Bag MsgDoc -> SDoc
-pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
-
--- | Make an unannotated error message with location info.
-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
-mkLocMessage = mkLocMessageAnn Nothing
-
--- | Make a possibly annotated error message with location info.
-mkLocMessageAnn
-  :: Maybe String                       -- ^ optional annotation
-  -> Severity                           -- ^ severity
-  -> SrcSpan                            -- ^ location
-  -> MsgDoc                             -- ^ message
-  -> MsgDoc
-  -- Always print the location, even if it is unhelpful.  Error messages
-  -- are supposed to be in a standard format, and one without a location
-  -- would look strange.  Better to say explicitly "<no location info>".
-mkLocMessageAnn ann severity locn msg
-    = sdocOption sdocColScheme $ \col_scheme ->
-      let locn' = sdocOption sdocErrorSpans $ \case
-                     True  -> ppr locn
-                     False -> ppr (srcSpanStart locn)
-
-          sevColour = getSeverityColour severity col_scheme
-
-          -- Add optional information
-          optAnn = case ann of
-            Nothing -> text ""
-            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"
-
-          -- Add prefixes, like    Foo.hs:34: warning:
-          --                           <the warning message>
-          header = locn' <> colon <+>
-                   coloured sevColour sevText <> optAnn
-
-      in coloured (Col.sMessage col_scheme)
-                  (hang (coloured (Col.sHeader col_scheme) header) 4
-                        msg)
-
-  where
-    sevText =
-      case severity of
-        SevWarning -> text "warning:"
-        SevError   -> text "error:"
-        SevFatal   -> text "fatal:"
-        _          -> empty
-
-getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
-getSeverityColour SevWarning = Col.sWarning
-getSeverityColour SevError   = Col.sError
-getSeverityColour SevFatal   = Col.sFatal
-getSeverityColour _          = const mempty
-
-getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
-getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
-getCaretDiagnostic severity (RealSrcSpan span _) = do
-  caretDiagnostic <$> getSrcLine (srcSpanFile span) row
-
-  where
-    getSrcLine fn i =
-      getLine i (unpackFS fn)
-        `catchIOError` \_ ->
-          pure Nothing
-
-    getLine i fn = do
-      -- StringBuffer has advantages over readFile:
-      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
-      -- (b) always UTF-8, rather than some system-dependent encoding
-      --     (Haskell source code must be UTF-8 anyway)
-      content <- hGetStringBuffer fn
-      case atLine i content of
-        Just at_line -> pure $
-          case lines (fix <$> lexemeToString at_line (len at_line)) of
-            srcLine : _ -> Just srcLine
-            _           -> Nothing
-        _ -> pure Nothing
-
-    -- allow user to visibly see that their code is incorrectly encoded
-    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
-    fix '\0' = '\xfffd'
-    fix c    = c
-
-    row = srcSpanStartLine span
-    rowStr = show row
-    multiline = row /= srcSpanEndLine span
-
-    caretDiagnostic Nothing = empty
-    caretDiagnostic (Just srcLineWithNewline) =
-      sdocOption sdocColScheme$ \col_scheme ->
-      let sevColour = getSeverityColour severity col_scheme
-          marginColour = Col.sMargin col_scheme
-      in
-      coloured marginColour (text marginSpace) <>
-      text ("\n") <>
-      coloured marginColour (text marginRow) <>
-      text (" " ++ srcLinePre) <>
-      coloured sevColour (text srcLineSpan) <>
-      text (srcLinePost ++ "\n") <>
-      coloured marginColour (text marginSpace) <>
-      coloured sevColour (text (" " ++ caretLine))
-
-      where
-
-        -- expand tabs in a device-independent manner #13664
-        expandTabs tabWidth i s =
-          case s of
-            ""        -> ""
-            '\t' : cs -> replicate effectiveWidth ' ' ++
-                         expandTabs tabWidth (i + effectiveWidth) cs
-            c    : cs -> c : expandTabs tabWidth (i + 1) cs
-          where effectiveWidth = tabWidth - i `mod` tabWidth
-
-        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
-
-        start = srcSpanStartCol span - 1
-        end | multiline = length srcLine
-            | otherwise = srcSpanEndCol span - 1
-        width = max 1 (end - start)
-
-        marginWidth = length rowStr
-        marginSpace = replicate marginWidth ' ' ++ " |"
-        marginRow   = rowStr ++ " |"
-
-        (srcLinePre,  srcLineRest) = splitAt start srcLine
-        (srcLineSpan, srcLinePost) = splitAt width srcLineRest
-
-        caretEllipsis | multiline = "..."
-                      | otherwise = ""
-        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
-
-makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
-makeIntoWarning reason err = err
-    { errMsgSeverity = SevWarning
-    , errMsgReason = reason }
 
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
@@ -993,3 +790,44 @@ dumpAction dflags = dump_action dflags dflags
 -- | Helper for `trace_action`
 traceAction :: TraceAction
 traceAction dflags = trace_action dflags dflags
+
+handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()
+handleFlagWarnings dflags warns = do
+  let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason)  warns
+
+      -- It would be nicer if warns :: [Located MsgDoc], but that
+      -- has circular import problems.
+      bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
+                      | CmdLine.Warn _ (L loc warn) <- warns' ]
+
+  printOrThrowWarnings dflags bag
+
+-- Given a warn reason, check to see if it's associated -W opt is enabled
+shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
+shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag
+  = wopt Opt_WarnDeprecatedFlags dflags
+shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
+  = wopt Opt_WarnUnrecognisedWarningFlags dflags
+shouldPrintWarning _ _
+  = True
+
+
+-- | Given a bag of warnings, turn them into an exception if
+-- -Werror is enabled, or print them out otherwise.
+printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowWarnings dflags warns = do
+  let (make_error, warns') =
+        mapAccumBagL
+          (\make_err warn ->
+            case isWarnMsgFatal dflags warn of
+              Nothing ->
+                (make_err, warn)
+              Just err_reason ->
+                (True, warn{ errMsgSeverity = SevError
+                           , errMsgReason = ErrReason err_reason
+                           }))
+          False warns
+  if make_error
+    then throwIO (mkSrcErr warns')
+    else printBagOfErrors dflags warns
+
diff --git a/compiler/GHC/Utils/Error.hs-boot b/compiler/GHC/Utils/Error.hs-boot
index 20c6930fa5..a455e730f2 100644
--- a/compiler/GHC/Utils/Error.hs-boot
+++ b/compiler/GHC/Utils/Error.hs-boot
@@ -4,8 +4,6 @@ module GHC.Utils.Error where
 
 import GHC.Prelude
 import GHC.Utils.Outputable (SDoc, PprStyle )
-import GHC.Types.SrcLoc (SrcSpan)
-import GHC.Utils.Json
 import {-# SOURCE #-} GHC.Driver.Session ( DynFlags )
 
 type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String
@@ -29,22 +27,5 @@ data DumpFormat
   | FormatLLVM
   | FormatText
 
-data Severity
-  = SevOutput
-  | SevFatal
-  | SevInteractive
-  | SevDump
-  | SevInfo
-  | SevWarning
-  | SevError
-
-
-type MsgDoc = SDoc
-
-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
-mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
-getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
 defaultDumpAction :: DumpAction
 defaultTraceAction :: TraceAction
-
-instance ToJson Severity
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index ea9c8daecd..489c20cd75 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -198,7 +198,7 @@ type QueryQualifyModule = Module -> Bool
 -- the component id to disambiguate it.
 type QueryQualifyPackage = Unit -> Bool
 
--- See Note [Printing original names] in GHC.Driver.Types
+-- See Note [Printing original names] in GHC.Types.Name.Ppr
 data QualifyName   -- Given P:M.T
   = NameUnqual           -- It's in scope unqualified as "T"
                          -- OR nothing called "T" is in scope