De-orphan a load of Binary instances
authorIan Lynagh <ian@well-typed.com>
Sat, 27 Jul 2013 14:43:13 +0000 (15:43 +0100)
committerIan Lynagh <ian@well-typed.com>
Sat, 27 Jul 2013 14:43:13 +0000 (15:43 +0100)
compiler/basicTypes/Avail.hs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/main/Annotations.hs
compiler/main/HscTypes.lhs
compiler/profiling/CostCentre.lhs
compiler/types/Coercion.lhs
compiler/utils/Binary.hs

index afe93ff..e22527c 100644 (file)
@@ -18,6 +18,7 @@ import NameEnv
 import NameSet
 import RdrName
 
+import Binary
 import Outputable
 import Util
 
@@ -104,4 +105,20 @@ pprAvail :: AvailInfo -> SDoc
 pprAvail (Avail n)      = ppr n
 pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
 
+instance Binary AvailInfo where
+    put_ bh (Avail aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (AvailTC ab ac) = do
+            putByte bh 1
+            put_ bh ab
+            put_ bh ac
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      return (Avail aa)
+              _ -> do ab <- get bh
+                      ac <- get bh
+                      return (AvailTC ab ac)
 
index ba1a7e2..0876d90 100644 (file)
@@ -2,7 +2,6 @@
 --  (c) The University of Glasgow 2002-2006
 --
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -O #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -24,20 +23,15 @@ import TyCon
 import DataCon    (dataConName, dataConWorkId, dataConTyCon)
 import PrelInfo   (wiredInThings, basicKnownKeyNames)
 import Id         (idName, isDataConWorkId_maybe)
-import Coercion   (LeftOrRight(..))
 import TysWiredIn
 import IfaceEnv
 import HscTypes
 import BasicTypes
-import Annotations
-import IfaceSyn
 import Module
 import Name
-import Avail
 import DynFlags
 import UniqFM
 import UniqSupply
-import CostCentre
 import Panic
 import Binary
 import SrcLoc
@@ -413,153 +407,6 @@ data BinDictionary = BinDictionary {
                                 -- indexed by FastString
   }
 
--- -----------------------------------------------------------------------------
--- All the binary instances
-
--- BasicTypes
-{-! for Fixity derive: Binary !-}
-{-! for FixityDirection derive: Binary !-}
-{-! for Boxity derive: Binary !-}
-{-! for StrictnessMark derive: Binary !-}
-{-! for Activation derive: Binary !-}
-
--- Class
-{-! for DefMeth derive: Binary !-}
-
--- HsTypes
-{-! for HsPred derive: Binary !-}
-{-! for HsType derive: Binary !-}
-{-! for TupCon derive: Binary !-}
-{-! for HsTyVarBndr derive: Binary !-}
-
--- HsCore
-{-! for UfExpr derive: Binary !-}
-{-! for UfConAlt derive: Binary !-}
-{-! for UfBinding derive: Binary !-}
-{-! for UfBinder derive: Binary !-}
-{-! for HsIdInfo derive: Binary !-}
-{-! for UfNote derive: Binary !-}
-
--- HsDecls
-{-! for ConDetails derive: Binary !-}
-{-! for BangType derive: Binary !-}
-
--- CostCentre
-{-! for IsCafCC derive: Binary !-}
-{-! for CostCentre derive: Binary !-}
-
-
-
--- ---------------------------------------------------------------------------
--- Reading a binary interface into ParsedIface
-
-instance Binary ModIface where
-   put_ bh (ModIface {
-                 mi_module    = mod,
-                 mi_boot      = is_boot,
-                 mi_iface_hash= iface_hash,
-                 mi_mod_hash  = mod_hash,
-                 mi_flag_hash = flag_hash,
-                 mi_orphan    = orphan,
-                 mi_finsts    = hasFamInsts,
-                 mi_deps      = deps,
-                 mi_usages    = usages,
-                 mi_exports   = exports,
-                 mi_exp_hash  = exp_hash,
-                 mi_used_th   = used_th,
-                 mi_fixities  = fixities,
-                 mi_warns     = warns,
-                 mi_anns      = anns,
-                 mi_decls     = decls,
-                 mi_insts     = insts,
-                 mi_fam_insts = fam_insts,
-                 mi_rules     = rules,
-                 mi_orphan_hash = orphan_hash,
-                 mi_vect_info = vect_info,
-                 mi_hpc       = hpc_info,
-                 mi_trust     = trust,
-                 mi_trust_pkg = trust_pkg }) = do
-        put_ bh mod
-        put_ bh is_boot
-        put_ bh iface_hash
-        put_ bh mod_hash
-        put_ bh flag_hash
-        put_ bh orphan
-        put_ bh hasFamInsts
-        lazyPut bh deps
-        lazyPut bh usages
-        put_ bh exports
-        put_ bh exp_hash
-        put_ bh used_th
-        put_ bh fixities
-        lazyPut bh warns
-        lazyPut bh anns
-        put_ bh decls
-        put_ bh insts
-        put_ bh fam_insts
-        lazyPut bh rules
-        put_ bh orphan_hash
-        put_ bh vect_info
-        put_ bh hpc_info
-        put_ bh trust
-        put_ bh trust_pkg
-
-   get bh = do
-        mod_name    <- get bh
-        is_boot     <- get bh
-        iface_hash  <- get bh
-        mod_hash    <- get bh
-        flag_hash   <- get bh
-        orphan      <- get bh
-        hasFamInsts <- get bh
-        deps        <- lazyGet bh
-        usages      <- {-# SCC "bin_usages" #-} lazyGet bh
-        exports     <- {-# SCC "bin_exports" #-} get bh
-        exp_hash    <- get bh
-        used_th     <- get bh
-        fixities    <- {-# SCC "bin_fixities" #-} get bh
-        warns       <- {-# SCC "bin_warns" #-} lazyGet bh
-        anns        <- {-# SCC "bin_anns" #-} lazyGet bh
-        decls       <- {-# SCC "bin_tycldecls" #-} get bh
-        insts       <- {-# SCC "bin_insts" #-} get bh
-        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
-        rules       <- {-# SCC "bin_rules" #-} lazyGet bh
-        orphan_hash <- get bh
-        vect_info   <- get bh
-        hpc_info    <- get bh
-        trust       <- get bh
-        trust_pkg   <- get bh
-        return (ModIface {
-                 mi_module      = mod_name,
-                 mi_boot        = is_boot,
-                 mi_iface_hash  = iface_hash,
-                 mi_mod_hash    = mod_hash,
-                 mi_flag_hash   = flag_hash,
-                 mi_orphan      = orphan,
-                 mi_finsts      = hasFamInsts,
-                 mi_deps        = deps,
-                 mi_usages      = usages,
-                 mi_exports     = exports,
-                 mi_exp_hash    = exp_hash,
-                 mi_used_th     = used_th,
-                 mi_anns        = anns,
-                 mi_fixities    = fixities,
-                 mi_warns       = warns,
-                 mi_decls       = decls,
-                 mi_globals     = Nothing,
-                 mi_insts       = insts,
-                 mi_fam_insts   = fam_insts,
-                 mi_rules       = rules,
-                 mi_orphan_hash = orphan_hash,
-                 mi_vect_info   = vect_info,
-                 mi_hpc         = hpc_info,
-                 mi_trust       = trust,
-                 mi_trust_pkg   = trust_pkg,
-                        -- And build the cached values
-                 mi_warn_fn     = mkIfaceWarnCache warns,
-                 mi_fix_fn      = mkIfaceFixCache fixities,
-                 mi_hash_fn     = mkIfaceHashCache decls })
-
 getWayDescr :: DynFlags -> String
 getWayDescr dflags
   | platformUnregisterised (targetPlatform dflags) = 'u':tag
@@ -568,929 +415,3 @@ getWayDescr dflags
         -- if this is an unregisterised build, make sure our interfaces
         -- can't be used by a registerised build.
 
--------------------------------------------------------------------------
---              Types from: HscTypes
--------------------------------------------------------------------------
-
-instance Binary Dependencies where
-    put_ bh deps = do put_ bh (dep_mods deps)
-                      put_ bh (dep_pkgs deps)
-                      put_ bh (dep_orphs deps)
-                      put_ bh (dep_finsts deps)
-
-    get bh = do ms <- get bh 
-                ps <- get bh
-                os <- get bh
-                fis <- get bh
-                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
-                               dep_finsts = fis })
-
-instance Binary AvailInfo where
-    put_ bh (Avail aa) = do
-            putByte bh 0
-            put_ bh aa
-    put_ bh (AvailTC ab ac) = do
-            putByte bh 1
-            put_ bh ab
-            put_ bh ac
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do aa <- get bh
-                      return (Avail aa)
-              _ -> do ab <- get bh
-                      ac <- get bh
-                      return (AvailTC ab ac)
-
-instance Binary Usage where
-    put_ bh usg@UsagePackageModule{} = do 
-        putByte bh 0
-        put_ bh (usg_mod usg)
-        put_ bh (usg_mod_hash usg)
-        put_ bh (usg_safe     usg)
-
-    put_ bh usg@UsageHomeModule{} = do 
-        putByte bh 1
-        put_ bh (usg_mod_name usg)
-        put_ bh (usg_mod_hash usg)
-        put_ bh (usg_exports  usg)
-        put_ bh (usg_entities usg)
-        put_ bh (usg_safe     usg)
-
-    put_ bh usg@UsageFile{} = do 
-        putByte bh 2
-        put_ bh (usg_file_path usg)
-        put_ bh (usg_mtime     usg)
-
-    get bh = do
-        h <- getByte bh
-        case h of
-          0 -> do
-            nm    <- get bh
-            mod   <- get bh
-            safe  <- get bh
-            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
-          1 -> do
-            nm    <- get bh
-            mod   <- get bh
-            exps  <- get bh
-            ents  <- get bh
-            safe  <- get bh
-            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
-                     usg_exports = exps, usg_entities = ents, usg_safe = safe }
-          2 -> do
-            fp    <- get bh
-            mtime <- get bh
-            return UsageFile { usg_file_path = fp, usg_mtime = mtime }
-          i -> error ("Binary.get(Usage): " ++ show i)
-
-instance Binary Warnings where
-    put_ bh NoWarnings     = putByte bh 0
-    put_ bh (WarnAll t) = do
-            putByte bh 1
-            put_ bh t
-    put_ bh (WarnSome ts) = do
-            putByte bh 2
-            put_ bh ts
-
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> return NoWarnings
-              1 -> do aa <- get bh
-                      return (WarnAll aa)
-              _ -> do aa <- get bh
-                      return (WarnSome aa)
-
-instance Binary WarningTxt where
-    put_ bh (WarningTxt w) = do
-            putByte bh 0
-            put_ bh w
-    put_ bh (DeprecatedTxt d) = do
-            putByte bh 1
-            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)
-
--------------------------------------------------------------------------
---              Types from: BasicTypes
--------------------------------------------------------------------------
-
-instance Binary Activation where
-    put_ bh NeverActive = do
-            putByte bh 0
-    put_ bh AlwaysActive = do
-            putByte bh 1
-    put_ bh (ActiveBefore aa) = do
-            putByte bh 2
-            put_ bh aa
-    put_ bh (ActiveAfter ab) = do
-            putByte bh 3
-            put_ bh ab
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return NeverActive
-              1 -> do return AlwaysActive
-              2 -> do aa <- get bh
-                      return (ActiveBefore aa)
-              _ -> do ab <- get bh
-                      return (ActiveAfter ab)
-
-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 InlinePragma where
-    put_ bh (InlinePragma a b c d) = do
-            put_ bh a
-            put_ bh b
-            put_ bh c
-            put_ bh d
-
-    get bh = do
-           a <- get bh
-           b <- get bh
-           c <- get bh
-           d <- get bh
-           return (InlinePragma a b c d)
-
-instance Binary InlineSpec where
-    put_ bh EmptyInlineSpec = 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 EmptyInlineSpec
-                  1 -> return Inline
-                  2 -> return Inlinable
-                  _ -> return NoInline
-
-instance Binary IfaceBang where
-    put_ bh IfNoBang        = putByte bh 0
-    put_ bh IfStrict        = putByte bh 1
-    put_ bh IfUnpack        = putByte bh 2
-    put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
-
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return IfNoBang
-              1 -> do return IfStrict
-              2 -> do return IfUnpack
-              _ -> do { a <- get bh; return (IfUnpackCo a) }
-
-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 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 DefMethSpec where
-    put_ bh NoDM      = putByte bh 0
-    put_ bh VanillaDM = putByte bh 1
-    put_ bh GenericDM = putByte bh 2
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> return NoDM
-              1 -> return VanillaDM
-              _ -> return GenericDM
-
-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 aa ab) = do
-            put_ bh aa
-            put_ bh ab
-    get bh = do
-          aa <- get bh
-          ab <- get bh
-          return (Fixity aa ab)
-
-
--------------------------------------------------------------------------
---              Types from: CostCentre
--------------------------------------------------------------------------
-
-instance Binary IsCafCC where
-    put_ bh CafCC = do
-            putByte bh 0
-    put_ bh NotCafCC = do
-            putByte bh 1
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return CafCC
-              _ -> do return NotCafCC
-
-instance Binary CostCentre where
-    put_ bh (NormalCC aa ab ac _ad ae) = do
-            putByte bh 0
-            put_ bh aa
-            put_ bh ab
-            put_ bh ac
-            put_ bh ae
-    put_ bh (AllCafsCC ae _af) = do
-            putByte bh 1
-            put_ bh ae
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do aa <- get bh
-                      ab <- get bh
-                      ac <- get bh
-                      ae <- get bh
-                      return (NormalCC aa ab ac noSrcSpan ae)
-              _ -> do ae <- get bh
-                      return (AllCafsCC ae noSrcSpan)
-
-    -- We ignore the SrcSpans in CostCentres when we serialise them,
-    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
-    -- ok, because we only need the SrcSpan when declaring the
-    -- CostCentre in the original module, it is not used by importing
-    -- modules.
-
--------------------------------------------------------------------------
---              IfaceTypes and friends
--------------------------------------------------------------------------
-
-instance Binary IfaceBndr where
-    put_ bh (IfaceIdBndr aa) = do
-            putByte bh 0
-            put_ bh aa
-    put_ bh (IfaceTvBndr ab) = do
-            putByte bh 1
-            put_ bh ab
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do aa <- get bh
-                      return (IfaceIdBndr aa)
-              _ -> do ab <- get bh
-                      return (IfaceTvBndr ab)
-
-instance Binary IfaceLetBndr where
-    put_ bh (IfLetBndr a b c) = do
-            put_ bh a
-            put_ bh b
-            put_ bh c
-    get bh = do a <- get bh
-                b <- get bh
-                c <- get bh
-                return (IfLetBndr a b c)           
-
-instance Binary IfaceType where
-    put_ bh (IfaceForAllTy aa ab) = do
-            putByte bh 0
-            put_ bh aa
-            put_ bh ab
-    put_ bh (IfaceTyVar ad) = do
-            putByte bh 1
-            put_ bh ad
-    put_ bh (IfaceAppTy ae af) = do
-            putByte bh 2
-            put_ bh ae
-            put_ bh af
-    put_ bh (IfaceFunTy ag ah) = do
-            putByte bh 3
-            put_ bh ag
-            put_ bh ah
-    put_ bh (IfaceCoConApp cc tys)
-      = do { putByte bh 4; put_ bh cc; put_ bh tys }
-    put_ bh (IfaceTyConApp tc tys)
-      = do { putByte bh 5; put_ bh tc; put_ bh tys }
-
-    put_ bh (IfaceLitTy n)
-      = do { putByte bh 30; put_ bh n }
-
-
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do aa <- get bh
-                      ab <- get bh
-                      return (IfaceForAllTy aa ab)
-              1 -> do ad <- get bh
-                      return (IfaceTyVar ad)
-              2 -> do ae <- get bh
-                      af <- get bh
-                      return (IfaceAppTy ae af)
-              3 -> do ag <- get bh
-                      ah <- get bh
-                      return (IfaceFunTy ag ah)
-              4 -> do { cc <- get bh; tys <- get bh
-                      ; return (IfaceCoConApp cc tys) }
-              5 -> do { tc <- get bh; tys <- get bh
-                      ; return (IfaceTyConApp tc tys) }
-
-              30 -> do n <- get bh
-                       return (IfaceLitTy n)
-
-              _  -> panic ("get IfaceType " ++ show h)
-
-instance Binary IfaceTyLit where
-  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n
-  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n
-
-  get bh =
-    do tag <- getByte bh
-       case tag of
-         1 -> do { n <- get bh
-                 ; return (IfaceNumTyLit n) }
-         2 -> do { n <- get bh
-                 ; return (IfaceStrTyLit n) }
-         _ -> panic ("get IfaceTyLit " ++ show tag)
-
-instance Binary IfaceTyCon where
-   put_ bh (IfaceTc ext) = put_ bh ext
-   get bh = liftM IfaceTc (get bh)
-
-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 IfaceCoCon where
-   put_ bh (IfaceCoAx n ind)   = do { putByte bh 0; put_ bh n; put_ bh ind }
-   put_ bh IfaceReflCo         = putByte bh 1
-   put_ bh IfaceUnsafeCo       = putByte bh 2
-   put_ bh IfaceSymCo          = putByte bh 3
-   put_ bh IfaceTransCo        = putByte bh 4
-   put_ bh IfaceInstCo         = putByte bh 5
-   put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
-   put_ bh (IfaceLRCo lr)      = do { putByte bh 7; put_ bh lr }
-
-   get bh = do
-        h <- getByte bh
-        case h of
-          0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) }
-          1 -> return IfaceReflCo 
-          2 -> return IfaceUnsafeCo
-          3 -> return IfaceSymCo
-          4 -> return IfaceTransCo
-          5 -> return IfaceInstCo
-          6 -> do { d <- get bh; return (IfaceNthCo d) }
-          7 -> do { lr <- get bh; return (IfaceLRCo lr) }
-          _ -> panic ("get IfaceCoCon " ++ show h)
-
--------------------------------------------------------------------------
---              IfaceExpr and friends
--------------------------------------------------------------------------
-
-instance Binary IfaceExpr where
-    put_ bh (IfaceLcl aa) = do
-        putByte bh 0
-        put_ bh aa
-    put_ bh (IfaceType ab) = do
-        putByte bh 1
-        put_ bh ab
-    put_ bh (IfaceCo ab) = do
-        putByte bh 2
-        put_ bh ab
-    put_ bh (IfaceTuple ac ad) = do
-        putByte bh 3
-        put_ bh ac
-        put_ bh ad
-    put_ bh (IfaceLam ae af) = do
-        putByte bh 4
-        put_ bh ae
-        put_ bh af
-    put_ bh (IfaceApp ag ah) = do
-        putByte bh 5
-        put_ bh ag
-        put_ bh ah
-    put_ bh (IfaceCase ai aj ak) = do
-        putByte bh 6
-        put_ bh ai
-        put_ bh aj
-        put_ bh ak
-    put_ bh (IfaceLet al am) = do
-        putByte bh 7
-        put_ bh al
-        put_ bh am
-    put_ bh (IfaceTick an ao) = do
-        putByte bh 8
-        put_ bh an
-        put_ bh ao
-    put_ bh (IfaceLit ap) = do
-        putByte bh 9
-        put_ bh ap
-    put_ bh (IfaceFCall as at) = do
-        putByte bh 10
-        put_ bh as
-        put_ bh at
-    put_ bh (IfaceExt aa) = do
-        putByte bh 11
-        put_ bh aa
-    put_ bh (IfaceCast ie ico) = do
-        putByte bh 12
-        put_ bh ie
-        put_ bh ico
-    put_ bh (IfaceECase a b) = do
-        putByte bh 13
-        put_ bh a
-        put_ bh b
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> do aa <- get bh
-                    return (IfaceLcl aa)
-            1 -> do ab <- get bh
-                    return (IfaceType ab)
-            2 -> do ab <- get bh
-                    return (IfaceCo ab)
-            3 -> do ac <- get bh
-                    ad <- get bh
-                    return (IfaceTuple ac ad)
-            4 -> do ae <- get bh
-                    af <- get bh
-                    return (IfaceLam ae af)
-            5 -> do ag <- get bh
-                    ah <- get bh
-                    return (IfaceApp ag ah)
-            6 -> do ai <- get bh
-                    aj <- get bh
-                    ak <- get bh
-                    return (IfaceCase ai aj ak)
-            7 -> do al <- get bh
-                    am <- get bh
-                    return (IfaceLet al am)
-            8 -> do an <- get bh
-                    ao <- get bh
-                    return (IfaceTick an ao)
-            9 -> do ap <- get bh
-                    return (IfaceLit ap)
-            10 -> do as <- get bh
-                     at <- get bh
-                     return (IfaceFCall as at)
-            11 -> do aa <- get bh
-                     return (IfaceExt aa)
-            12 -> do ie <- get bh
-                     ico <- get bh
-                     return (IfaceCast ie ico)
-            13 -> do a <- get bh
-                     b <- get bh
-                     return (IfaceECase a b)
-            _ -> panic ("get IfaceExpr " ++ show h)
-
-instance Binary IfaceConAlt where
-    put_ bh IfaceDefault      = putByte bh 0
-    put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
-    put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> return IfaceDefault
-            1 -> get bh >>= (return . IfaceDataAlt)
-            _ -> get bh >>= (return . IfaceLitAlt)
-
-instance Binary IfaceBinding where
-    put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
-    put_ bh (IfaceRec ac)       = putByte bh 1 >> put_ bh ac
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
-            _ -> do { ac <- get bh; return (IfaceRec ac) }
-
-instance Binary IfaceIdDetails where
-    put_ bh IfVanillaId      = putByte bh 0
-    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
-    put_ bh (IfDFunId n)     = do { putByte bh 2; put_ bh n }
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> return IfVanillaId
-            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
-            _ -> do { n <- get bh; return (IfDFunId n) }
-
-instance Binary IfaceIdInfo where
-    put_ bh NoInfo      = putByte bh 0
-    put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
-
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> return NoInfo
-            _ -> lazyGet bh >>= (return . HasInfo)     -- NB lazyGet
-
-instance Binary IfaceInfoItem where
-    put_ bh (HsArity aa)          = putByte bh 0 >> put_ bh aa
-    put_ bh (HsStrictness ab)     = putByte bh 1 >> put_ bh ab
-    put_ bh (HsUnfold lb ad)      = putByte bh 2 >> put_ bh lb >> put_ bh ad
-    put_ bh (HsInline ad)         = putByte bh 3 >> put_ bh ad
-    put_ bh HsNoCafRefs           = putByte bh 4
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> get bh >>= (return . HsArity)
-            1 -> get bh >>= (return . HsStrictness)
-            2 -> do lb <- get bh
-                    ad <- get bh
-                    return (HsUnfold lb ad)
-            3 -> get bh >>= (return . HsInline)
-            _ -> return HsNoCafRefs
-
-instance Binary IfaceUnfolding where
-    put_ bh (IfCoreUnfold s e) = do
-        putByte bh 0
-        put_ bh s
-        put_ bh e
-    put_ bh (IfInlineRule a b c d) = do
-        putByte bh 1
-        put_ bh a
-        put_ bh b
-        put_ bh c
-        put_ bh d
-    put_ bh (IfLclWrapper a n) = do
-        putByte bh 2
-        put_ bh a
-        put_ bh n
-    put_ bh (IfExtWrapper a n) = do
-        putByte bh 3
-        put_ bh a
-        put_ bh n
-    put_ bh (IfDFunUnfold as bs) = do
-        putByte bh 4
-        put_ bh as
-        put_ bh bs
-    put_ bh (IfCompulsory e) = do
-        putByte bh 5
-        put_ bh e
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> do s <- get bh
-                    e <- get bh
-                    return (IfCoreUnfold s e)
-            1 -> do a <- get bh
-                    b <- get bh
-                    c <- get bh
-                    d <- get bh
-                    return (IfInlineRule a b c d)
-            2 -> do a <- get bh
-                    n <- get bh
-                    return (IfLclWrapper a n)
-            3 -> do a <- get bh
-                    n <- get bh
-                    return (IfExtWrapper a n)
-            4 -> do as <- get bh
-                    bs <- get bh
-                    return (IfDFunUnfold as bs)
-            _ -> do e <- get bh
-                    return (IfCompulsory e)
-
-instance Binary IfaceTickish where
-    put_ bh (IfaceHpcTick m ix) = do
-        putByte bh 0
-        put_ bh m
-        put_ bh ix
-    put_ bh (IfaceSCC cc tick push) = do
-        putByte bh 1
-        put_ bh cc
-        put_ bh tick
-        put_ bh push
-
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> do m <- get bh
-                    ix <- get bh
-                    return (IfaceHpcTick m ix)
-            1 -> do cc <- get bh
-                    tick <- get bh
-                    push <- get bh
-                    return (IfaceSCC cc tick push)
-            _ -> panic ("get IfaceTickish " ++ show h)
-
--------------------------------------------------------------------------
---              IfaceDecl and friends
--------------------------------------------------------------------------
-
--- A bit of magic going on here: there's no need to store the OccName
--- for a decl on the disk, since we can infer the namespace from the
--- context; however it is useful to have the OccName in the IfaceDecl
--- to avoid re-building it in various places.  So we build the OccName
--- when de-serialising.
-
-instance Binary IfaceDecl where
-    put_ bh (IfaceId name ty details idinfo) = do
-        putByte bh 0
-        put_ bh (occNameFS name)
-        put_ bh ty
-        put_ bh details
-        put_ bh idinfo
-
-    put_ _ (IfaceForeign _ _) = 
-        error "Binary.put_(IfaceDecl): IfaceForeign"
-
-    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
-        putByte bh 2
-        put_ bh (occNameFS a1)
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-        put_ bh a6
-        put_ bh a7
-        put_ bh a8
-        put_ bh a9
-
-    put_ bh (IfaceSyn a1 a2 a3 a4) = do
-        putByte bh 3
-        put_ bh (occNameFS a1)
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-
-    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
-        putByte bh 4
-        put_ bh a1
-        put_ bh (occNameFS a2)
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-        put_ bh a6
-        put_ bh a7
-        
-    put_ bh (IfaceAxiom a1 a2 a3) = do
-        putByte bh 5
-        put_ bh (occNameFS a1)
-        put_ bh a2
-        put_ bh a3
-
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> do name    <- get bh
-                    ty      <- get bh
-                    details <- get bh
-                    idinfo  <- get bh
-                    occ <- return $! mkOccNameFS varName name
-                    return (IfaceId occ ty details idinfo)
-            1 -> error "Binary.get(TyClDecl): ForeignType"
-            2 -> do a1 <- get bh
-                    a2 <- get bh
-                    a3 <- get bh
-                    a4 <- get bh
-                    a5 <- get bh
-                    a6 <- get bh
-                    a7 <- get bh
-                    a8 <- get bh
-                    a9 <- get bh
-                    occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
-            3 -> do a1 <- get bh
-                    a2 <- get bh
-                    a3 <- get bh
-                    a4 <- get bh
-                    occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceSyn occ a2 a3 a4)
-            4 -> do a1 <- get bh
-                    a2 <- get bh
-                    a3 <- get bh
-                    a4 <- get bh
-                    a5 <- get bh
-                    a6 <- get bh
-                    a7 <- get bh
-                    occ <- return $! mkOccNameFS clsName a2
-                    return (IfaceClass a1 occ a3 a4 a5 a6 a7)
-            _ -> do a1 <- get bh
-                    a2 <- get bh
-                    a3 <- get bh
-                    occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceAxiom occ a2 a3)
-
-instance Binary IfaceAxBranch where
-    put_ bh (IfaceAxBranch a1 a2 a3 a4) = do
-        put_ bh a1
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        a3 <- get bh
-        a4 <- get bh
-        return (IfaceAxBranch a1 a2 a3 a4)
-
-instance Binary IfaceSynTyConRhs where
-    put_ bh IfaceOpenSynFamilyTyCon        = putByte bh 0
-    put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax
-    put_ bh (IfaceSynonymTyCon ty)         = putByte bh 2 >> put_ bh ty
-
-    get bh = do { h <- getByte bh
-                ; case h of
-                    0 -> do { return IfaceOpenSynFamilyTyCon }
-                    1 -> do { ax <- get bh
-                            ; return (IfaceClosedSynFamilyTyCon ax) }
-                    _ -> do { ty <- get bh
-                            ; return (IfaceSynonymTyCon ty) } }
-
-instance Binary IfaceClsInst where
-    put_ bh (IfaceClsInst cls tys dfun flag orph) = do
-        put_ bh cls
-        put_ bh tys
-        put_ bh dfun
-        put_ bh flag
-        put_ bh orph
-    get bh = do
-        cls  <- get bh
-        tys  <- get bh
-        dfun <- get bh
-        flag <- get bh
-        orph <- get bh
-        return (IfaceClsInst cls tys dfun flag orph)
-
-instance Binary IfaceFamInst where
-    put_ bh (IfaceFamInst fam tys name orph) = do
-        put_ bh fam
-        put_ bh tys
-        put_ bh name
-        put_ bh orph
-    get bh = do
-        fam      <- get bh
-        tys      <- get bh
-        name     <- get bh
-        orph     <- get bh
-        return (IfaceFamInst fam tys name orph)
-
-instance Binary OverlapFlag where
-    put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
-    put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
-    put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
-    get bh = do
-        h <- getByte bh
-        b <- get bh
-        case h of
-            0 -> return $ NoOverlap b
-            1 -> return $ OverlapOk b
-            2 -> return $ Incoherent b
-            _ -> panic ("get OverlapFlag " ++ show h)
-
-instance Binary IfaceConDecls where
-    put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
-    put_ bh IfDataFamTyCon     = putByte bh 1
-    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
-    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> get bh >>= (return . IfAbstractTyCon)
-            1 -> return IfDataFamTyCon
-            2 -> get bh >>= (return . IfDataTyCon)
-            _ -> get bh >>= (return . IfNewTyCon)
-
-instance Binary IfaceConDecl where
-    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
-        put_ bh a1
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-        put_ bh a6
-        put_ bh a7
-        put_ bh a8
-        put_ bh a9
-        put_ bh a10
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        a3 <- get bh          
-        a4 <- get bh
-        a5 <- get bh
-        a6 <- get bh
-        a7 <- get bh
-        a8 <- get bh
-        a9 <- get bh
-        a10 <- get bh
-        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
-
-instance Binary IfaceAT where
-    put_ bh (IfaceAT dec defs) = do
-        put_ bh dec
-        put_ bh defs
-    get bh = do
-        dec  <- get bh
-        defs <- get bh
-        return (IfaceAT dec defs)
-
-instance Binary IfaceClassOp where
-    put_ bh (IfaceClassOp n def ty) = do 
-        put_ bh (occNameFS n)
-        put_ bh def     
-        put_ bh ty
-    get bh = do
-        n   <- get bh
-        def <- get bh
-        ty  <- get bh
-        occ <- return $! mkOccNameFS varName n
-        return (IfaceClassOp occ def ty)
-
-instance Binary IfaceRule where
-    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
-        put_ bh a1
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-        put_ bh a6
-        put_ bh a7
-        put_ bh a8
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        a3 <- get bh
-        a4 <- get bh
-        a5 <- get bh
-        a6 <- get bh
-        a7 <- get bh
-        a8 <- get bh
-        return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
-
-instance Binary IfaceAnnotation where
-    put_ bh (IfaceAnnotation a1 a2) = do
-        put_ bh a1
-        put_ bh a2
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        return (IfaceAnnotation a1 a2)
-
-instance Binary name => Binary (AnnTarget name) where
-    put_ bh (NamedTarget a) = do
-        putByte bh 0
-        put_ bh a
-    put_ bh (ModuleTarget a) = do
-        putByte bh 1
-        put_ bh a
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> get bh >>= (return . NamedTarget)
-            _ -> get bh >>= (return . ModuleTarget)
-
-instance Binary IfaceVectInfo where
-    put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
-        put_ bh a1
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        a3 <- get bh
-        a4 <- get bh
-        a5 <- get bh
-        return (IfaceVectInfo a1 a2 a3 a4 a5)
-
-instance Binary IfaceTrustInfo where
-    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
-    get bh = getByte bh >>= (return . numToTrustInfo)
-
index ad327d6..0150d21 100644 (file)
@@ -112,20 +112,148 @@ data IfaceDecl
                                                 -- beyond .NET
                    ifExtName :: Maybe FastString }
 
