Remove source location information from interface files

This change aims to minimize source location information leaking
into interface files, which makes ABI hashes dependent on the
build location.

The `Binary (Located a)` instance has been removed completely.

It seems that the HIE interface still needs the ability to
serialize SrcSpans, but by wrapping the instances, it should
be a lot more difficult to inadvertently add source location
information.

8 files changed, 88 insertions, 72 deletions

diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs
index bedb360875..f01aa0339d 100644
--- a/compiler/GHC/Data/BooleanFormula.hs
+++ b/compiler/GHC/Data/BooleanFormula.hs
@@ -25,7 +25,7 @@ import Data.Data
 import GHC.Utils.Monad
 import GHC.Utils.Outputable
 import GHC.Utils.Binary
-import GHC.Parser.Annotation ( LocatedL )
+import GHC.Parser.Annotation ( LocatedL, noLocA )
 import GHC.Types.SrcLoc
 import GHC.Types.Unique
 import GHC.Types.Unique.Set
@@ -251,14 +251,14 @@ pprBooleanFormulaNormal = go
 
 instance Binary a => Binary (BooleanFormula a) where
   put_ bh (Var x)    = putByte bh 0 >> put_ bh x
-  put_ bh (And xs)   = putByte bh 1 >> put_ bh xs
-  put_ bh (Or  xs)   = putByte bh 2 >> put_ bh xs
-  put_ bh (Parens x) = putByte bh 3 >> put_ bh x
+  put_ bh (And xs)   = putByte bh 1 >> put_ bh (unLoc <$> xs)
+  put_ bh (Or  xs)   = putByte bh 2 >> put_ bh (unLoc <$> xs)
+  put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x)
 
   get bh = do
     h <- getByte bh
     case h of
-      0 -> Var    <$> get bh
-      1 -> And    <$> get bh
-      2 -> Or     <$> get bh
-      _ -> Parens <$> get bh
+      0 -> Var                  <$> get bh
+      1 -> And    . fmap noLocA <$> get bh
+      2 -> Or     . fmap noLocA <$> get bh
+      _ -> Parens . noLocA      <$> get bh
diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
index 4873eaa367..948341f89f 100644
--- a/compiler/GHC/Hs/Doc.hs
+++ b/compiler/GHC/Hs/Doc.hs
@@ -85,9 +85,9 @@ instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
 instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
   put_ bh (WithHsDocIdentifiers s ids) = do
     put_ bh s
-    put_ bh ids
+    put_ bh $ BinLocated <$> ids
   get bh =
-    liftA2 WithHsDocIdentifiers (get bh) (get bh)
+    liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh)
 
 -- | Extract a mapping from the lexed identifiers to the names they may
 -- correspond to.
diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs
index 8297d3a2de..c96165d178 100644
--- a/compiler/GHC/Hs/DocString.hs
+++ b/compiler/GHC/Hs/DocString.hs
@@ -75,19 +75,19 @@ instance Binary HsDocString where
     MultiLineDocString dec xs -> do
       putByte bh 0
       put_ bh dec
-      put_ bh xs
+      put_ bh $ BinLocated <$> xs
     NestedDocString dec x -> do
       putByte bh 1
       put_ bh dec
-      put_ bh x
+      put_ bh $ BinLocated x
     GeneratedDocString x -> do
       putByte bh 2
       put_ bh x
   get bh = do
     tag <- getByte bh
     case tag of
-      0 -> MultiLineDocString <$> get bh <*> get bh
-      1 -> NestedDocString <$> get bh <*> get bh
+      0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh)
+      1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh)
       2 -> GeneratedDocString <$> get bh
       t -> fail $ "HsDocString: invalid tag " ++ show t
 
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 86dc042e63..e492bb726b 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -339,10 +339,10 @@ fromHieName nc hie_name = do
 putHieName :: BinHandle -> HieName -> IO ()
 putHieName bh (ExternalName mod occ span) = do
   putByte bh 0
-  put_ bh (mod, occ, span)
+  put_ bh (mod, occ, BinSrcSpan span)
 putHieName bh (LocalName occName span) = do
   putByte bh 1
-  put_ bh (occName, span)
+  put_ bh (occName, BinSrcSpan span)
 putHieName bh (KnownKeyName uniq) = do
   putByte bh 2
   put_ bh $ unpkUnique uniq
@@ -353,10 +353,10 @@ getHieName bh = do
   case t of
     0 -> do
       (modu, occ, span) <- get bh
-      return $ ExternalName modu occ span
+      return $ ExternalName modu occ $ unBinSrcSpan span
     1 -> do
       (occ, span) <- get bh
