ghc/compiler/main/BinIface.hs

   1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   3 --
   4 --  (c) The University of Glasgow 2002
   5 --
   6 -- Binary interface file support.
   7
   8 module BinIface ( writeBinIface, readBinIface ) where
   9
  10 #include "HsVersions.h"
  11
  12 import HscTypes
  13 import BasicTypes
  14 import NewDemand
  15 import HsTypes
  16 import HsCore
  17 import HsDecls
  18 import HsBinds
  19 import HsPat            ( HsConDetails(..) )
  20 import TyCon
  21 import Class
  22 import VarEnv
  23 import CostCentre
  24 import RdrName          ( mkRdrUnqual, mkRdrQual )
  25 import Name             ( Name, nameOccName, nameModule_maybe )
  26 import NameEnv          ( NameEnv, lookupNameEnv, nameEnvElts )
  27 import Module           ( moduleName )
  28 import OccName          ( OccName )
  29 import RnHsSyn
  30 import DriverState      ( v_Build_tag )
  31 import CmdLineOpts      ( opt_IgnoreIfacePragmas, opt_HiVersion )
  32 import Panic
  33 import SrcLoc
  34 import Binary
  35
  36 import DATA_IOREF       ( readIORef )
  37 import EXCEPTION        ( throwDyn )
  38 import Monad            ( when )
  39
  40 #include "HsVersions.h"
  41
  42 -- ---------------------------------------------------------------------------
  43 -- We write out a ModIface, but read it in as a ParsedIface.
  44 -- There are some big differences, and some subtle ones.  We do most
  45 -- of the conversion on the way out, so there is minimal fuss when we
  46 -- read it back in again (see RnMonad.lhs)
  47
  48 -- The main difference is that all Names in a ModIface are RdrNames in
  49 -- a ParsedIface, so when writing out a Name in binary we make sure it
  50 -- is binary-compatible with a RdrName.
  51
  52 -- Other subtle differences:
  53 --      - pi_mod is a ModuleName, but mi_mod is a Module.  Hence we put
  54 --        Modules as ModuleNames.
  55 --      - pi_exports and pi_usages, Names have
  56 --        to be converted to OccNames.
  57 --      - pi_fixity is a NameEnv in ModIface,
  58 --        but a list of (Name,Fixity) pairs in ParsedIface.
  59 --      - versioning is totally different.
  60 --      - deprecations are different.
  61
  62 writeBinIface :: FilePath -> ModIface -> IO ()
  63 writeBinIface hi_path mod_iface
  64   = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
  65
  66 readBinIface :: FilePath -> IO ParsedIface
  67 readBinIface hi_path = getBinFileWithDict hi_path
  68
  69
  70 -- %*********************************************************
  71 -- %*                                                       *
  72 --              All the Binary instances
  73 -- %*                                                       *
  74 -- %*********************************************************
  75
  76 -- BasicTypes
  77 {-! for IPName derive: Binary !-}
  78 {-! for Fixity derive: Binary !-}
  79 {-! for FixityDirection derive: Binary !-}
  80 {-! for NewOrData derive: Binary !-}
  81 {-! for Boxity derive: Binary !-}
  82 {-! for StrictnessMark derive: Binary !-}
  83 {-! for Activation derive: Binary !-}
  84
  85 instance Binary Name where
  86   -- we must print these as RdrNames, because that's how they will be read in
  87   put_ bh name
  88    = case nameModule_maybe name of
  89        Just mod
  90           | this_mod == mod -> put_ bh (mkRdrUnqual occ)
  91           | otherwise       -> put_ bh (mkRdrQual (moduleName mod) occ)
  92        _                    -> put_ bh (mkRdrUnqual occ)
  93     where
  94       occ              = nameOccName name
  95       (this_mod,_,_,_) = getUserData bh
  96
  97   get bh = error "can't Binary.get a Name"
  98
  99 -- NewDemand
 100 {-! for Demand derive: Binary !-}
 101 {-! for Demands derive: Binary !-}
 102 {-! for DmdResult derive: Binary !-}
 103 {-! for StrictSig derive: Binary !-}
 104
 105 instance Binary DmdType where
 106         -- ignore DmdEnv when spitting out the DmdType
 107   put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
 108   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 109
 110 -- TyCon
 111 {-! for DataConDetails derive: Binary !-}
 112
 113 -- Class
 114 {-! for DefMeth derive: Binary !-}
 115
 116 -- HsTypes
 117 {-! for HsPred derive: Binary !-}
 118 {-! for HsType derive: Binary !-}
 119 {-! for HsTupCon derive: Binary !-}
 120 {-! for HsTyVarBndr derive: Binary !-}
 121
 122 -- HsCore
 123 {-! for UfExpr derive: Binary !-}
 124 {-! for UfConAlt derive: Binary !-}
 125 {-! for UfBinding derive: Binary !-}
 126 {-! for UfBinder derive: Binary !-}
 127 {-! for HsIdInfo derive: Binary !-}
 128 {-! for UfNote derive: Binary !-}
 129
 130 -- HsDecls
 131 {-! for ConDetails derive: Binary !-}
 132 {-! for BangType derive: Binary !-}
 133
 134 instance (Binary name) => Binary (TyClDecl name) where
 135     put_ bh (IfaceSig name ty idinfo _) = do
 136             putByte bh 0
 137             put_ bh name
 138             lazyPut bh ty
 139             lazyPut bh idinfo
 140     put_ bh (ForeignType ae af ag ah) =
 141         error "Binary.put_(TyClDecl): ForeignType"
 142     put_ bh (TyData ai aj ak al am _ (Just generics) _) = do
 143             putByte bh 2
 144             put_ bh ai
 145             put_ bh aj
 146             put_ bh ak
 147             put_ bh al
 148             put_ bh am
 149             -- ignore Derivs
 150             put_ bh generics -- Record whether generics needed or not
 151     put_ bh (TySynonym aq ar as _) = do
 152             putByte bh 3
 153             put_ bh aq
 154             put_ bh ar
 155             put_ bh as
 156     put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do
 157             putByte bh 4
 158             put_ bh ctxt
 159             put_ bh nm
 160             put_ bh tyvars
 161             put_ bh fds
 162             put_ bh sigs
 163                 -- ignore methods (there should be none)
 164                 -- ignore SrcLoc
 165     get bh = do
 166             h <- getByte bh
 167             case h of
 168               0 -> do
 169                     name <- get bh
 170                     ty <- lazyGet bh
 171                     idinfo <- lazyGet bh
 172                     let idinfo' | opt_IgnoreIfacePragmas = []
 173                                 | otherwise = idinfo
 174                     return (IfaceSig name ty idinfo' noSrcLoc)
 175               1 -> error "Binary.get(TyClDecl): ForeignType"
 176               2 -> do
 177                     n_or_d <- get bh
 178                     ctx    <- get bh
 179                     nm     <- get bh
 180                     tyvars <- get bh
 181                     cons   <- get bh
 182                     generics <- get bh
 183                     return (TyData n_or_d ctx nm tyvars cons
 184                                 Nothing (Just generics) noSrcLoc)
 185               3 -> do
 186                     aq <- get bh
 187                     ar <- get bh
 188                     as <- get bh
 189                     return (TySynonym aq ar as noSrcLoc)
 190               _ -> do
 191                     ctxt <- get bh
 192                     nm <- get bh
 193                     tyvars <- get bh
 194                     fds <- get bh
 195                     sigs <- get bh
 196                     return (ClassDecl ctxt nm tyvars fds sigs
 197                                       Nothing noSrcLoc)
 198
 199 instance (Binary name) => Binary (ConDecl name) where
 200     put_ bh (ConDecl aa ac ad ae _) = do
 201             put_ bh aa
 202             put_ bh ac
 203             put_ bh ad
 204             put_ bh ae
 205                 -- ignore SrcLoc
 206     get bh = do
 207           aa <- get bh
 208           ac <- get bh
 209           ad <- get bh
 210           ae <- get bh
 211           return (ConDecl aa ac ad ae noSrcLoc)
 212
 213 instance (Binary name) => Binary (InstDecl name) where
 214     put_ bh (InstDecl aa _ _ ad _) = do
 215             put_ bh aa
 216                 -- ignore MonoBinds
 217                 -- ignore Sigs
 218             put_ bh ad
 219                 -- ignore SrcLoc
 220     get bh = do
 221           aa <- get bh
 222           ad <- get bh
 223           return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
 224
 225 instance (Binary name) => Binary (RuleDecl name) where
 226     put_ bh (IfaceRule ag ah ai aj ak al _) = do
 227             put_ bh ag
 228             put_ bh ah
 229             put_ bh ai
 230             put_ bh aj
 231             put_ bh ak
 232             put_ bh al
 233                 -- ignore SrcLoc
 234     get bh = do     ag <- get bh
 235                     ah <- get bh
 236                     ai <- get bh
 237                     aj <- get bh
 238                     ak <- get bh
 239                     al <- get bh
 240                     return (IfaceRule ag ah ai aj ak al noSrcLoc)
 241
 242 instance (Binary name) => Binary (DeprecDecl name) where
 243     put_ bh (Deprecation aa ab _) = do
 244             put_ bh aa
 245             put_ bh ab
 246                 -- ignore SrcLoc
 247     get bh = do
 248           aa <- get bh
 249           ab <- get bh
 250           return (Deprecation aa ab noSrcLoc)
 251
 252 -- HsBinds
 253 instance Binary name => Binary (Sig name) where
 254    put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty
 255    get bh = do
 256         n <- get bh
 257         def <- get bh
 258         ty <- get bh
 259         return (ClassOpSig n def ty noSrcLoc)
 260
 261 -- CostCentre
 262 {-! for IsCafCC derive: Binary !-}
 263 {-! for IsDupdCC derive: Binary !-}
 264 {-! for CostCentre derive: Binary !-}
 265
 266
 267
 268 instance Binary ModIface where
 269   put_ bh iface =  do
 270         build_tag <- readIORef v_Build_tag
 271         put_ bh (show opt_HiVersion ++ build_tag)
 272         p <- put_ bh (mi_module iface)
 273         put_ bh (mi_package iface)
 274         put_ bh (vers_module (mi_version iface))
 275         put_ bh (mi_orphan iface)
 276         -- no: mi_boot
 277         lazyPut bh (map importVersionNameToOccName (mi_usages iface))
 278         put_ bh (vers_exports (mi_version iface),
 279                  map exportItemToRdrExportItem (mi_exports iface))
 280         put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
 281                         (vers_decls (mi_version iface)))
 282         -- no: mi_globals
 283         put_ bh (collectFixities (mi_fixities iface)
 284                                  (dcl_tycl (mi_decls iface)))
 285         put_ bh (dcl_insts (mi_decls iface))
 286         lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
 287         lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
 288
 289   -- Read in as a ParsedIface, not a ModIface.  See above.
 290   get bh = error "Binary.get: ModIface"
 291
 292 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
 293    -> [(Version, RenamedTyClDecl)]
 294 declsToVersionedDecls decls env
 295   = map add_vers decls
 296   where add_vers d =
 297            case lookupNameEnv env (tyClDeclName d) of
 298                 Nothing -> (initialVersion, d)
 299                 Just v  -> (v, d)
 300
 301
 302 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
 303 deprecsToIfaceDeprecs NoDeprecs = Nothing
 304 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
 305 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
 306
 307
 308 {-! for GenAvailInfo derive: Binary !-}
 309 {-! for WhatsImported derive: Binary !-}
 310
 311 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
 312 importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
 313 importVersionNameToOccName (mod, orphans, boot, what)
 314   = (mod, orphans, boot, fiddle_with what)
 315   where fiddle_with NothingAtAll = NothingAtAll
 316         fiddle_with (Everything v) = Everything v
 317         fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
 318           where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
 319
 320
 321 exportItemToRdrExportItem (mn, avails)
 322   = (mn, map availInfoToRdrAvailInfo avails)
 323
 324 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
 325 availInfoToRdrAvailInfo (Avail n)
 326    = Avail (nameOccName n)
 327 availInfoToRdrAvailInfo (AvailTC n ns)
 328   = AvailTC (nameOccName n) (map nameOccName ns)
 329
 330 -- ---------------------------------------------------------------------------
 331 -- Reading a binary interface into ParsedIface
 332
 333 instance Binary ParsedIface where
 334    put_ bh ParsedIface{
 335                  pi_mod = module_name,
 336                  pi_pkg = pkg_name,
 337                  pi_vers = module_ver,
 338                  pi_orphan = orphan,
 339                  pi_usages = usages,
 340                  pi_exports = exports,
 341                  pi_decls = tycl_decls,
 342                  pi_fixity = fixities,
 343                  pi_insts = insts,
 344                  pi_rules = rules,
 345                  pi_deprecs = deprecs } = do
 346         build_tag <- readIORef v_Build_tag
 347         put_ bh (show opt_HiVersion ++ build_tag)
 348         put_ bh module_name
 349         put_ bh pkg_name
 350         put_ bh module_ver
 351         put_ bh orphan
 352         lazyPut bh usages
 353         put_ bh exports
 354         put_ bh tycl_decls
 355         put_ bh fixities
 356         put_ bh insts
 357         lazyPut bh rules
 358         lazyPut bh deprecs
 359    get bh = do
 360         check_ver   <- get bh
 361         build_tag <- readIORef v_Build_tag
 362         let our_ver = show opt_HiVersion ++ build_tag
 363         when (check_ver /= our_ver) $
 364            -- use userError because this will be caught by readIface
 365            -- which will emit an error msg containing the iface module name.
 366            throwDyn (ProgramError (
 367                 "mismatched interface file versions: expected "
 368                 ++ our_ver ++ ", found " ++ check_ver))
 369         module_name <- get bh           -- same rep. as Module, so that's ok
 370         pkg_name    <- get bh
 371         module_ver  <- get bh
 372         orphan      <- get bh
 373         usages      <- {-# SCC "bin_usages" #-} lazyGet bh
 374         exports     <- {-# SCC "bin_exports" #-} get bh
 375         tycl_decls  <- {-# SCC "bin_tycldecls" #-} get bh
 376         fixities    <- {-# SCC "bin_fixities" #-} get bh
 377         insts       <- {-# SCC "bin_insts" #-} get bh
 378         rules       <- {-# SCC "bin_rules" #-} lazyGet bh
 379         deprecs     <- {-# SCC "bin_deprecs" #-} lazyGet bh
 380         return (ParsedIface {
 381                  pi_mod = module_name,
 382                  pi_pkg = pkg_name,
 383                  pi_vers = module_ver,
 384                  pi_orphan = orphan,
 385                  pi_usages = usages,
 386                  pi_exports = exports,
 387                  pi_decls = tycl_decls,
 388                  pi_fixity = fixities,
 389                  pi_insts = reverse insts,
 390                  pi_rules = rules,
 391                  pi_deprecs = deprecs })
 392
 393 -- ----------------------------------------------------------------------------
 394 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 395
 396 --  Imported from other files :-
 397
 398 instance (Binary name) => Binary (GenAvailInfo name) where
 399     put_ bh (Avail aa) = do
 400             putByte bh 0
 401             put_ bh aa
 402     put_ bh (AvailTC ab ac) = do
 403             putByte bh 1
 404             put_ bh ab
 405             put_ bh ac
 406     get bh = do
 407             h <- getByte bh
 408             case h of
 409               0 -> do aa <- get bh
 410                       return (Avail aa)
 411               _ -> do ab <- get bh
 412                       ac <- get bh
 413                       return (AvailTC ab ac)
 414
 415 instance (Binary name) => Binary (WhatsImported name) where
 416     put_ bh NothingAtAll = do
 417             putByte bh 0
 418     put_ bh (Everything aa) = do
 419             putByte bh 1
 420             put_ bh aa
 421     put_ bh (Specifically ab ac ad ae) = do
 422             putByte bh 2
 423             put_ bh ab
 424             put_ bh ac
 425             put_ bh ad
 426             put_ bh ae
 427     get bh = do
 428             h <- getByte bh
 429             case h of
 430               0 -> do return NothingAtAll
 431               1 -> do aa <- get bh
 432                       return (Everything aa)
 433               _ -> do ab <- get bh
 434                       ac <- get bh
 435                       ad <- get bh
 436                       ae <- get bh
 437                       return (Specifically ab ac ad ae)
 438
 439 instance Binary Activation where
 440     put_ bh NeverActive = do
 441             putByte bh 0
 442     put_ bh AlwaysActive = do
 443             putByte bh 1
 444     put_ bh (ActiveBefore aa) = do
 445             putByte bh 2
 446             put_ bh aa
 447     put_ bh (ActiveAfter ab) = do
 448             putByte bh 3
 449             put_ bh ab
 450     get bh = do
 451             h <- getByte bh
 452             case h of
 453               0 -> do return NeverActive
 454               1 -> do return AlwaysActive
 455               2 -> do aa <- get bh
 456                       return (ActiveBefore aa)
 457               _ -> do ab <- get bh
 458                       return (ActiveAfter ab)
 459
 460 instance Binary StrictnessMark where
 461     put_ bh MarkedUserStrict = do
 462             putByte bh 0
 463     put_ bh MarkedStrict = do
 464             putByte bh 1
 465     put_ bh MarkedUnboxed = do
 466             putByte bh 2
 467     put_ bh NotMarkedStrict = do
 468             putByte bh 3
 469     get bh = do
 470             h <- getByte bh
 471             case h of
 472               0 -> do return MarkedUserStrict
 473               1 -> do return MarkedStrict
 474               2 -> do return MarkedUnboxed
 475               _ -> do return NotMarkedStrict
 476
 477 instance Binary Boxity where
 478     put_ bh Boxed = do
 479             putByte bh 0
 480     put_ bh Unboxed = do
 481             putByte bh 1
 482     get bh = do
 483             h <- getByte bh
 484             case h of
 485               0 -> do return Boxed
 486               _ -> do return Unboxed
 487
 488 instance Binary NewOrData where
 489     put_ bh NewType = do
 490             putByte bh 0
 491     put_ bh DataType = do
 492             putByte bh 1
 493     get bh = do
 494             h <- getByte bh
 495             case h of
 496               0 -> do return NewType
 497               _ -> do return DataType
 498
 499 instance Binary FixityDirection where
 500     put_ bh InfixL = do
 501             putByte bh 0
 502     put_ bh InfixR = do
 503             putByte bh 1
 504     put_ bh InfixN = do
 505             putByte bh 2
 506     get bh = do
 507             h <- getByte bh
 508             case h of
 509               0 -> do return InfixL
 510               1 -> do return InfixR
 511               _ -> do return InfixN
 512
 513 instance Binary Fixity where
 514     put_ bh (Fixity aa ab) = do
 515             put_ bh aa
 516             put_ bh ab
 517     get bh = do
 518           aa <- get bh
 519           ab <- get bh
 520           return (Fixity aa ab)
 521
 522 instance (Binary name) => Binary (FixitySig name) where
 523     put_ bh (FixitySig aa ab _) = do
 524             put_ bh aa
 525             put_ bh ab
 526     get bh = do
 527           aa <- get bh
 528           ab <- get bh
 529           return (FixitySig aa ab noSrcLoc)
 530
 531 instance (Binary name) => Binary (IPName name) where
 532     put_ bh (Dupable aa) = do
 533             putByte bh 0
 534             put_ bh aa
 535     put_ bh (Linear ab) = do
 536             putByte bh 1
 537             put_ bh ab
 538     get bh = do
 539             h <- getByte bh
 540             case h of
 541               0 -> do aa <- get bh
 542                       return (Dupable aa)
 543               _ -> do ab <- get bh
 544                       return (Linear ab)
 545
 546 instance Binary Demand where
 547     put_ bh Top = do
 548             putByte bh 0
 549     put_ bh Abs = do
 550             putByte bh 1
 551     put_ bh (Call aa) = do
 552             putByte bh 2
 553             put_ bh aa
 554     put_ bh (Eval ab) = do
 555             putByte bh 3
 556             put_ bh ab
 557     put_ bh (Defer ac) = do
 558             putByte bh 4
 559             put_ bh ac
 560     put_ bh (Box ad) = do
 561             putByte bh 5
 562             put_ bh ad
 563     put_ bh Bot = do
 564             putByte bh 6
 565     get bh = do
 566             h <- getByte bh
 567             case h of
 568               0 -> do return Top
 569               1 -> do return Abs
 570               2 -> do aa <- get bh
 571                       return (Call aa)
 572               3 -> do ab <- get bh
 573                       return (Eval ab)
 574               4 -> do ac <- get bh
 575                       return (Defer ac)
 576               5 -> do ad <- get bh
 577                       return (Box ad)
 578               _ -> do return Bot
 579
 580 instance Binary Demands where
 581     put_ bh (Poly aa) = do
 582             putByte bh 0
 583             put_ bh aa
 584     put_ bh (Prod ab) = do
 585             putByte bh 1
 586             put_ bh ab
 587     get bh = do
 588             h <- getByte bh
 589             case h of
 590               0 -> do aa <- get bh
 591                       return (Poly aa)
 592               _ -> do ab <- get bh
 593                       return (Prod ab)
 594
 595 instance Binary DmdResult where
 596     put_ bh TopRes = do
 597             putByte bh 0
 598     put_ bh RetCPR = do
 599             putByte bh 1
 600     put_ bh BotRes = do
 601             putByte bh 2
 602     get bh = do
 603             h <- getByte bh
 604             case h of
 605               0 -> do return TopRes
 606               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 607                                         -- The wrapper was generated for CPR in
 608                                         -- the imported module!
 609               _ -> do return BotRes
 610
 611 instance Binary StrictSig where
 612     put_ bh (StrictSig aa) = do
 613             put_ bh aa
 614     get bh = do
 615           aa <- get bh
 616           return (StrictSig aa)
 617
 618 instance (Binary name) => Binary (HsTyVarBndr name) where
 619     put_ bh (UserTyVar aa) = do
 620             putByte bh 0
 621             put_ bh aa
 622     put_ bh (IfaceTyVar ab ac) = do
 623             putByte bh 1
 624             put_ bh ab
 625             put_ bh ac
 626     get bh = do
 627             h <- getByte bh
 628             case h of
 629               0 -> do aa <- get bh
 630                       return (UserTyVar aa)
 631               _ -> do ab <- get bh
 632                       ac <- get bh
 633                       return (IfaceTyVar ab ac)
 634
 635 instance Binary HsTupCon where
 636     put_ bh (HsTupCon ab ac) = do
 637             put_ bh ab
 638             put_ bh ac
 639     get bh = do
 640           ab <- get bh
 641           ac <- get bh
 642           return (HsTupCon ab ac)
 643
 644 instance (Binary name) => Binary (HsTyOp name) where
 645     put_ bh HsArrow    = putByte bh 0
 646     put_ bh (HsTyOp n) = do putByte bh 1
 647                             put_ bh n
 648
 649     get bh = do h <- getByte bh
 650                 case h of
 651                   0 -> return HsArrow
 652                   1 -> do a <- get bh
 653                           return (HsTyOp a)
 654
 655 instance (Binary name) => Binary (HsType name) where
 656     put_ bh (HsForAllTy aa ab ac) = do
 657             putByte bh 0
 658             put_ bh aa
 659             put_ bh ab
 660             put_ bh ac
 661     put_ bh (HsTyVar ad) = do
 662             putByte bh 1
 663             put_ bh ad
 664     put_ bh (HsAppTy ae af) = do
 665             putByte bh 2
 666             put_ bh ae
 667             put_ bh af
 668     put_ bh (HsFunTy ag ah) = do
 669             putByte bh 3
 670             put_ bh ag
 671             put_ bh ah
 672     put_ bh (HsListTy ai) = do
 673             putByte bh 4
 674             put_ bh ai
 675     put_ bh (HsPArrTy aj) = do
 676             putByte bh 5
 677             put_ bh aj
 678     put_ bh (HsTupleTy ak al) = do
 679             putByte bh 6
 680             put_ bh ak
 681             put_ bh al
 682     put_ bh (HsOpTy am an ao) = do
 683             putByte bh 7
 684             put_ bh am
 685             put_ bh an
 686             put_ bh ao
 687     put_ bh (HsNumTy ap) = do
 688             putByte bh 8
 689             put_ bh ap
 690     put_ bh (HsPredTy aq) = do
 691             putByte bh 9
 692             put_ bh aq
 693     put_ bh (HsKindSig ar as) = do
 694             putByte bh 10
 695             put_ bh ar
 696             put_ bh as
 697     get bh = do
 698             h <- getByte bh
 699             case h of
 700               0 -> do aa <- get bh
 701                       ab <- get bh
 702                       ac <- get bh
 703                       return (HsForAllTy aa ab ac)
 704               1 -> do ad <- get bh
 705                       return (HsTyVar ad)
 706               2 -> do ae <- get bh
 707                       af <- get bh
 708                       return (HsAppTy ae af)
 709               3 -> do ag <- get bh
 710                       ah <- get bh
 711                       return (HsFunTy ag ah)
 712               4 -> do ai <- get bh
 713                       return (HsListTy ai)
 714               5 -> do aj <- get bh
 715                       return (HsPArrTy aj)
 716               6 -> do ak <- get bh
 717                       al <- get bh
 718                       return (HsTupleTy ak al)
 719               7 -> do am <- get bh
 720                       an <- get bh
 721                       ao <- get bh
 722                       return (HsOpTy am an ao)
 723               8 -> do ap <- get bh
 724                       return (HsNumTy ap)
 725               9 -> do aq <- get bh
 726                       return (HsPredTy aq)
 727               _ -> do ar <- get bh
 728                       as <- get bh
 729                       return (HsKindSig ar as)
 730
 731 instance (Binary name) => Binary (HsPred name) where
 732     put_ bh (HsClassP aa ab) = do
 733             putByte bh 0
 734             put_ bh aa
 735             put_ bh ab
 736     put_ bh (HsIParam ac ad) = do
 737             putByte bh 1
 738             put_ bh ac
 739             put_ bh ad
 740     get bh = do
 741             h <- getByte bh
 742             case h of
 743               0 -> do aa <- get bh
 744                       ab <- get bh
 745                       return (HsClassP aa ab)
 746               _ -> do ac <- get bh
 747                       ad <- get bh
 748                       return (HsIParam ac ad)
 749
 750 instance (Binary name) => Binary (UfExpr name) where
 751     put_ bh (UfVar aa) = do
 752             putByte bh 0
 753             put_ bh aa
 754     put_ bh (UfType ab) = do
 755             putByte bh 1
 756             put_ bh ab
 757     put_ bh (UfTuple ac ad) = do
 758             putByte bh 2
 759             put_ bh ac
 760             put_ bh ad
 761     put_ bh (UfLam ae af) = do
 762             putByte bh 3
 763             put_ bh ae
 764             put_ bh af
 765     put_ bh (UfApp ag ah) = do
 766             putByte bh 4
 767             put_ bh ag
 768             put_ bh ah
 769     put_ bh (UfCase ai aj ak) = do
 770             putByte bh 5
 771             put_ bh ai
 772             put_ bh aj
 773             put_ bh ak
 774     put_ bh (UfLet al am) = do
 775             putByte bh 6
 776             put_ bh al
 777             put_ bh am
 778     put_ bh (UfNote an ao) = do
 779             putByte bh 7
 780             put_ bh an
 781             put_ bh ao
 782     put_ bh (UfLit ap) = do
 783             putByte bh 8
 784             put_ bh ap
 785     put_ bh (UfLitLit aq ar) = do
 786             putByte bh 9
 787             put_ bh aq
 788             put_ bh ar
 789     put_ bh (UfFCall as at) = do
 790             putByte bh 10
 791             put_ bh as
 792             put_ bh at
 793     get bh = do
 794             h <- getByte bh
 795             case h of
 796               0 -> do aa <- get bh
 797                       return (UfVar aa)
 798               1 -> do ab <- get bh
 799                       return (UfType ab)
 800               2 -> do ac <- get bh
 801                       ad <- get bh
 802                       return (UfTuple ac ad)
 803               3 -> do ae <- get bh
 804                       af <- get bh
 805                       return (UfLam ae af)
 806               4 -> do ag <- get bh
 807                       ah <- get bh
 808                       return (UfApp ag ah)
 809               5 -> do ai <- get bh
 810                       aj <- get bh
 811                       ak <- get bh
 812                       return (UfCase ai aj ak)
 813               6 -> do al <- get bh
 814                       am <- get bh
 815                       return (UfLet al am)
 816               7 -> do an <- get bh
 817                       ao <- get bh
 818                       return (UfNote an ao)
 819               8 -> do ap <- get bh
 820                       return (UfLit ap)
 821               9 -> do aq <- get bh
 822                       ar <- get bh
 823                       return (UfLitLit aq ar)
 824               _ -> do as <- get bh
 825                       at <- get bh
 826                       return (UfFCall as at)
 827
 828 instance (Binary name) => Binary (UfConAlt name) where
 829     put_ bh UfDefault = do
 830             putByte bh 0
 831     put_ bh (UfDataAlt aa) = do
 832             putByte bh 1
 833             put_ bh aa
 834     put_ bh (UfTupleAlt ab) = do
 835             putByte bh 2
 836             put_ bh ab
 837     put_ bh (UfLitAlt ac) = do
 838             putByte bh 3
 839             put_ bh ac
 840     put_ bh (UfLitLitAlt ad ae) = do
 841             putByte bh 4
 842             put_ bh ad
 843             put_ bh ae
 844     get bh = do
 845             h <- getByte bh
 846             case h of
 847               0 -> do return UfDefault
 848               1 -> do aa <- get bh
 849                       return (UfDataAlt aa)
 850               2 -> do ab <- get bh
 851                       return (UfTupleAlt ab)
 852               3 -> do ac <- get bh
 853                       return (UfLitAlt ac)
 854               _ -> do ad <- get bh
 855                       ae <- get bh
 856                       return (UfLitLitAlt ad ae)
 857
 858 instance (Binary name) => Binary (UfBinding name) where
 859     put_ bh (UfNonRec aa ab) = do
 860             putByte bh 0
 861             put_ bh aa
 862             put_ bh ab
 863     put_ bh (UfRec ac) = do
 864             putByte bh 1
 865             put_ bh ac
 866     get bh = do
 867             h <- getByte bh
 868             case h of
 869               0 -> do aa <- get bh
 870                       ab <- get bh
 871                       return (UfNonRec aa ab)
 872               _ -> do ac <- get bh
 873                       return (UfRec ac)
 874
 875 instance (Binary name) => Binary (UfBinder name) where
 876     put_ bh (UfValBinder aa ab) = do
 877             putByte bh 0
 878             put_ bh aa
 879             put_ bh ab
 880     put_ bh (UfTyBinder ac ad) = do
 881             putByte bh 1
 882             put_ bh ac
 883             put_ bh ad
 884     get bh = do
 885             h <- getByte bh
 886             case h of
 887               0 -> do aa <- get bh
 888                       ab <- get bh
 889                       return (UfValBinder aa ab)
 890               _ -> do ac <- get bh
 891                       ad <- get bh
 892                       return (UfTyBinder ac ad)
 893
 894 instance (Binary name) => Binary (HsIdInfo name) where
 895     put_ bh (HsArity aa) = do
 896             putByte bh 0
 897             put_ bh aa
 898     put_ bh (HsStrictness ab) = do
 899             putByte bh 1
 900             put_ bh ab
 901     put_ bh (HsUnfold ac ad) = do
 902             putByte bh 2
 903             put_ bh ac
 904             put_ bh ad
 905     put_ bh HsNoCafRefs = do
 906             putByte bh 3
 907     put_ bh (HsWorker ae af) = do
 908             putByte bh 4
 909             put_ bh ae
 910             put_ bh af
 911     get bh = do
 912             h <- getByte bh
 913             case h of
 914               0 -> do aa <- get bh
 915                       return (HsArity aa)
 916               1 -> do ab <- get bh
 917                       return (HsStrictness ab)
 918               2 -> do ac <- get bh
 919                       ad <- get bh
 920                       return (HsUnfold ac ad)
 921               3 -> do return HsNoCafRefs
 922               _ -> do ae <- get bh
 923                       af <- get bh
 924                       return (HsWorker ae af)
 925
 926 instance (Binary name) => Binary (UfNote name) where
 927     put_ bh (UfSCC aa) = do
 928             putByte bh 0
 929             put_ bh aa
 930     put_ bh (UfCoerce ab) = do
 931             putByte bh 1
 932             put_ bh ab
 933     put_ bh UfInlineCall = do
 934             putByte bh 2
 935     put_ bh UfInlineMe = do
 936             putByte bh 3
 937     get bh = do
 938             h <- getByte bh
 939             case h of
 940               0 -> do aa <- get bh
 941                       return (UfSCC aa)
 942               1 -> do ab <- get bh
 943                       return (UfCoerce ab)
 944               2 -> do return UfInlineCall
 945               _ -> do return UfInlineMe
 946
 947 instance (Binary name) => Binary (BangType name) where
 948     put_ bh (BangType aa ab) = do
 949             put_ bh aa
 950             put_ bh ab
 951     get bh = do
 952           aa <- get bh
 953           ab <- get bh
 954           return (BangType aa ab)
 955
 956 instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
 957     put_ bh (PrefixCon aa) = do
 958             putByte bh 0
 959             put_ bh aa
 960     put_ bh (InfixCon ab ac) = do
 961             putByte bh 1
 962             put_ bh ab
 963             put_ bh ac
 964     put_ bh (RecCon ad) = do
 965             putByte bh 2
 966             put_ bh ad
 967     get bh = do
 968             h <- getByte bh
 969             case h of
 970               0 -> do aa <- get bh
 971                       return (PrefixCon aa)
 972               1 -> do ab <- get bh
 973                       ac <- get bh
 974                       return (InfixCon ab ac)
 975               _ -> do ad <- get bh
 976                       return (RecCon ad)
 977
 978 instance (Binary datacon) => Binary (DataConDetails datacon) where
 979     put_ bh (DataCons aa) = do
 980             putByte bh 0
 981             put_ bh aa
 982     put_ bh Unknown = do
 983             putByte bh 1
 984     put_ bh (HasCons ab) = do
 985             putByte bh 2
 986             put_ bh ab
 987     get bh = do
 988             h <- getByte bh
 989             case h of
 990               0 -> do aa <- get bh
 991                       return (DataCons aa)
 992               1 -> do return Unknown
 993               _ -> do ab <- get bh
 994                       return (HasCons ab)
 995
 996 instance (Binary id) => Binary (DefMeth id) where
 997     put_ bh NoDefMeth = do
 998             putByte bh 0
 999     put_ bh (DefMeth aa) = do
1000             putByte bh 1
1001             put_ bh aa
1002     put_ bh GenDefMeth = do
1003             putByte bh 2
1004     get bh = do
1005             h <- getByte bh
1006             case h of
1007               0 -> do return NoDefMeth
1008               1 -> do aa <- get bh
1009                       return (DefMeth aa)
1010               _ -> do return GenDefMeth
1011
1012 instance Binary IsCafCC where
1013     put_ bh CafCC = do
1014             putByte bh 0
1015     put_ bh NotCafCC = do
1016             putByte bh 1
1017     get bh = do
1018             h <- getByte bh
1019             case h of
1020               0 -> do return CafCC
1021               _ -> do return NotCafCC
1022
1023 instance Binary IsDupdCC where
1024     put_ bh OriginalCC = do
1025             putByte bh 0
1026     put_ bh DupdCC = do
1027             putByte bh 1
1028     get bh = do
1029             h <- getByte bh
1030             case h of
1031               0 -> do return OriginalCC
1032               _ -> do return DupdCC
1033
1034 instance Binary CostCentre where
1035     put_ bh NoCostCentre = do
1036             putByte bh 0
1037     put_ bh (NormalCC aa ab ac ad) = do
1038             putByte bh 1
1039             put_ bh aa
1040             put_ bh ab
1041             put_ bh ac
1042             put_ bh ad
1043     put_ bh (AllCafsCC ae) = do
1044             putByte bh 2
1045             put_ bh ae
1046     get bh = do
1047             h <- getByte bh
1048             case h of
1049               0 -> do return NoCostCentre
1050               1 -> do aa <- get bh
1051                       ab <- get bh
1052                       ac <- get bh
1053                       ad <- get bh
1054                       return (NormalCC aa ab ac ad)
1055               _ -> do ae <- get bh
1056                       return (AllCafsCC ae)