+-- A bit of magic going on here: there's no need to store the OccName
+-- for a decl on the disk, since we can infer the namespace from the
+-- context; however it is useful to have the OccName in the IfaceDecl
+-- to avoid re-building it in various places.  So we build the OccName
+-- when de-serialising.
+
+instance Binary IfaceDecl where
+    put_ bh (IfaceId name ty details idinfo) = do
+        putByte bh 0
+        put_ bh (occNameFS name)
+        put_ bh ty
+        put_ bh details
+        put_ bh idinfo
+
+    put_ _ (IfaceForeign _ _) = 
+        error "Binary.put_(IfaceDecl): IfaceForeign"
+
+    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
+        putByte bh 2
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
+        put_ bh a9
+
+    put_ bh (IfaceSyn a1 a2 a3 a4) = do
+        putByte bh 3
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+
+    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
+        putByte bh 4
+        put_ bh a1
+        put_ bh (occNameFS a2)
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+
+    put_ bh (IfaceAxiom a1 a2 a3) = do
+        putByte bh 5
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> do name    <- get bh
+                    ty      <- get bh
+                    details <- get bh
+                    idinfo  <- get bh
+                    occ <- return $! mkOccNameFS varName name
+                    return (IfaceId occ ty details idinfo)
+            1 -> error "Binary.get(TyClDecl): ForeignType"
+            2 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
+                    a6 <- get bh
+                    a7 <- get bh
+                    a8 <- get bh
+                    a9 <- get bh
+                    occ <- return $! mkOccNameFS tcName a1
+                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
+            3 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    occ <- return $! mkOccNameFS tcName a1
+                    return (IfaceSyn occ a2 a3 a4)
+            4 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
+                    a6 <- get bh
+                    a7 <- get bh
+                    occ <- return $! mkOccNameFS clsName a2
+                    return (IfaceClass a1 occ a3 a4 a5 a6 a7)
+            _ -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    occ <- return $! mkOccNameFS tcName a1
+                    return (IfaceAxiom occ a2 a3)
+
 data IfaceSynTyConRhs
   = IfaceOpenSynFamilyTyCon
   | IfaceClosedSynFamilyTyCon IfExtName  -- name of associated axiom
   | IfaceSynonymTyCon IfaceType
 