-      return $ LocalName occ span
+      return $ LocalName occ $ unBinSrcSpan span
     2 -> do
       (c,i) <- get bh
       return $ KnownKeyName $ mkUnique c i
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index 4aefc4d23c..714b23b7c2 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -251,12 +251,12 @@ data HieAST a =
 instance Binary (HieAST TypeIndex) where
   put_ bh ast = do
     put_ bh $ sourcedNodeInfo ast
-    put_ bh $ nodeSpan ast
+    put_ bh $ BinSpan $ nodeSpan ast
     put_ bh $ nodeChildren ast
 
   get bh = Node
     <$> get bh
-    <*> get bh
+    <*> (unBinSpan <$> get bh)
     <*> get bh
 
 instance Outputable a => Outputable (HieAST a) where
@@ -486,19 +486,19 @@ instance Binary ContextInfo where
     putByte bh 3
     put_ bh bt
     put_ bh sc
-    put_ bh msp
+    put_ bh $ BinSpan <$> msp
   put_ bh (PatternBind a b c) = do
     putByte bh 4
     put_ bh a
     put_ bh b
-    put_ bh c
+    put_ bh $ BinSpan <$> c
   put_ bh (ClassTyDecl sp) = do
     putByte bh 5
-    put_ bh sp
+    put_ bh $ BinSpan <$> sp
   put_ bh (Decl a b) = do
     putByte bh 6
     put_ bh a
-    put_ bh b
+    put_ bh $ BinSpan <$> b
   put_ bh (TyVarBind a b) = do
     putByte bh 7
     put_ bh a
@@ -506,13 +506,13 @@ instance Binary ContextInfo where
   put_ bh (RecField a b) = do
     putByte bh 8
     put_ bh a
-    put_ bh b
+    put_ bh $ BinSpan <$> b
   put_ bh MatchBind = putByte bh 9
   put_ bh (EvidenceVarBind a b c) = do
     putByte bh 10
     put_ bh a
     put_ bh b
-    put_ bh c
+    put_ bh $ BinSpan <$> c
   put_ bh EvidenceVarUse = putByte bh 11
 
   get bh = do
@@ -521,14 +521,14 @@ instance Binary ContextInfo where
       0 -> return Use
       1 -> IEThing <$> get bh
       2 -> return TyDecl
-      3 -> ValBind <$> get bh <*> get bh <*> get bh
-      4 -> PatternBind <$> get bh <*> get bh <*> get bh
-      5 -> ClassTyDecl <$> get bh
-      6 -> Decl <$> get bh <*> get bh
+      3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
+      4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
+      5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh)
+      6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh)
       7 -> TyVarBind <$> get bh <*> get bh
-      8 -> RecField <$> get bh <*> get bh
+      8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh)
       9 -> return MatchBind
-      10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
+      10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
       11 -> return EvidenceVarUse
       _ -> panic "Binary ContextInfo: invalid tag"
 
@@ -679,14 +679,14 @@ instance Binary Scope where
   put_ bh NoScope = putByte bh 0
   put_ bh (LocalScope span) = do
     putByte bh 1
-    put_ bh span
+    put_ bh $ BinSpan span
   put_ bh ModuleScope = putByte bh 2
 
   get bh = do
     (t :: Word8) <- get bh
     case t of
       0 -> return NoScope
-      1 -> LocalScope <$> get bh
+      1 -> LocalScope . unBinSpan <$> get bh
       2 -> return ModuleScope
       _ -> panic "Binary Scope: invalid tag"
 
@@ -732,13 +732,13 @@ instance Binary TyVarScope where
   put_ bh (UnresolvedScope ns span) = do
     putByte bh 1
     put_ bh ns
-    put_ bh span
+    put_ bh (BinSpan <$> span)
 
   get bh = do
     (t :: Word8) <- get bh
     case t of
       0 -> ResolvedScopes <$> get bh
-      1 -> UnresolvedScope <$> get bh <*> get bh
+      1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh)
       _ -> panic "Binary TyVarScope: invalid tag"
 
 -- | `Name`'s get converted into `HieName`'s before being written into @.hie@
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 101c14f4ef..ccd5a2210f 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -95,7 +95,6 @@ import GHC.Data.FastString
 import GHC.Types.Name
 import GHC.Types.SrcLoc
 import GHC.Hs.DocString
-import GHC.Utils.Binary
 import GHC.Utils.Outputable hiding ( (<>) )
 import GHC.Utils.Panic
 import qualified GHC.Data.Strict as Strict
@@ -1249,17 +1248,6 @@ instance Outputable AnnSortKey where
 instance Outputable IsUnicodeSyntax where
   ppr = text . show
 
