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