+instance Binary IfaceSynTyConRhs where
+    put_ bh IfaceOpenSynFamilyTyCon        = putByte bh 0
+    put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax
+    put_ bh (IfaceSynonymTyCon ty)         = putByte bh 2 >> put_ bh ty
+
+    get bh = do { h <- getByte bh
+                ; case h of
+                    0 -> do { return IfaceOpenSynFamilyTyCon }
+                    1 -> do { ax <- get bh
+                            ; return (IfaceClosedSynFamilyTyCon ax) }
+                    _ -> do { ty <- get bh
+                            ; return (IfaceSynonymTyCon ty) } }
+
 data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
         -- Nothing    => no default method
         -- Just False => ordinary polymorphic default method
         -- Just True  => generic default method
 
+instance Binary IfaceClassOp where
+    put_ bh (IfaceClassOp n def ty) = do 
+        put_ bh (occNameFS n)
+        put_ bh def     
+        put_ bh ty
+    get bh = do
+        n   <- get bh
+        def <- get bh
+        ty  <- get bh
+        occ <- return $! mkOccNameFS varName n
+        return (IfaceClassOp occ def ty)
+
 data IfaceAT = IfaceAT IfaceDecl [IfaceAxBranch]
         -- Nothing => no default associated type instance
         -- Just ds => default associated type instance from these templates
 