-instance Binary a => Binary (LocatedL a) where
-  -- We do not serialise the annotations
-    put_ bh (L l x) = do
-            put_ bh (locA l)
-            put_ bh x
-
-    get bh = do
-            l <- get bh
-            x <- get bh
-            return (L (noAnnSrcSpan l) x)
-
 instance (Outputable a) => Outputable (SrcSpanAnn' a) where
   ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l
 
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 6dae41ecfc..75f3950208 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -61,21 +61,21 @@ instance Outputable (WarningTxt pass) where
 instance Binary (WarningTxt GhcRn) where
     put_ bh (WarningTxt s w) = do
             putByte bh 0
-            put_ bh s
-            put_ bh w
+            put_ bh $ unLoc s
+            put_ bh $ unLoc <$> w
     put_ bh (DeprecatedTxt s d) = do
             putByte bh 1
-            put_ bh s
-            put_ bh d
+            put_ bh $ unLoc s
+            put_ bh $ unLoc <$> d
 
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do s <- get bh
-                      w <- get bh
+              0 -> do s <- noLoc <$> get bh
+                      w <- fmap noLoc  <$> get bh
                       return (WarningTxt s w)
-              _ -> do s <- get bh
-                      d <- get bh
+              _ -> do s <- noLoc <$> get bh
+                      d <- fmap noLoc <$> get bh
                       return (DeprecatedTxt s d)
 
 
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index f224589ee0..26328d8d05 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -73,6 +73,9 @@ module GHC.Utils.Binary
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
    putDictionary, getDictionary, putFS,
+
+   -- * Newtype wrappers
+   BinSpan(..), BinSrcSpan(..), BinLocated(..)
   ) where
 
 import GHC.Prelude
@@ -1285,18 +1288,23 @@ instance Binary ModuleName where
 --             fs <- get bh
 --             return (StringLiteral st fs Nothing)
 
-instance Binary a => Binary (Located a) where
-    put_ bh (L l x) = do
-            put_ bh l
+newtype BinLocated a = BinLocated { unBinLocated :: Located a }
+
+instance Binary a => Binary (BinLocated a) where
+    put_ bh (BinLocated (L l x)) = do
+            put_ bh $ BinSrcSpan l
             put_ bh x
 
     get bh = do
-            l <- get bh
+            l <- unBinSrcSpan <$> get bh
             x <- get bh
-            return (L l x)
+            return $ BinLocated (L l x)
+
+newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan }
 
-instance Binary RealSrcSpan where
-  put_ bh ss = do
+-- See Note [Source Location Wrappers]
+instance Binary BinSpan where
+  put_ bh (BinSpan ss) = do
             put_ bh (srcSpanFile ss)
             put_ bh (srcSpanStartLine ss)
             put_ bh (srcSpanStartCol ss)
@@ -1309,8 +1317,8 @@ instance Binary RealSrcSpan where
             sc <- get bh
             el <- get bh
             ec <- get bh
-            return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
-                                  (mkRealSrcLoc f el ec))
+            return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)
+                                            (mkRealSrcLoc f el ec))
 
 instance Binary UnhelpfulSpanReason where
   put_ bh r = case r of
@@ -1329,24 +1337,44 @@ instance Binary UnhelpfulSpanReason where
       3 -> return UnhelpfulGenerated
       _ -> UnhelpfulOther <$> get bh
 
-instance Binary SrcSpan where
-  put_ bh (RealSrcSpan ss _sb) = do
+newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }
+
+-- See Note [Source Location Wrappers]
+instance Binary BinSrcSpan where
+  put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do
           putByte bh 0
           -- BufSpan doesn't ever get serialised because the positions depend
           -- on build location.
-          put_ bh ss
+          put_ bh $ BinSpan ss
 
-  put_ bh (UnhelpfulSpan s) = do
+  put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do
           putByte bh 1
           put_ bh s
 
   get bh = do
           h <- getByte bh
           case h of
-            0 -> do ss <- get bh
-                    return (RealSrcSpan ss Strict.Nothing)
+            0 -> do BinSpan ss <- get bh
+                    return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)
             _ -> do s <- get bh
-                    return (UnhelpfulSpan s)
+                    return $ BinSrcSpan (UnhelpfulSpan s)
+
+
+{-
+Note [Source Location Wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Source locations are banned from interface files, to
+prevent filepaths affecting interface hashes.
+
+Unfortunately, we can't remove all binary instances,
+as they're used to serialise .hie files, and we don't
+want to break binary compatibility.
+
+To this end, the Bin[Src]Span newtypes wrappers were
+introduced to prevent accidentally serialising a
+source location as part of a larger structure.
+-}
 
 --------------------------------------------------------------------------------
 -- Instances for the containers package