Generate Typeable info at definition sites
[ghc.git] / compiler / utils / Binary.hs
index ea53b31..5083804 100644 (file)
@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -46,10 +48,6 @@ module Binary
    lazyGet,
    lazyPut,
 
-   ByteArray(..),
-   getByteArray,
-   putByteArray,
-
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
    putDictionary, getDictionary, putFS,
@@ -67,6 +65,7 @@ import UniqFM
 import FastMutInt
 import Fingerprint
 import BasicTypes
+import SrcLoc
 
 import Foreign
 import Data.Array
@@ -77,16 +76,11 @@ import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Time
 import Data.Typeable
-import Data.Typeable.Internal
 import Control.Monad            ( when )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
-import ExtsCompat46
-import GHC.Word                 ( Word8(..) )
-
-import GHC.IO ( IO(..) )
 
 type BinArray = ForeignPtr Word8
 
@@ -470,7 +464,7 @@ instance Binary DiffTime where
 -- we just change this instance to be portable like the rest of the
 -- instances? (binary package has code to steal for that)
 --
--- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs
 
 instance Binary Integer where
     -- XXX This is hideous
@@ -481,6 +475,10 @@ instance Binary Integer where
                     _ -> fail ("Binary Integer: got " ++ show str)
 
     {-
+    -- This code is currently commented out.
+    -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for
+    -- discussion.
+
     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
     put_ bh (J# s# a#) = do
         putByte bh 1
@@ -498,11 +496,6 @@ instance Binary Integer where
                   sz <- get bh
                   (BA a#) <- getByteArray bh sz
                   return (J# s# a#)
--}
-
--- As for the rest of this code, even though this module
--- exports it, it doesn't seem to be used anywhere else
--- in GHC!
 
 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 putByteArray bh a s# = loop 0#
@@ -523,8 +516,9 @@ getByteArray bh (I# sz) = do
                 loop (n +# 1#)
   loop 0#
   freezeByteArray arr
+    -}
 
-
+{-
 data ByteArray = BA ByteArray#
 data MBA = MBA (MutableByteArray# RealWorld)
 
@@ -546,7 +540,8 @@ writeByteArray arr i (W8# w) = IO $ \s ->
 indexByteArray :: ByteArray# -> Int# -> Word8
 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 
-instance (Integral a, Binary a) => Binary (Ratio a) where
+-}
+instance (Binary a) => Binary (Ratio a) where
     put_ bh (a :% b) = do put_ bh a; put_ bh b
     get bh = do a <- get bh; b <- get bh; return (a :% b)
 
@@ -558,10 +553,14 @@ instance Binary (Bin a) where
 -- Instances for Data.Typeable stuff
 
 instance Binary TyCon where
-    put_ bh (TyCon _ p m n) = do
-        put_ bh (p,m,n)
+    put_ bh tc = do
+        put_ bh (tyConPackage tc)
+        put_ bh (tyConModule tc)
+        put_ bh (tyConName tc)
     get bh = do
-        (p,m,n) <- get bh
+        p <- get bh
+        m <- get bh
+        n <- get bh
         return (mkTyCon3 p m n)
 
 instance Binary TypeRep where
@@ -772,18 +771,20 @@ instance Binary Activation where
                       return (ActiveAfter ab)
 
 instance Binary InlinePragma where
-    put_ bh (InlinePragma a b c d) = do
+    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 a b c d)
+           return (InlinePragma a b c d)
 
 instance Binary RuleMatchInfo where
     put_ bh FunLike = putByte bh 0
@@ -829,19 +830,19 @@ instance Binary RecFlag where
               _ -> do return NonRecursive
 
 instance Binary OverlapMode where
-    put_ bh NoOverlap     = putByte bh 0
-    put_ bh Overlaps      = putByte bh 1
-    put_ bh Incoherent    = putByte bh 2
-    put_ bh Overlapping   = putByte bh 3
-    put_ bh Overlappable  = putByte bh 4
+    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 -> return NoOverlap
-            1 -> return Overlaps
-            2 -> return Incoherent
-            3 -> return Overlapping
-            4 -> return Overlappable
+            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)
 
 
@@ -877,18 +878,66 @@ instance Binary Fixity where
           return (Fixity aa ab)
 
 instance Binary WarningTxt where
-    put_ bh (WarningTxt w) = do
+    put_ bh (WarningTxt w) = do
             putByte bh 0
+            put_ bh s
             put_ bh w
-    put_ bh (DeprecatedTxt d) = do
+    put_ bh (DeprecatedTxt d) = do
             putByte bh 1
+            put_ bh s
             put_ bh d
 
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do w <- get bh
-                      return (WarningTxt w)
-              _ -> do d <- get bh
-                      return (DeprecatedTxt d)
+              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 (GenLocated SrcSpan a) where
+    put_ bh (L l x) = do
+            put_ bh l
+            put_ bh x
 
+    get bh = do
+            l <- get bh
+            x <- get bh
+            return (L l x)
+
+instance Binary SrcSpan where
+  put_ bh (RealSrcSpan ss) = do
+          putByte bh 0
+          put_ bh (srcSpanFile ss)
+          put_ bh (srcSpanStartLine ss)
+          put_ bh (srcSpanStartCol ss)
+          put_ bh (srcSpanEndLine ss)
+          put_ bh (srcSpanEndCol ss)
+
+  put_ bh (UnhelpfulSpan s) = do
+          putByte bh 1
+          put_ bh s
+
+  get bh = do
+          h <- getByte bh
+          case h of
+            0 -> do f <- get bh
+                    sl <- get bh
+                    sc <- get bh
+                    el <- get bh
+                    ec <- get bh
+                    return (mkSrcSpan (mkSrcLoc f sl sc)
+                                      (mkSrcLoc f el ec))
+            _ -> do s <- get bh
+                    return (UnhelpfulSpan s)