+instance Binary IfaceAT where
+    put_ bh (IfaceAT dec defs) = do
+        put_ bh dec
+        put_ bh defs
+    get bh = do
+        dec  <- get bh
+        defs <- get bh
+        return (IfaceAT dec defs)
+
 instance Outputable IfaceAxBranch where
   ppr = pprAxBranch Nothing
 
@@ -157,12 +285,38 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
                                    , ifaxbIncomps :: [BranchIndex] }
                                      -- See Note [Storing compatibility] in CoAxiom
 
+instance Binary IfaceAxBranch where
+    put_ bh (IfaceAxBranch a1 a2 a3 a4) = do
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        return (IfaceAxBranch a1 a2 a3 a4)
+
 data IfaceConDecls
   = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
   | IfDataFamTyCon              -- Data family
   | IfDataTyCon [IfaceConDecl]  -- Data type decls
   | IfNewTyCon  IfaceConDecl    -- Newtype decls
 
+instance Binary IfaceConDecls where
+    put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
+    put_ bh IfDataFamTyCon     = putByte bh 1
+    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
+    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> get bh >>= (return . IfAbstractTyCon)
+            1 -> return IfDataFamTyCon
+            2 -> get bh >>= (return . IfDataTyCon)
+            _ -> get bh >>= (return . IfNewTyCon)
+
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
 visibleIfConDecls IfDataFamTyCon      = []
