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