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 (moduleName (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 (mi_deps iface)
 278         lazyPut bh (map usageToOccName (mi_usages iface))
 279         put_ bh (vers_exports (mi_version iface),
 280                  map exportItemToRdrExportItem (mi_exports iface))
 281         put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
 282                         (vers_decls (mi_version iface)))
 283         -- no: mi_globals
 284         put_ bh (collectFixities (mi_fixities iface)
 285                                  (dcl_tycl (mi_decls iface)))
 286         put_ bh (dcl_insts (mi_decls iface))
 287         lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
 288         lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
 289
 290   -- Read in as a ParsedIface, not a ModIface.  See above.
 291   get bh = error "Binary.get: ModIface"
 292
 293 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
 294    -> [(Version, RenamedTyClDecl)]
 295 declsToVersionedDecls decls env
 296   = map add_vers decls
 297   where add_vers d =
 298            case lookupNameEnv env (tyClDeclName d) of
 299                 Nothing -> (initialVersion, d)
 300                 Just v  -> (v, d)
 301
 302
 303 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
 304 deprecsToIfaceDeprecs NoDeprecs = Nothing
 305 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
 306 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
 307
 308
 309 {-! for GenAvailInfo derive: Binary !-}
 310 {-! for WhatsImported derive: Binary !-}
 311
 312 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
 313 usageToOccName :: Usage Name -> Usage OccName
 314 usageToOccName usg
 315   = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] }
 316
 317 exportItemToRdrExportItem (mn, avails)
 318   = (mn, map availInfoToRdrAvailInfo avails)
 319
 320 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
 321 availInfoToRdrAvailInfo (Avail n)
 322    = Avail (nameOccName n)
 323 availInfoToRdrAvailInfo (AvailTC n ns)
 324   = AvailTC (nameOccName n) (map nameOccName ns)
 325
 326 -- ---------------------------------------------------------------------------
 327 -- Reading a binary interface into ParsedIface
 328
 329 instance Binary ParsedIface where
 330    put_ bh ParsedIface{
 331                  pi_mod = module_name,
 332                  pi_pkg = pkg_name,
 333                  pi_vers = module_ver,
 334                  pi_orphan = orphan,
 335                  pi_usages = usages,
 336                  pi_exports = exports,
 337                  pi_decls = tycl_decls,
 338                  pi_fixity = fixities,
 339                  pi_insts = insts,
 340                  pi_rules = rules,
 341                  pi_deprecs = deprecs } = do
 342         build_tag <- readIORef v_Build_tag
 343         put_ bh (show opt_HiVersion ++ build_tag)
 344         put_ bh module_name
 345         put_ bh pkg_name
 346         put_ bh module_ver
 347         put_ bh orphan
 348         lazyPut bh usages
 349         put_ bh exports
 350         put_ bh tycl_decls
 351         put_ bh fixities
 352         put_ bh insts
 353         lazyPut bh rules
 354         lazyPut bh deprecs
 355    get bh = do
 356         check_ver   <- get bh
 357         build_tag <- readIORef v_Build_tag
 358         let our_ver = show opt_HiVersion ++ build_tag
 359         when (check_ver /= our_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 -- ----------------------------------------------------------------------------
 392 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 393
 394 --  Imported from other files :-
 395
 396 instance Binary Dependencies where
 397     put_ bh deps = do put_ bh (dep_mods deps)
 398                       put_ bh (dep_pkgs deps)
 399                       put_ bh (dep_orphs deps)
 400
 401     get bh = do ms <- get bh
 402                 ps <- get bh
 403                 os <- get bh
 404                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
 405
 406 instance (Binary name) => Binary (GenAvailInfo name) where
 407     put_ bh (Avail aa) = do
 408             putByte bh 0
 409             put_ bh aa
 410     put_ bh (AvailTC ab ac) = do
 411             putByte bh 1
 412             put_ bh ab
 413             put_ bh ac
 414     get bh = do
 415             h <- getByte bh
 416             case h of
 417               0 -> do aa <- get bh
 418                       return (Avail aa)
 419               _ -> do ab <- get bh
 420                       ac <- get bh
 421                       return (AvailTC ab ac)
 422
 423 instance (Binary name) => Binary (Usage name) where
 424     put_ bh usg = do
 425         put_ bh (usg_name     usg)
 426         put_ bh (usg_mod      usg)
 427         put_ bh (usg_exports  usg)
 428         put_ bh (usg_entities usg)
 429         put_ bh (usg_rules    usg)
 430
 431     get bh = do
 432         nm    <- get bh
 433         mod   <- get bh
 434         exps  <- get bh
 435         ents  <- get bh
 436         rules <- get bh
 437         return (Usage { usg_name = nm, usg_mod = mod,
 438                         usg_exports = exps, usg_entities = ents,
 439                         usg_rules = rules })
 440
 441 instance Binary Activation where
 442     put_ bh NeverActive = do
 443             putByte bh 0
 444     put_ bh AlwaysActive = do
 445             putByte bh 1
 446     put_ bh (ActiveBefore aa) = do
 447             putByte bh 2
 448             put_ bh aa
 449     put_ bh (ActiveAfter ab) = do
 450             putByte bh 3
 451             put_ bh ab
 452     get bh = do
 453             h <- getByte bh
 454             case h of
 455               0 -> do return NeverActive
 456               1 -> do return AlwaysActive
 457               2 -> do aa <- get bh
 458                       return (ActiveBefore aa)
 459               _ -> do ab <- get bh
 460                       return (ActiveAfter ab)
 461
 462 instance Binary StrictnessMark where
 463     put_ bh MarkedUserStrict = do
 464             putByte bh 0
 465     put_ bh MarkedStrict = do
 466             putByte bh 1
 467     put_ bh MarkedUnboxed = do
 468             putByte bh 2
 469     put_ bh NotMarkedStrict = do
 470             putByte bh 3
 471     get bh = do
 472             h <- getByte bh
 473             case h of
 474               0 -> do return MarkedUserStrict
 475               1 -> do return MarkedStrict
 476               2 -> do return MarkedUnboxed
 477               _ -> do return NotMarkedStrict
 478
 479 instance Binary Boxity where
 480     put_ bh Boxed = do
 481             putByte bh 0
 482     put_ bh Unboxed = do
 483             putByte bh 1
 484     get bh = do
 485             h <- getByte bh
 486             case h of
 487               0 -> do return Boxed
 488               _ -> do return Unboxed
 489
 490 instance Binary NewOrData where
 491     put_ bh NewType = do
 492             putByte bh 0
 493     put_ bh DataType = do
 494             putByte bh 1
 495     get bh = do
 496             h <- getByte bh
 497             case h of
 498               0 -> do return NewType
 499               _ -> do return DataType
 500
 501 instance Binary FixityDirection where
 502     put_ bh InfixL = do
 503             putByte bh 0
 504     put_ bh InfixR = do
 505             putByte bh 1
 506     put_ bh InfixN = do
 507             putByte bh 2
 508     get bh = do
 509             h <- getByte bh
 510             case h of
 511               0 -> do return InfixL
 512               1 -> do return InfixR
 513               _ -> do return InfixN
 514
 515 instance Binary Fixity where
 516     put_ bh (Fixity aa ab) = do
 517             put_ bh aa
 518             put_ bh ab
 519     get bh = do
 520           aa <- get bh
 521           ab <- get bh
 522           return (Fixity aa ab)
 523
 524 instance (Binary name) => Binary (FixitySig name) where
 525     put_ bh (FixitySig aa ab _) = do
 526             put_ bh aa
 527             put_ bh ab
 528     get bh = do
 529           aa <- get bh
 530           ab <- get bh
 531           return (FixitySig aa ab noSrcLoc)
 532
 533 instance (Binary name) => Binary (IPName name) where
 534     put_ bh (Dupable aa) = do
 535             putByte bh 0
 536             put_ bh aa
 537     put_ bh (Linear ab) = do
 538             putByte bh 1
 539             put_ bh ab
 540     get bh = do
 541             h <- getByte bh
 542             case h of
 543               0 -> do aa <- get bh
 544                       return (Dupable aa)
 545               _ -> do ab <- get bh
 546                       return (Linear ab)
 547
 548 instance Binary Demand where
 549     put_ bh Top = do
 550             putByte bh 0
 551     put_ bh Abs = do
 552             putByte bh 1
 553     put_ bh (Call aa) = do
 554             putByte bh 2
 555             put_ bh aa
 556     put_ bh (Eval ab) = do
 557             putByte bh 3
 558             put_ bh ab
 559     put_ bh (Defer ac) = do
 560             putByte bh 4
 561             put_ bh ac
 562     put_ bh (Box ad) = do
 563             putByte bh 5
 564             put_ bh ad
 565     put_ bh Bot = do
 566             putByte bh 6
 567     get bh = do
 568             h <- getByte bh
 569             case h of
 570               0 -> do return Top
 571               1 -> do return Abs
 572               2 -> do aa <- get bh
 573                       return (Call aa)
 574               3 -> do ab <- get bh
 575                       return (Eval ab)
 576               4 -> do ac <- get bh
 577                       return (Defer ac)
 578               5 -> do ad <- get bh
 579                       return (Box ad)
 580               _ -> do return Bot
 581
 582 instance Binary Demands where
 583     put_ bh (Poly aa) = do
 584             putByte bh 0
 585             put_ bh aa
 586     put_ bh (Prod ab) = do
 587             putByte bh 1
 588             put_ bh ab
 589     get bh = do
 590             h <- getByte bh
 591             case h of
 592               0 -> do aa <- get bh
 593                       return (Poly aa)
 594               _ -> do ab <- get bh
 595                       return (Prod ab)
 596
 597 instance Binary DmdResult where
 598     put_ bh TopRes = do
 599             putByte bh 0
 600     put_ bh RetCPR = do
 601             putByte bh 1
 602     put_ bh BotRes = do
 603             putByte bh 2
 604     get bh = do
 605             h <- getByte bh
 606             case h of
 607               0 -> do return TopRes
 608               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 609                                         -- The wrapper was generated for CPR in
 610                                         -- the imported module!
 611               _ -> do return BotRes
 612
 613 instance Binary StrictSig where
 614     put_ bh (StrictSig aa) = do
 615             put_ bh aa
 616     get bh = do
 617           aa <- get bh
 618           return (StrictSig aa)
 619
 620 instance (Binary name) => Binary (HsTyVarBndr name) where
 621     put_ bh (UserTyVar aa) = do
 622             putByte bh 0
 623             put_ bh aa
 624     put_ bh (IfaceTyVar ab ac) = do
 625             putByte bh 1
 626             put_ bh ab
 627             put_ bh ac
 628     get bh = do
 629             h <- getByte bh
 630             case h of
 631               0 -> do aa <- get bh
 632                       return (UserTyVar aa)
 633               _ -> do ab <- get bh
 634                       ac <- get bh
 635                       return (IfaceTyVar ab ac)
 636
 637 instance Binary HsTupCon where
 638     put_ bh (HsTupCon ab ac) = do
 639             put_ bh ab
 640             put_ bh ac
 641     get bh = do
 642           ab <- get bh
 643           ac <- get bh
 644           return (HsTupCon ab ac)
 645
 646 instance (Binary name) => Binary (HsTyOp name) where
 647     put_ bh HsArrow    = putByte bh 0
 648     put_ bh (HsTyOp n) = do putByte bh 1
 649                             put_ bh n
 650
 651     get bh = do h <- getByte bh
 652                 case h of
 653                   0 -> return HsArrow
 654                   1 -> do a <- get bh
 655                           return (HsTyOp a)
 656
 657 instance (Binary name) => Binary (HsType name) where
 658     put_ bh (HsForAllTy aa ab ac) = do
 659             putByte bh 0
 660             put_ bh aa
 661             put_ bh ab
 662             put_ bh ac
 663     put_ bh (HsTyVar ad) = do
 664             putByte bh 1
 665             put_ bh ad
 666     put_ bh (HsAppTy ae af) = do
 667             putByte bh 2
 668             put_ bh ae
 669             put_ bh af
 670     put_ bh (HsFunTy ag ah) = do
 671             putByte bh 3
 672             put_ bh ag
 673             put_ bh ah
 674     put_ bh (HsListTy ai) = do
 675             putByte bh 4
 676             put_ bh ai
 677     put_ bh (HsPArrTy aj) = do
 678             putByte bh 5
 679             put_ bh aj
 680     put_ bh (HsTupleTy ak al) = do
 681             putByte bh 6
 682             put_ bh ak
 683             put_ bh al
 684     put_ bh (HsOpTy am an ao) = do
 685             putByte bh 7
 686             put_ bh am
 687             put_ bh an
 688             put_ bh ao
 689     put_ bh (HsNumTy ap) = do
 690             putByte bh 8
 691             put_ bh ap
 692     put_ bh (HsPredTy aq) = do
 693             putByte bh 9
 694             put_ bh aq
 695     put_ bh (HsKindSig ar as) = do
 696             putByte bh 10
 697             put_ bh ar
 698             put_ bh as
 699     get bh = do
 700             h <- getByte bh
 701             case h of
 702               0 -> do aa <- get bh
 703                       ab <- get bh
 704                       ac <- get bh
 705                       return (HsForAllTy aa ab ac)
 706               1 -> do ad <- get bh
 707                       return (HsTyVar ad)
 708               2 -> do ae <- get bh
 709                       af <- get bh
 710                       return (HsAppTy ae af)
 711               3 -> do ag <- get bh
 712                       ah <- get bh
 713                       return (HsFunTy ag ah)
 714               4 -> do ai <- get bh
 715                       return (HsListTy ai)
 716               5 -> do aj <- get bh
 717                       return (HsPArrTy aj)
 718               6 -> do ak <- get bh
 719                       al <- get bh
 720                       return (HsTupleTy ak al)
 721               7 -> do am <- get bh
 722                       an <- get bh
 723                       ao <- get bh
 724                       return (HsOpTy am an ao)
 725               8 -> do ap <- get bh
 726                       return (HsNumTy ap)
 727               9 -> do aq <- get bh
 728                       return (HsPredTy aq)
 729               _ -> do ar <- get bh
 730                       as <- get bh
 731                       return (HsKindSig ar as)
 732
 733 instance (Binary name) => Binary (HsPred name) where
 734     put_ bh (HsClassP aa ab) = do
 735             putByte bh 0
 736             put_ bh aa
 737             put_ bh ab
 738     put_ bh (HsIParam ac ad) = do
 739             putByte bh 1
 740             put_ bh ac
 741             put_ bh ad
 742     get bh = do
 743             h <- getByte bh
 744             case h of
 745               0 -> do aa <- get bh
 746                       ab <- get bh
 747                       return (HsClassP aa ab)
 748               _ -> do ac <- get bh
 749                       ad <- get bh
 750                       return (HsIParam ac ad)
 751
 752 instance (Binary name) => Binary (UfExpr name) where
 753     put_ bh (UfVar aa) = do
 754             putByte bh 0
 755             put_ bh aa
 756     put_ bh (UfType ab) = do
 757             putByte bh 1
 758             put_ bh ab
 759     put_ bh (UfTuple ac ad) = do
 760             putByte bh 2
 761             put_ bh ac
 762             put_ bh ad
 763     put_ bh (UfLam ae af) = do
 764             putByte bh 3
 765             put_ bh ae
 766             put_ bh af
 767     put_ bh (UfApp ag ah) = do
 768             putByte bh 4
 769             put_ bh ag
 770             put_ bh ah
 771     put_ bh (UfCase ai aj ak) = do
 772             putByte bh 5
 773             put_ bh ai
 774             put_ bh aj
 775             put_ bh ak
 776     put_ bh (UfLet al am) = do
 777             putByte bh 6
 778             put_ bh al
 779             put_ bh am
 780     put_ bh (UfNote an ao) = do
 781             putByte bh 7
 782             put_ bh an
 783             put_ bh ao
 784     put_ bh (UfLit ap) = do
 785             putByte bh 8
 786             put_ bh ap
 787     put_ bh (UfLitLit aq ar) = do
 788             putByte bh 9
 789             put_ bh aq
 790             put_ bh ar
 791     put_ bh (UfFCall as at) = do
 792             putByte bh 10
 793             put_ bh as
 794             put_ bh at
 795     get bh = do
 796             h <- getByte bh
 797             case h of
 798               0 -> do aa <- get bh
 799                       return (UfVar aa)
 800               1 -> do ab <- get bh
 801                       return (UfType ab)
 802               2 -> do ac <- get bh
 803                       ad <- get bh
 804                       return (UfTuple ac ad)
 805               3 -> do ae <- get bh
 806                       af <- get bh
 807                       return (UfLam ae af)
 808               4 -> do ag <- get bh
 809                       ah <- get bh
 810                       return (UfApp ag ah)
 811               5 -> do ai <- get bh
 812                       aj <- get bh
 813                       ak <- get bh
 814                       return (UfCase ai aj ak)
 815               6 -> do al <- get bh
 816                       am <- get bh
 817                       return (UfLet al am)
 818               7 -> do an <- get bh
 819                       ao <- get bh
 820                       return (UfNote an ao)
 821               8 -> do ap <- get bh
 822                       return (UfLit ap)
 823               9 -> do aq <- get bh
 824                       ar <- get bh
 825                       return (UfLitLit aq ar)
 826               _ -> do as <- get bh
 827                       at <- get bh
 828                       return (UfFCall as at)
 829
 830 instance (Binary name) => Binary (UfConAlt name) where
 831     put_ bh UfDefault = do
 832             putByte bh 0
 833     put_ bh (UfDataAlt aa) = do
 834             putByte bh 1
 835             put_ bh aa
 836     put_ bh (UfTupleAlt ab) = do
 837             putByte bh 2
 838             put_ bh ab
 839     put_ bh (UfLitAlt ac) = do
 840             putByte bh 3
 841             put_ bh ac
 842     put_ bh (UfLitLitAlt ad ae) = do
 843             putByte bh 4
 844             put_ bh ad
 845             put_ bh ae
 846     get bh = do
 847             h <- getByte bh
 848             case h of
 849               0 -> do return UfDefault
 850               1 -> do aa <- get bh
 851                       return (UfDataAlt aa)
 852               2 -> do ab <- get bh
 853                       return (UfTupleAlt ab)
 854               3 -> do ac <- get bh
 855                       return (UfLitAlt ac)
 856               _ -> do ad <- get bh
 857                       ae <- get bh
 858                       return (UfLitLitAlt ad ae)
 859
 860 instance (Binary name) => Binary (UfBinding name) where
 861     put_ bh (UfNonRec aa ab) = do
 862             putByte bh 0
 863             put_ bh aa
 864             put_ bh ab
 865     put_ bh (UfRec ac) = do
 866             putByte bh 1
 867             put_ bh ac
 868     get bh = do
 869             h <- getByte bh
 870             case h of
 871               0 -> do aa <- get bh
 872                       ab <- get bh
 873                       return (UfNonRec aa ab)
 874               _ -> do ac <- get bh
 875                       return (UfRec ac)
 876
 877 instance (Binary name) => Binary (UfBinder name) where
 878     put_ bh (UfValBinder aa ab) = do
 879             putByte bh 0
 880             put_ bh aa
 881             put_ bh ab
 882     put_ bh (UfTyBinder ac ad) = do
 883             putByte bh 1
 884             put_ bh ac
 885             put_ bh ad
 886     get bh = do
 887             h <- getByte bh
 888             case h of
 889               0 -> do aa <- get bh
 890                       ab <- get bh
 891                       return (UfValBinder aa ab)
 892               _ -> do ac <- get bh
 893                       ad <- get bh
 894                       return (UfTyBinder ac ad)
 895
 896 instance (Binary name) => Binary (HsIdInfo name) where
 897     put_ bh (HsArity aa) = do
 898             putByte bh 0
 899             put_ bh aa
 900     put_ bh (HsStrictness ab) = do
 901             putByte bh 1
 902             put_ bh ab
 903     put_ bh (HsUnfold ac ad) = do
 904             putByte bh 2
 905             put_ bh ac
 906             put_ bh ad
 907     put_ bh HsNoCafRefs = do
 908             putByte bh 3
 909     put_ bh (HsWorker ae af) = do
 910             putByte bh 4
 911             put_ bh ae
 912             put_ bh af
 913     get bh = do
 914             h <- getByte bh
 915             case h of
 916               0 -> do aa <- get bh
 917                       return (HsArity aa)
 918               1 -> do ab <- get bh
 919                       return (HsStrictness ab)
 920               2 -> do ac <- get bh
 921                       ad <- get bh
 922                       return (HsUnfold ac ad)
 923               3 -> do return HsNoCafRefs
 924               _ -> do ae <- get bh
 925                       af <- get bh
 926                       return (HsWorker ae af)
 927
 928 instance (Binary name) => Binary (UfNote name) where
 929     put_ bh (UfSCC aa) = do
 930             putByte bh 0
 931             put_ bh aa
 932     put_ bh (UfCoerce ab) = do
 933             putByte bh 1
 934             put_ bh ab
 935     put_ bh UfInlineCall = do
 936             putByte bh 2
 937     put_ bh UfInlineMe = do
 938             putByte bh 3
 939     get bh = do
 940             h <- getByte bh
 941             case h of
 942               0 -> do aa <- get bh
 943                       return (UfSCC aa)
 944               1 -> do ab <- get bh
 945                       return (UfCoerce ab)
 946               2 -> do return UfInlineCall
 947               _ -> do return UfInlineMe
 948
 949 instance (Binary name) => Binary (BangType name) where
 950     put_ bh (BangType aa ab) = do
 951             put_ bh aa
 952             put_ bh ab
 953     get bh = do
 954           aa <- get bh
 955           ab <- get bh
 956           return (BangType aa ab)
 957
 958 instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
 959     put_ bh (PrefixCon aa) = do
 960             putByte bh 0
 961             put_ bh aa
 962     put_ bh (InfixCon ab ac) = do
 963             putByte bh 1
 964             put_ bh ab
 965             put_ bh ac
 966     put_ bh (RecCon ad) = do
 967             putByte bh 2
 968             put_ bh ad
 969     get bh = do
 970             h <- getByte bh
 971             case h of
 972               0 -> do aa <- get bh
 973                       return (PrefixCon aa)
 974               1 -> do ab <- get bh
 975                       ac <- get bh
 976                       return (InfixCon ab ac)
 977               _ -> do ad <- get bh
 978                       return (RecCon ad)
 979
 980 instance (Binary datacon) => Binary (DataConDetails datacon) where
 981     put_ bh (DataCons aa) = do
 982             putByte bh 0
 983             put_ bh aa
 984     put_ bh Unknown = do
 985             putByte bh 1
 986     put_ bh (HasCons ab) = do
 987             putByte bh 2
 988             put_ bh ab
 989     get bh = do
 990             h <- getByte bh
 991             case h of
 992               0 -> do aa <- get bh
 993                       return (DataCons aa)
 994               1 -> do return Unknown
 995               _ -> do ab <- get bh
 996                       return (HasCons ab)
 997
 998 instance (Binary id) => Binary (DefMeth id) where
 999     put_ bh NoDefMeth = do
1000             putByte bh 0
1001     put_ bh (DefMeth aa) = do
1002             putByte bh 1
1003             put_ bh aa
1004     put_ bh GenDefMeth = do
1005             putByte bh 2
1006     get bh = do
1007             h <- getByte bh
1008             case h of
1009               0 -> do return NoDefMeth
1010               1 -> do aa <- get bh
1011                       return (DefMeth aa)
1012               _ -> do return GenDefMeth
1013
1014 instance Binary IsCafCC where
1015     put_ bh CafCC = do
1016             putByte bh 0
1017     put_ bh NotCafCC = do
1018             putByte bh 1
1019     get bh = do
1020             h <- getByte bh
1021             case h of
1022               0 -> do return CafCC
1023               _ -> do return NotCafCC
1024
1025 instance Binary IsDupdCC where
1026     put_ bh OriginalCC = do
1027             putByte bh 0
1028     put_ bh DupdCC = do
1029             putByte bh 1
1030     get bh = do
1031             h <- getByte bh
1032             case h of
1033               0 -> do return OriginalCC
1034               _ -> do return DupdCC
1035
1036 instance Binary CostCentre where
1037     put_ bh NoCostCentre = do
1038             putByte bh 0
1039     put_ bh (NormalCC aa ab ac ad) = do
1040             putByte bh 1
1041             put_ bh aa
1042             put_ bh ab
1043             put_ bh ac
1044             put_ bh ad
1045     put_ bh (AllCafsCC ae) = do
1046             putByte bh 2
1047             put_ bh ae
1048     get bh = do
1049             h <- getByte bh
1050             case h of
1051               0 -> do return NoCostCentre
1052               1 -> do aa <- get bh
1053                       ab <- get bh
1054                       ac <- get bh
1055                       ad <- get bh
1056                       return (NormalCC aa ab ac ad)
1057               _ -> do ae <- get bh
1058                       return (AllCafsCC ae)