@@ -183,9 +337,48 @@ data IfaceConDecl
         ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
                                                 -- or 1-1 corresp with arg tys
 
+instance Binary IfaceConDecl where
+    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
+        put_ bh a9
+        put_ bh a10
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        a5 <- get bh
+        a6 <- get bh
+        a7 <- get bh
+        a8 <- get bh
+        a9 <- get bh
+        a10 <- get bh
+        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+
 data IfaceBang
   = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
 
+instance Binary IfaceBang where
+    put_ bh IfNoBang        = putByte bh 0
+    put_ bh IfStrict        = putByte bh 1
+    put_ bh IfUnpack        = putByte bh 2
+    put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return IfNoBang
+              1 -> do return IfStrict
+              2 -> do return IfUnpack
+              _ -> do { a <- get bh; return (IfUnpackCo a) }
+
 data IfaceClsInst
   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
@@ -199,6 +392,21 @@ data IfaceClsInst
         -- If this instance decl is *used*, we'll record a usage on the dfun;
         -- and if the head does not change it won't be used if it wasn't before
 
+instance Binary IfaceClsInst where
+    put_ bh (IfaceClsInst cls tys dfun flag orph) = do
+        put_ bh cls
+        put_ bh tys
+        put_ bh dfun
+        put_ bh flag
+        put_ bh orph
+    get bh = do
+        cls  <- get bh
+        tys  <- get bh
+        dfun <- get bh
+        flag <- get bh
+        orph <- get bh
+        return (IfaceClsInst cls tys dfun flag orph)
+
 -- The ifFamInstTys field of IfaceFamInst contains a list of the rough
 -- match types
 data IfaceFamInst
@@ -208,6 +416,19 @@ data IfaceFamInst
                  , ifFamInstOrph     :: Maybe OccName        -- Just like IfaceClsInst
                  }
 
+instance Binary IfaceFamInst where
+    put_ bh (IfaceFamInst fam tys name orph) = do
+        put_ bh fam
+        put_ bh tys
+        put_ bh name
+        put_ bh orph
+    get bh = do
+        fam      <- get bh
+        tys      <- get bh
+        name     <- get bh
+        orph     <- get bh
+        return (IfaceFamInst fam tys name orph)
+
 data IfaceRule
   = IfaceRule {
         ifRuleName   :: RuleName,
@@ -220,12 +441,42 @@ data IfaceRule
         ifRuleOrph   :: Maybe OccName   -- Just like IfaceClsInst
     }
 
+instance Binary IfaceRule where
+    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        a5 <- get bh
+        a6 <- get bh
+        a7 <- get bh
+        a8 <- get bh
+        return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
+
 data IfaceAnnotation
   = IfaceAnnotation {
         ifAnnotatedTarget :: IfaceAnnTarget,
         ifAnnotatedValue :: Serialized
   }
 
+instance Binary IfaceAnnotation where
+    put_ bh (IfaceAnnotation a1 a2) = do
+        put_ bh a1
+        put_ bh a2
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        return (IfaceAnnotation a1 a2)
+
 type IfaceAnnTarget = AnnTarget OccName
 
 -- We only serialise the IdDetails of top-level Ids, and even then
@@ -238,10 +489,31 @@ data IfaceIdDetails
   | IfRecSelId IfaceTyCon Bool
   | IfDFunId Int          -- Number of silent args
 
+instance Binary IfaceIdDetails where
+    put_ bh IfVanillaId      = putByte bh 0
+    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
+    put_ bh (IfDFunId n)     = do { putByte bh 2; put_ bh n }
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> return IfVanillaId
+            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
+            _ -> do { n <- get bh; return (IfDFunId n) }
+
 data IfaceIdInfo
   = NoInfo                      -- When writing interface file without -O
   | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 
+instance Binary IfaceIdInfo where
+    put_ bh NoInfo      = putByte bh 0
+    put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
+
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> return NoInfo
+            _ -> lazyGet bh >>= (return . HasInfo)     -- NB lazyGet
+
 -- Here's a tricky case:
 --   * Compile with -O module A, and B which imports A.f
 --   * Change function f in A, and recompile without -O
@@ -260,6 +532,23 @@ data IfaceInfoItem
                     IfaceUnfolding   -- See Note [Expose recursive functions]
   | HsNoCafRefs
 
+instance Binary IfaceInfoItem where
+    put_ bh (HsArity aa)          = putByte bh 0 >> put_ bh aa
+    put_ bh (HsStrictness ab)     = putByte bh 1 >> put_ bh ab
+    put_ bh (HsUnfold lb ad)      = putByte bh 2 >> put_ bh lb >> put_ bh ad
+    put_ bh (HsInline ad)         = putByte bh 3 >> put_ bh ad
+    put_ bh HsNoCafRefs           = putByte bh 4
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> get bh >>= (return . HsArity)
+            1 -> get bh >>= (return . HsStrictness)
+            2 -> do lb <- get bh
+                    ad <- get bh
+                    return (HsUnfold lb ad)
+            3 -> get bh >>= (return . HsInline)
+            _ -> return HsNoCafRefs
+
 -- NB: Specialisations and rules come in separately and are
 -- only later attached to the Id.  Partial reason: some are orphans.
 
@@ -281,6 +570,55 @@ data IfaceUnfolding
 
   | IfDFunUnfold [IfaceBndr] [IfaceExpr]
 
+instance Binary IfaceUnfolding where
+    put_ bh (IfCoreUnfold s e) = do
+        putByte bh 0
+        put_ bh s
+        put_ bh e
+    put_ bh (IfInlineRule a b c d) = do
+        putByte bh 1
+        put_ bh a
+        put_ bh b
+        put_ bh c
+        put_ bh d
+    put_ bh (IfLclWrapper a n) = do
+        putByte bh 2
+        put_ bh a
+        put_ bh n
+    put_ bh (IfExtWrapper a n) = do
+        putByte bh 3
+        put_ bh a
+        put_ bh n
+    put_ bh (IfDFunUnfold as bs) = do
+        putByte bh 4
+        put_ bh as
+        put_ bh bs
+    put_ bh (IfCompulsory e) = do
+        putByte bh 5
+        put_ bh e
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> do s <- get bh
+                    e <- get bh
+                    return (IfCoreUnfold s e)
+            1 -> do a <- get bh
+                    b <- get bh
+                    c <- get bh
+                    d <- get bh
+                    return (IfInlineRule a b c d)
+            2 -> do a <- get bh
+                    n <- get bh
+                    return (IfLclWrapper a n)
+            3 -> do a <- get bh
+                    n <- get bh
+                    return (IfExtWrapper a n)
+            4 -> do as <- get bh
+                    bs <- get bh
+                    return (IfDFunUnfold as bs)
+            _ -> do e <- get bh
+                    return (IfCompulsory e)
+
 --------------------------------
 data IfaceExpr
   = IfaceLcl    IfLclName
@@ -298,11 +636,130 @@ data IfaceExpr
   | IfaceFCall  ForeignCall IfaceType
   | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E
 
+instance Binary IfaceExpr where
+    put_ bh (IfaceLcl aa) = do
+        putByte bh 0
+        put_ bh aa
+    put_ bh (IfaceType ab) = do
+        putByte bh 1
+        put_ bh ab
+    put_ bh (IfaceCo ab) = do
+        putByte bh 2
+        put_ bh ab
+    put_ bh (IfaceTuple ac ad) = do
+        putByte bh 3
+        put_ bh ac
+        put_ bh ad
+    put_ bh (IfaceLam ae af) = do
+        putByte bh 4
+        put_ bh ae
+        put_ bh af
+    put_ bh (IfaceApp ag ah) = do
+        putByte bh 5
+        put_ bh ag
+        put_ bh ah
+    put_ bh (IfaceCase ai aj ak) = do
+        putByte bh 6
+        put_ bh ai
+        put_ bh aj
+        put_ bh ak
+    put_ bh (IfaceLet al am) = do
+        putByte bh 7
+        put_ bh al
+        put_ bh am
+    put_ bh (IfaceTick an ao) = do
+        putByte bh 8
+        put_ bh an
+        put_ bh ao
+    put_ bh (IfaceLit ap) = do
+        putByte bh 9
+        put_ bh ap
+    put_ bh (IfaceFCall as at) = do
+        putByte bh 10
+        put_ bh as
+        put_ bh at
+    put_ bh (IfaceExt aa) = do
+        putByte bh 11
+        put_ bh aa
+    put_ bh (IfaceCast ie ico) = do
+        putByte bh 12
+        put_ bh ie
+        put_ bh ico
+    put_ bh (IfaceECase a b) = do
+        putByte bh 13
+        put_ bh a
+        put_ bh b
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> do aa <- get bh
+                    return (IfaceLcl aa)
+            1 -> do ab <- get bh
+                    return (IfaceType ab)
+            2 -> do ab <- get bh
+                    return (IfaceCo ab)
+            3 -> do ac <- get bh
+                    ad <- get bh
+                    return (IfaceTuple ac ad)
+            4 -> do ae <- get bh
+                    af <- get bh
+                    return (IfaceLam ae af)
+            5 -> do ag <- get bh
+                    ah <- get bh
+                    return (IfaceApp ag ah)
+            6 -> do ai <- get bh
+                    aj <- get bh
+                    ak <- get bh
+                    return (IfaceCase ai aj ak)
+            7 -> do al <- get bh
+                    am <- get bh
+                    return (IfaceLet al am)
+            8 -> do an <- get bh
+                    ao <- get bh
+                    return (IfaceTick an ao)
+            9 -> do ap <- get bh
+                    return (IfaceLit ap)
+            10 -> do as <- get bh
+                     at <- get bh
+                     return (IfaceFCall as at)
+            11 -> do aa <- get bh
+                     return (IfaceExt aa)
+            12 -> do ie <- get bh
+                     ico <- get bh
+                     return (IfaceCast ie ico)
+            13 -> do a <- get bh
+                     b <- get bh
+                     return (IfaceECase a b)
+            _ -> panic ("get IfaceExpr " ++ show h)
+
 data IfaceTickish
   = IfaceHpcTick Module Int                -- from HpcTick x
   | IfaceSCC     CostCentre Bool Bool      -- from ProfNote
   -- no breakpoints: we never export these into interface files
 
+instance Binary IfaceTickish where
+    put_ bh (IfaceHpcTick m ix) = do
+        putByte bh 0
+        put_ bh m
+        put_ bh ix
+    put_ bh (IfaceSCC cc tick push) = do
+        putByte bh 1
+        put_ bh cc
+        put_ bh tick
+        put_ bh push
+
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> do m <- get bh
+                    ix <- get bh
+                    return (IfaceHpcTick m ix)
+            1 -> do cc <- get bh
+                    tick <- get bh
+                    push <- get bh
+                    return (IfaceSCC cc tick push)
+            _ -> panic ("get IfaceTickish " ++ show h)
+
 type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
         -- Note: IfLclName, not IfaceBndr (and same with the case binder)
         -- We reconstruct the kind/type of the thing from the context
@@ -312,14 +769,44 @@ data IfaceConAlt = IfaceDefault
                  | IfaceDataAlt IfExtName
                  | IfaceLitAlt Literal
 
+instance Binary IfaceConAlt where
+    put_ bh IfaceDefault      = putByte bh 0
+    put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
+    put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> return IfaceDefault
+            1 -> get bh >>= (return . IfaceDataAlt)
+            _ -> get bh >>= (return . IfaceLitAlt)
+
 data IfaceBinding
   = IfaceNonRec IfaceLetBndr IfaceExpr
   | IfaceRec    [(IfaceLetBndr, IfaceExpr)]
 
+instance Binary IfaceBinding where
+    put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
+    put_ bh (IfaceRec ac)       = putByte bh 1 >> put_ bh ac
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
+            _ -> do { ac <- get bh; return (IfaceRec ac) }
+
 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
 -- It's used for *non-top-level* let/rec binders
 -- See Note [IdInfo on nested let-bindings]
 data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
+
+instance Binary IfaceLetBndr where
+    put_ bh (IfLetBndr a b c) = do
+            put_ bh a
+            put_ bh b
+            put_ bh c
+    get bh = do a <- get bh
+                b <- get bh
+                c <- get bh
+                return (IfLetBndr a b c)
 \end{code}
 
 Note [Empty case alternatives]
index 480eb7e..c3b59b7 100644 (file)
@@ -40,8 +40,11 @@ import TysPrim
 import PrelNames( funTyConKey )
 import Name
 import BasicTypes
+import Binary
 import Outputable
 import FastString
+
+import Control.Monad
 \end{code}
 
 %************************************************************************
@@ -173,6 +176,21 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
 
 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
 pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
+
+instance Binary IfaceBndr where
+    put_ bh (IfaceIdBndr aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (IfaceTvBndr ab) = do
+            putByte bh 1
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      return (IfaceIdBndr aa)
+              _ -> do ab <- get bh
+                      return (IfaceTvBndr ab)
 \end{code}
 
 ----------------------------- Printing IfaceType ------------------------------------
@@ -264,6 +282,10 @@ ppr_tylit (IfaceStrTyLit n) = text (show n)
 instance Outputable IfaceTyCon where
   ppr = ppr . ifaceTyConName
 
+instance Binary IfaceTyCon where
+   put_ bh (IfaceTc ext) = put_ bh ext
+   get bh = liftM IfaceTc (get bh)
+
 instance Outputable IfaceCoCon where
   ppr (IfaceCoAx n i)  = ppr n <> brackets (ppr i)
   ppr IfaceReflCo      = ptext (sLit "Refl")
@@ -274,9 +296,45 @@ instance Outputable IfaceCoCon where
   ppr (IfaceNthCo d)   = ptext (sLit "Nth:") <> int d
   ppr (IfaceLRCo lr)   = ppr lr
 
+instance Binary IfaceCoCon where
+   put_ bh (IfaceCoAx n ind)   = do { putByte bh 0; put_ bh n; put_ bh ind }
+   put_ bh IfaceReflCo         = putByte bh 1
+   put_ bh IfaceUnsafeCo       = putByte bh 2
+   put_ bh IfaceSymCo          = putByte bh 3
+   put_ bh IfaceTransCo        = putByte bh 4
+   put_ bh IfaceInstCo         = putByte bh 5
+   put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
+   put_ bh (IfaceLRCo lr)      = do { putByte bh 7; put_ bh lr }
+
+   get bh = do
+        h <- getByte bh
+        case h of
+          0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) }
+          1 -> return IfaceReflCo 
+          2 -> return IfaceUnsafeCo
+          3 -> return IfaceSymCo
+          4 -> return IfaceTransCo
+          5 -> return IfaceInstCo
+          6 -> do { d <- get bh; return (IfaceNthCo d) }
+          7 -> do { lr <- get bh; return (IfaceLRCo lr) }
+          _ -> panic ("get IfaceCoCon " ++ show h)
+
 instance Outputable IfaceTyLit where
   ppr = ppr_tylit
 
+instance Binary IfaceTyLit where
+  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n
+  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n
+
+  get bh =
+    do tag <- getByte bh
+       case tag of
+         1 -> do { n <- get bh
+                 ; return (IfaceNumTyLit n) }
+         2 -> do { n <- get bh
+                 ; return (IfaceStrTyLit n) }
+         _ -> panic ("get IfaceTyLit " ++ show tag)
+
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
@@ -286,6 +344,54 @@ pprIfaceContext theta = ppr_preds theta <+> darrow
 ppr_preds :: [IfacePredType] -> SDoc
 ppr_preds [pred] = ppr pred    -- No parens
 ppr_preds preds  = parens (sep (punctuate comma (map ppr preds)))
+
+instance Binary IfaceType where
+    put_ bh (IfaceForAllTy aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (IfaceTyVar ad) = do
+            putByte bh 1
+            put_ bh ad
+    put_ bh (IfaceAppTy ae af) = do
+            putByte bh 2
+            put_ bh ae
+            put_ bh af
+    put_ bh (IfaceFunTy ag ah) = do
+            putByte bh 3
+            put_ bh ag
+            put_ bh ah
+    put_ bh (IfaceCoConApp cc tys)
+      = do { putByte bh 4; put_ bh cc; put_ bh tys }
+    put_ bh (IfaceTyConApp tc tys)
+      = do { putByte bh 5; put_ bh tc; put_ bh tys }
+
+    put_ bh (IfaceLitTy n)
+      = do { putByte bh 30; put_ bh n }
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      ab <- get bh
+                      return (IfaceForAllTy aa ab)
+              1 -> do ad <- get bh
+                      return (IfaceTyVar ad)
+              2 -> do ae <- get bh
+                      af <- get bh
+                      return (IfaceAppTy ae af)
+              3 -> do ag <- get bh
+                      ah <- get bh
+                      return (IfaceFunTy ag ah)
+              4 -> do { cc <- get bh; tys <- get bh
+                      ; return (IfaceCoConApp cc tys) }
+              5 -> do { tc <- get bh; tys <- get bh
+                      ; return (IfaceTyConApp tc tys) }
+
+              30 -> do n <- get bh
+                       return (IfaceLitTy n)
+
+              _  -> panic ("get IfaceType " ++ show h)
 \end{code}
 
 %************************************************************************
index 277c059..ec179d8 100644 (file)
@@ -16,6 +16,7 @@ module Annotations (
         deserializeAnns
     ) where
 
+import Binary
 import Module           ( Module )
 import Name
 import Outputable
@@ -64,6 +65,19 @@ instance Outputable name => Outputable (AnnTarget name) where
     ppr (NamedTarget nm) = text "Named target" <+> ppr nm
     ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
 
+instance Binary name => Binary (AnnTarget name) where
+    put_ bh (NamedTarget a) = do
+        putByte bh 0
+        put_ bh a
+    put_ bh (ModuleTarget a) = do
+        putByte bh 1
+        put_ bh a
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> get bh >>= (return . NamedTarget)
+            _ -> get bh >>= (return . ModuleTarget)
+
 instance Outputable Annotation where
     ppr ann = ppr (ann_target ann)
 
index 163af05..e022ae3 100644 (file)
@@ -159,6 +159,7 @@ import StringBuffer     ( StringBuffer )
 import Fingerprint
 import MonadUtils
 import Bag
+import Binary
 import ErrUtils
 import Platform
 import Util
@@ -717,6 +718,113 @@ data ModIface
                 -- See Note [RnNames . Trust Own Package]
      }
 
+instance Binary ModIface where
+   put_ bh (ModIface {
+                 mi_module    = mod,
+                 mi_boot      = is_boot,
+                 mi_iface_hash= iface_hash,
+                 mi_mod_hash  = mod_hash,
+                 mi_flag_hash = flag_hash,
+                 mi_orphan    = orphan,
+                 mi_finsts    = hasFamInsts,
+                 mi_deps      = deps,
+                 mi_usages    = usages,
+                 mi_exports   = exports,
+                 mi_exp_hash  = exp_hash,
+                 mi_used_th   = used_th,
+                 mi_fixities  = fixities,
+                 mi_warns     = warns,
+                 mi_anns      = anns,
+                 mi_decls     = decls,
+                 mi_insts     = insts,
+                 mi_fam_insts = fam_insts,
+                 mi_rules     = rules,
+                 mi_orphan_hash = orphan_hash,
+                 mi_vect_info = vect_info,
+                 mi_hpc       = hpc_info,
+                 mi_trust     = trust,
+                 mi_trust_pkg = trust_pkg }) = do
+        put_ bh mod
+        put_ bh is_boot
+        put_ bh iface_hash
+        put_ bh mod_hash
+        put_ bh flag_hash
+        put_ bh orphan
+        put_ bh hasFamInsts
+        lazyPut bh deps
+        lazyPut bh usages
+        put_ bh exports
+        put_ bh exp_hash
+        put_ bh used_th
+        put_ bh fixities
+        lazyPut bh warns
+        lazyPut bh anns
+        put_ bh decls
+        put_ bh insts
+        put_ bh fam_insts
+        lazyPut bh rules
+        put_ bh orphan_hash
+        put_ bh vect_info
+        put_ bh hpc_info
+        put_ bh trust
+        put_ bh trust_pkg
+
+   get bh = do
+        mod_name    <- get bh
+        is_boot     <- get bh
+        iface_hash  <- get bh
+        mod_hash    <- get bh
+        flag_hash   <- get bh
+        orphan      <- get bh
+        hasFamInsts <- get bh
+        deps        <- lazyGet bh
+        usages      <- {-# SCC "bin_usages" #-} lazyGet bh
+        exports     <- {-# SCC "bin_exports" #-} get bh
+        exp_hash    <- get bh
+        used_th     <- get bh
+        fixities    <- {-# SCC "bin_fixities" #-} get bh
+        warns       <- {-# SCC "bin_warns" #-} lazyGet bh
+        anns        <- {-# SCC "bin_anns" #-} lazyGet bh
+        decls       <- {-# SCC "bin_tycldecls" #-} get bh
+        insts       <- {-# SCC "bin_insts" #-} get bh
+        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
+        rules       <- {-# SCC "bin_rules" #-} lazyGet bh
+        orphan_hash <- get bh
+        vect_info   <- get bh
+        hpc_info    <- get bh
+        trust       <- get bh
+        trust_pkg   <- get bh
+        return (ModIface {
+                 mi_module      = mod_name,
+                 mi_boot        = is_boot,
+                 mi_iface_hash  = iface_hash,
+                 mi_mod_hash    = mod_hash,
+                 mi_flag_hash   = flag_hash,
+                 mi_orphan      = orphan,
+                 mi_finsts      = hasFamInsts,
+                 mi_deps        = deps,
+                 mi_usages      = usages,
+                 mi_exports     = exports,
+                 mi_exp_hash    = exp_hash,
+                 mi_used_th     = used_th,
+                 mi_anns        = anns,
+                 mi_fixities    = fixities,
+                 mi_warns       = warns,
+                 mi_decls       = decls,
+                 mi_globals     = Nothing,
+                 mi_insts       = insts,
+                 mi_fam_insts   = fam_insts,
+                 mi_rules       = rules,
+                 mi_orphan_hash = orphan_hash,
+                 mi_vect_info   = vect_info,
+                 mi_hpc         = hpc_info,
+                 mi_trust       = trust,
+                 mi_trust_pkg   = trust_pkg,
+                        -- And build the cached values
+                 mi_warn_fn     = mkIfaceWarnCache warns,
+                 mi_fix_fn      = mkIfaceFixCache fixities,
+                 mi_hash_fn     = mkIfaceHashCache decls })
+
 -- | The original names declared of a certain module that are exported
 type IfaceExport = AvailInfo
 
@@ -1527,6 +1635,24 @@ data Warnings
      --        a Name to its fixity declaration.
   deriving( Eq )
 
+instance Binary Warnings where
+    put_ bh NoWarnings     = putByte bh 0
+    put_ bh (WarnAll t) = do
+            putByte bh 1
+            put_ bh t
+    put_ bh (WarnSome ts) = do
+            putByte bh 2
+            put_ bh ts
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return NoWarnings
+              1 -> do aa <- get bh
+                      return (WarnAll aa)
+              _ -> do aa <- get bh
+                      return (WarnSome aa)
+
 -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
 mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt
 mkIfaceWarnCache NoWarnings  = \_ -> Nothing
@@ -1625,6 +1751,19 @@ data Dependencies
         -- Equality used only for old/new comparison in MkIface.addFingerprints
         -- See 'TcRnTypes.ImportAvails' for details on dependencies.
 
+instance Binary Dependencies where
+    put_ bh deps = do put_ bh (dep_mods deps)
+                      put_ bh (dep_pkgs deps)
+                      put_ bh (dep_orphs deps)
+                      put_ bh (dep_finsts deps)
+
+    get bh = do ms <- get bh
+                ps <- get bh
+                os <- get bh
+                fis <- get bh
+                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
+                               dep_finsts = fis })
+
 noDependencies :: Dependencies
 noDependencies = Deps [] [] [] []
 
@@ -1673,6 +1812,49 @@ data Usage
         --                      import M()
         -- And of course, for modules that aren't imported directly we don't
         -- depend on their export lists
+
+instance Binary Usage where
+    put_ bh usg@UsagePackageModule{} = do 
+        putByte bh 0
+        put_ bh (usg_mod usg)
+        put_ bh (usg_mod_hash usg)
+        put_ bh (usg_safe     usg)
+
+    put_ bh usg@UsageHomeModule{} = do 
+        putByte bh 1
+        put_ bh (usg_mod_name usg)
+        put_ bh (usg_mod_hash usg)
+        put_ bh (usg_exports  usg)
+        put_ bh (usg_entities usg)
+        put_ bh (usg_safe     usg)
+
+    put_ bh usg@UsageFile{} = do 
+        putByte bh 2
+        put_ bh (usg_file_path usg)
+        put_ bh (usg_mtime     usg)
+
+    get bh = do
+        h <- getByte bh
+        case h of
+          0 -> do
+            nm    <- get bh
+            mod   <- get bh
+            safe  <- get bh
+            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
+          1 -> do
+            nm    <- get bh
+            mod   <- get bh
+            exps  <- get bh
+            ents  <- get bh
+            safe  <- get bh
+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
+                     usg_exports = exps, usg_entities = ents, usg_safe = safe }
+          2 -> do
+            fp    <- get bh
+            mtime <- get bh
+            return UsageFile { usg_file_path = fp, usg_mtime = mtime }
+          i -> error ("Binary.get(Usage): " ++ show i)
+
 \end{code}
 
 
@@ -2060,6 +2242,21 @@ instance Outputable VectInfo where
              , ptext (sLit "parallel vars   :") <+> ppr (vectInfoParallelVars   info)
              , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info)
              ]
+
+instance Binary IfaceVectInfo where
+    put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        a5 <- get bh
+        return (IfaceVectInfo a1 a2 a3 a4 a5)
 \end{code}
 
 %************************************************************************
@@ -2111,6 +2308,10 @@ instance Outputable IfaceTrustInfo where
     ppr (TrustInfo Sf_Trustworthy)   = ptext $ sLit "trustworthy"
     ppr (TrustInfo Sf_Safe)          = ptext $ sLit "safe"
     ppr (TrustInfo Sf_SafeInferred)  = ptext $ sLit "safe-inferred"
+
+instance Binary IfaceTrustInfo where
+    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
+    get bh = getByte bh >>= (return . numToTrustInfo)
 \end{code}
 
 %************************************************************************
index 8d9c269..7e6959b 100644 (file)
@@ -29,6 +29,7 @@ module CostCentre (
        cmpCostCentre   -- used for removing dups in a list
     ) where
 
+import Binary
 import Var
 import Name
 import Module
@@ -294,4 +295,42 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
 
 costCentreSrcSpan :: CostCentre -> SrcSpan
 costCentreSrcSpan = cc_loc
+
+instance Binary IsCafCC where
+    put_ bh CafCC = do
+            putByte bh 0
+    put_ bh NotCafCC = do
+            putByte bh 1
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return CafCC
+              _ -> do return NotCafCC
+
+instance Binary CostCentre where
+    put_ bh (NormalCC aa ab ac _ad ae) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ae
+    put_ bh (AllCafsCC ae _af) = do
+            putByte bh 1
+            put_ bh ae
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      ab <- get bh
+                      ac <- get bh
+                      ae <- get bh
+                      return (NormalCC aa ab ac noSrcSpan ae)
+              _ -> do ae <- get bh
+                      return (AllCafsCC ae noSrcSpan)
+
+    -- We ignore the SrcSpans in CostCentres when we serialise them,
+    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
+    -- ok, because we only need the SrcSpan when declaring the
+    -- CostCentre in the original module, it is not used by importing
+    -- modules.
 \end{code}
index e1dec49..0c85667 100644 (file)
@@ -91,6 +91,7 @@ import CoAxiom
 import Var
 import VarEnv
 import VarSet
+import Binary
 import Maybes   ( orElse )
 import Name    ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan )
 import OccName         ( parenSymOcc )
@@ -170,6 +171,15 @@ data Coercion
 data LeftOrRight = CLeft | CRight 
                  deriving( Eq, Data.Data, Data.Typeable )
 
+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 }
+
 pickLR :: LeftOrRight -> (a,a) -> a
 pickLR CLeft  (l,_) = l
 pickLR CRight (_,r) = r
index e075777..d14c326 100644 (file)
@@ -784,3 +784,144 @@ instance Binary FunctionOrData where
           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 AlwaysActive = do
+            putByte bh 1
+    put_ bh (ActiveBefore aa) = do
+            putByte bh 2
+            put_ bh aa
+    put_ bh (ActiveAfter ab) = do
+            putByte bh 3
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return NeverActive
+              1 -> do return AlwaysActive
+              2 -> do aa <- get bh
+                      return (ActiveBefore aa)
+              _ -> do ab <- get bh
+                      return (ActiveAfter ab)
+
+instance Binary InlinePragma where
+    put_ bh (InlinePragma a b c d) = do
+            put_ bh a
+            put_ bh b
+            put_ bh c
+            put_ bh d
+
+    get bh = do
+           a <- get bh
+           b <- get bh
+           c <- get bh
+           d <- get bh
+           return (InlinePragma 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 EmptyInlineSpec = 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 EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
+instance Binary DefMethSpec where
+    put_ bh NoDM      = putByte bh 0
+    put_ bh VanillaDM = putByte bh 1
+    put_ bh GenericDM = putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return NoDM
+              1 -> return VanillaDM
+              _ -> return GenericDM
+
+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 OverlapFlag where
+    put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
+    put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
+    put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
+    get bh = do
+        h <- getByte bh
+        b <- get bh
+        case h of
+            0 -> return $ NoOverlap b
+            1 -> return $ OverlapOk b
+            2 -> return $ Incoherent b
+            _ -> panic ("get OverlapFlag " ++ show h)
+
+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 aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+          aa <- get bh
+          ab <- get bh
+          return (Fixity aa ab)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt w) = do
+            putByte bh 0
+            put_ bh w
+    put_ bh (DeprecatedTxt d) = do
+            putByte bh 1
+            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)
+