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 name) => Binary (GenAvailInfo name) where
 397     put_ bh (Avail aa) = do
 398             putByte bh 0
 399             put_ bh aa
 400     put_ bh (AvailTC ab ac) = do
 401             putByte bh 1
 402             put_ bh ab
 403             put_ bh ac
 404     get bh = do
 405             h <- getByte bh
 406             case h of
 407               0 -> do aa <- get bh
 408                       return (Avail aa)
 409               _ -> do ab <- get bh
 410                       ac <- get bh
 411                       return (AvailTC ab ac)
 412
 413 instance (Binary name) => Binary (Usage name) where
 414     put_ bh usg = do
 415         put_ bh (usg_name     usg)
 416         put_ bh (usg_mod      usg)
 417         put_ bh (usg_exports  usg)
 418         put_ bh (usg_entities usg)
 419         put_ bh (usg_rules    usg)
 420
 421     get bh = do
 422         nm    <- get bh
 423         mod   <- get bh
 424         exps  <- get bh
 425         ents  <- get bh
 426         rules <- get bh
 427         return (Usage { usg_name = nm, usg_mod = mod,
 428                         usg_exports = exps, usg_entities = ents,
 429                         usg_rules = rules })
 430
 431 instance Binary Activation where
 432     put_ bh NeverActive = do
 433             putByte bh 0
 434     put_ bh AlwaysActive = do
 435             putByte bh 1
 436     put_ bh (ActiveBefore aa) = do
 437             putByte bh 2
 438             put_ bh aa
 439     put_ bh (ActiveAfter ab) = do
 440             putByte bh 3
 441             put_ bh ab
 442     get bh = do
 443             h <- getByte bh
 444             case h of
 445               0 -> do return NeverActive
 446               1 -> do return AlwaysActive
 447               2 -> do aa <- get bh
 448                       return (ActiveBefore aa)
 449               _ -> do ab <- get bh
 450                       return (ActiveAfter ab)
 451
 452 instance Binary StrictnessMark where
 453     put_ bh MarkedUserStrict = do
 454             putByte bh 0
 455     put_ bh MarkedStrict = do
 456             putByte bh 1
 457     put_ bh MarkedUnboxed = do
 458             putByte bh 2
 459     put_ bh NotMarkedStrict = do
 460             putByte bh 3
 461     get bh = do
 462             h <- getByte bh
 463             case h of
 464               0 -> do return MarkedUserStrict
 465               1 -> do return MarkedStrict
 466               2 -> do return MarkedUnboxed
 467               _ -> do return NotMarkedStrict
 468
 469 instance Binary Boxity where
 470     put_ bh Boxed = do
 471             putByte bh 0
 472     put_ bh Unboxed = do
 473             putByte bh 1
 474     get bh = do
 475             h <- getByte bh
 476             case h of
 477               0 -> do return Boxed
 478               _ -> do return Unboxed
 479
 480 instance Binary NewOrData where
 481     put_ bh NewType = do
 482             putByte bh 0
 483     put_ bh DataType = do
 484             putByte bh 1
 485     get bh = do
 486             h <- getByte bh
 487             case h of
 488               0 -> do return NewType
 489               _ -> do return DataType
 490
 491 instance Binary FixityDirection where
 492     put_ bh InfixL = do
 493             putByte bh 0
 494     put_ bh InfixR = do
 495             putByte bh 1
 496     put_ bh InfixN = do
 497             putByte bh 2
 498     get bh = do
 499             h <- getByte bh
 500             case h of
 501               0 -> do return InfixL
 502               1 -> do return InfixR
 503               _ -> do return InfixN
 504
 505 instance Binary Fixity where
 506     put_ bh (Fixity aa ab) = do
 507             put_ bh aa
 508             put_ bh ab
 509     get bh = do
 510           aa <- get bh
 511           ab <- get bh
 512           return (Fixity aa ab)
 513
 514 instance (Binary name) => Binary (FixitySig name) where
 515     put_ bh (FixitySig aa ab _) = do
 516             put_ bh aa
 517             put_ bh ab
 518     get bh = do
 519           aa <- get bh
 520           ab <- get bh
 521           return (FixitySig aa ab noSrcLoc)
 522
 523 instance (Binary name) => Binary (IPName name) where
 524     put_ bh (Dupable aa) = do
 525             putByte bh 0
 526             put_ bh aa
 527     put_ bh (Linear ab) = do
 528             putByte bh 1
 529             put_ bh ab
 530     get bh = do
 531             h <- getByte bh
 532             case h of
 533               0 -> do aa <- get bh
 534                       return (Dupable aa)
 535               _ -> do ab <- get bh
 536                       return (Linear ab)
 537
 538 instance Binary Demand where
 539     put_ bh Top = do
 540             putByte bh 0
 541     put_ bh Abs = do
 542             putByte bh 1
 543     put_ bh (Call aa) = do
 544             putByte bh 2
 545             put_ bh aa
 546     put_ bh (Eval ab) = do
 547             putByte bh 3
 548             put_ bh ab
 549     put_ bh (Defer ac) = do
 550             putByte bh 4
 551             put_ bh ac
 552     put_ bh (Box ad) = do
 553             putByte bh 5
 554             put_ bh ad
 555     put_ bh Bot = do
 556             putByte bh 6
 557     get bh = do
 558             h <- getByte bh
 559             case h of
 560               0 -> do return Top
 561               1 -> do return Abs
 562               2 -> do aa <- get bh
 563                       return (Call aa)
 564               3 -> do ab <- get bh
 565                       return (Eval ab)
 566               4 -> do ac <- get bh
 567                       return (Defer ac)
 568               5 -> do ad <- get bh
 569                       return (Box ad)
 570               _ -> do return Bot
 571
 572 instance Binary Demands where
 573     put_ bh (Poly aa) = do
 574             putByte bh 0
 575             put_ bh aa
 576     put_ bh (Prod ab) = do
 577             putByte bh 1
 578             put_ bh ab
 579     get bh = do
 580             h <- getByte bh
 581             case h of
 582               0 -> do aa <- get bh
 583                       return (Poly aa)
 584               _ -> do ab <- get bh
 585                       return (Prod ab)
 586
 587 instance Binary DmdResult where
 588     put_ bh TopRes = do
 589             putByte bh 0
 590     put_ bh RetCPR = do
 591             putByte bh 1
 592     put_ bh BotRes = do
 593             putByte bh 2
 594     get bh = do
 595             h <- getByte bh
 596             case h of
 597               0 -> do return TopRes
 598               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 599                                         -- The wrapper was generated for CPR in
 600                                         -- the imported module!
 601               _ -> do return BotRes
 602
 603 instance Binary StrictSig where
 604     put_ bh (StrictSig aa) = do
 605             put_ bh aa
 606     get bh = do
 607           aa <- get bh
 608           return (StrictSig aa)
 609
 610 instance (Binary name) => Binary (HsTyVarBndr name) where
 611     put_ bh (UserTyVar aa) = do
 612             putByte bh 0
 613             put_ bh aa
 614     put_ bh (IfaceTyVar ab ac) = do
 615             putByte bh 1
 616             put_ bh ab
 617             put_ bh ac
 618     get bh = do
 619             h <- getByte bh
 620             case h of
 621               0 -> do aa <- get bh
 622                       return (UserTyVar aa)
 623               _ -> do ab <- get bh
 624                       ac <- get bh
 625                       return (IfaceTyVar ab ac)
 626
 627 instance Binary HsTupCon where
 628     put_ bh (HsTupCon ab ac) = do
 629             put_ bh ab
 630             put_ bh ac
 631     get bh = do
 632           ab <- get bh
 633           ac <- get bh
 634           return (HsTupCon ab ac)
 635
 636 instance (Binary name) => Binary (HsTyOp name) where
 637     put_ bh HsArrow    = putByte bh 0
 638     put_ bh (HsTyOp n) = do putByte bh 1
 639                             put_ bh n
 640
 641     get bh = do h <- getByte bh
 642                 case h of
 643                   0 -> return HsArrow
 644                   1 -> do a <- get bh
 645                           return (HsTyOp a)
 646
 647 instance (Binary name) => Binary (HsType name) where
 648     put_ bh (HsForAllTy aa ab ac) = do
 649             putByte bh 0
 650             put_ bh aa
 651             put_ bh ab
 652             put_ bh ac
 653     put_ bh (HsTyVar ad) = do
 654             putByte bh 1
 655             put_ bh ad
 656     put_ bh (HsAppTy ae af) = do
 657             putByte bh 2
 658             put_ bh ae
 659             put_ bh af
 660     put_ bh (HsFunTy ag ah) = do
 661             putByte bh 3
 662             put_ bh ag
 663             put_ bh ah
 664     put_ bh (HsListTy ai) = do
 665             putByte bh 4
 666             put_ bh ai
 667     put_ bh (HsPArrTy aj) = do
 668             putByte bh 5
 669             put_ bh aj
 670     put_ bh (HsTupleTy ak al) = do
 671             putByte bh 6
 672             put_ bh ak
 673             put_ bh al
 674     put_ bh (HsOpTy am an ao) = do
 675             putByte bh 7
 676             put_ bh am
 677             put_ bh an
 678             put_ bh ao
 679     put_ bh (HsNumTy ap) = do
 680             putByte bh 8
 681             put_ bh ap
 682     put_ bh (HsPredTy aq) = do
 683             putByte bh 9
 684             put_ bh aq
 685     put_ bh (HsKindSig ar as) = do
 686             putByte bh 10
 687             put_ bh ar
 688             put_ bh as
 689     get bh = do
 690             h <- getByte bh
 691             case h of
 692               0 -> do aa <- get bh
 693                       ab <- get bh
 694                       ac <- get bh
 695                       return (HsForAllTy aa ab ac)
 696               1 -> do ad <- get bh
 697                       return (HsTyVar ad)
 698               2 -> do ae <- get bh
 699                       af <- get bh
 700                       return (HsAppTy ae af)
 701               3 -> do ag <- get bh
 702                       ah <- get bh
 703                       return (HsFunTy ag ah)
 704               4 -> do ai <- get bh
 705                       return (HsListTy ai)
 706               5 -> do aj <- get bh
 707                       return (HsPArrTy aj)
 708               6 -> do ak <- get bh
 709                       al <- get bh
 710                       return (HsTupleTy ak al)
 711               7 -> do am <- get bh
 712                       an <- get bh
 713                       ao <- get bh
 714                       return (HsOpTy am an ao)
 715               8 -> do ap <- get bh
 716                       return (HsNumTy ap)
 717               9 -> do aq <- get bh
 718                       return (HsPredTy aq)
 719               _ -> do ar <- get bh
 720                       as <- get bh
 721                       return (HsKindSig ar as)
 722
 723 instance (Binary name) => Binary (HsPred name) where
 724     put_ bh (HsClassP aa ab) = do
 725             putByte bh 0
 726             put_ bh aa
 727             put_ bh ab
 728     put_ bh (HsIParam ac ad) = do
 729             putByte bh 1
 730             put_ bh ac
 731             put_ bh ad
 732     get bh = do
 733             h <- getByte bh
 734             case h of
 735               0 -> do aa <- get bh
 736                       ab <- get bh
 737                       return (HsClassP aa ab)
 738               _ -> do ac <- get bh
 739                       ad <- get bh
 740                       return (HsIParam ac ad)
 741
 742 instance (Binary name) => Binary (UfExpr name) where
 743     put_ bh (UfVar aa) = do
 744             putByte bh 0
 745             put_ bh aa
 746     put_ bh (UfType ab) = do
 747             putByte bh 1
 748             put_ bh ab
 749     put_ bh (UfTuple ac ad) = do
 750             putByte bh 2
 751             put_ bh ac
 752             put_ bh ad
 753     put_ bh (UfLam ae af) = do
 754             putByte bh 3
 755             put_ bh ae
 756             put_ bh af
 757     put_ bh (UfApp ag ah) = do
 758             putByte bh 4
 759             put_ bh ag
 760             put_ bh ah
 761     put_ bh (UfCase ai aj ak) = do
 762             putByte bh 5
 763             put_ bh ai
 764             put_ bh aj
 765             put_ bh ak
 766     put_ bh (UfLet al am) = do
 767             putByte bh 6
 768             put_ bh al
 769             put_ bh am
 770     put_ bh (UfNote an ao) = do
 771             putByte bh 7
 772             put_ bh an
 773             put_ bh ao
 774     put_ bh (UfLit ap) = do
 775             putByte bh 8
 776             put_ bh ap
 777     put_ bh (UfLitLit aq ar) = do
 778             putByte bh 9
 779             put_ bh aq
 780             put_ bh ar
 781     put_ bh (UfFCall as at) = do
 782             putByte bh 10
 783             put_ bh as
 784             put_ bh at
 785     get bh = do
 786             h <- getByte bh
 787             case h of
 788               0 -> do aa <- get bh
 789                       return (UfVar aa)
 790               1 -> do ab <- get bh
 791                       return (UfType ab)
 792               2 -> do ac <- get bh
 793                       ad <- get bh
 794                       return (UfTuple ac ad)
 795               3 -> do ae <- get bh
 796                       af <- get bh
 797                       return (UfLam ae af)
 798               4 -> do ag <- get bh
 799                       ah <- get bh
 800                       return (UfApp ag ah)
 801               5 -> do ai <- get bh
 802                       aj <- get bh
 803                       ak <- get bh
 804                       return (UfCase ai aj ak)
 805               6 -> do al <- get bh
 806                       am <- get bh
 807                       return (UfLet al am)
 808               7 -> do an <- get bh
 809                       ao <- get bh
 810                       return (UfNote an ao)
 811               8 -> do ap <- get bh
 812                       return (UfLit ap)
 813               9 -> do aq <- get bh
 814                       ar <- get bh
 815                       return (UfLitLit aq ar)
 816               _ -> do as <- get bh
 817                       at <- get bh
 818                       return (UfFCall as at)
 819
 820 instance (Binary name) => Binary (UfConAlt name) where
 821     put_ bh UfDefault = do
 822             putByte bh 0
 823     put_ bh (UfDataAlt aa) = do
 824             putByte bh 1
 825             put_ bh aa
 826     put_ bh (UfTupleAlt ab) = do
 827             putByte bh 2
 828             put_ bh ab
 829     put_ bh (UfLitAlt ac) = do
 830             putByte bh 3
 831             put_ bh ac
 832     put_ bh (UfLitLitAlt ad ae) = do
 833             putByte bh 4
 834             put_ bh ad
 835             put_ bh ae
 836     get bh = do
 837             h <- getByte bh
 838             case h of
 839               0 -> do return UfDefault
 840               1 -> do aa <- get bh
 841                       return (UfDataAlt aa)
 842               2 -> do ab <- get bh
 843                       return (UfTupleAlt ab)
 844               3 -> do ac <- get bh
 845                       return (UfLitAlt ac)
 846               _ -> do ad <- get bh
 847                       ae <- get bh
 848                       return (UfLitLitAlt ad ae)
 849
 850 instance (Binary name) => Binary (UfBinding name) where
 851     put_ bh (UfNonRec aa ab) = do
 852             putByte bh 0
 853             put_ bh aa
 854             put_ bh ab
 855     put_ bh (UfRec ac) = do
 856             putByte bh 1
 857             put_ bh ac
 858     get bh = do
 859             h <- getByte bh
 860             case h of
 861               0 -> do aa <- get bh
 862                       ab <- get bh
 863                       return (UfNonRec aa ab)
 864               _ -> do ac <- get bh
 865                       return (UfRec ac)
 866
 867 instance (Binary name) => Binary (UfBinder name) where
 868     put_ bh (UfValBinder aa ab) = do
 869             putByte bh 0
 870             put_ bh aa
 871             put_ bh ab
 872     put_ bh (UfTyBinder ac ad) = do
 873             putByte bh 1
 874             put_ bh ac
 875             put_ bh ad
 876     get bh = do
 877             h <- getByte bh
 878             case h of
 879               0 -> do aa <- get bh
 880                       ab <- get bh
 881                       return (UfValBinder aa ab)
 882               _ -> do ac <- get bh
 883                       ad <- get bh
 884                       return (UfTyBinder ac ad)
 885
 886 instance (Binary name) => Binary (HsIdInfo name) where
 887     put_ bh (HsArity aa) = do
 888             putByte bh 0
 889             put_ bh aa
 890     put_ bh (HsStrictness ab) = do
 891             putByte bh 1
 892             put_ bh ab
 893     put_ bh (HsUnfold ac ad) = do
 894             putByte bh 2
 895             put_ bh ac
 896             put_ bh ad
 897     put_ bh HsNoCafRefs = do
 898             putByte bh 3
 899     put_ bh (HsWorker ae af) = do
 900             putByte bh 4
 901             put_ bh ae
 902             put_ bh af
 903     get bh = do
 904             h <- getByte bh
 905             case h of
 906               0 -> do aa <- get bh
 907                       return (HsArity aa)
 908               1 -> do ab <- get bh
 909                       return (HsStrictness ab)
 910               2 -> do ac <- get bh
 911                       ad <- get bh
 912                       return (HsUnfold ac ad)
 913               3 -> do return HsNoCafRefs
 914               _ -> do ae <- get bh
 915                       af <- get bh
 916                       return (HsWorker ae af)
 917
 918 instance (Binary name) => Binary (UfNote name) where
 919     put_ bh (UfSCC aa) = do
 920             putByte bh 0
 921             put_ bh aa
 922     put_ bh (UfCoerce ab) = do
 923             putByte bh 1
 924             put_ bh ab
 925     put_ bh UfInlineCall = do
 926             putByte bh 2
 927     put_ bh UfInlineMe = do
 928             putByte bh 3
 929     get bh = do
 930             h <- getByte bh
 931             case h of
 932               0 -> do aa <- get bh
 933                       return (UfSCC aa)
 934               1 -> do ab <- get bh
 935                       return (UfCoerce ab)
 936               2 -> do return UfInlineCall
 937               _ -> do return UfInlineMe
 938
 939 instance (Binary name) => Binary (BangType name) where
 940     put_ bh (BangType aa ab) = do
 941             put_ bh aa
 942             put_ bh ab
 943     get bh = do
 944           aa <- get bh
 945           ab <- get bh
 946           return (BangType aa ab)
 947
 948 instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
 949     put_ bh (PrefixCon aa) = do
 950             putByte bh 0
 951             put_ bh aa
 952     put_ bh (InfixCon ab ac) = do
 953             putByte bh 1
 954             put_ bh ab
 955             put_ bh ac
 956     put_ bh (RecCon ad) = do
 957             putByte bh 2
 958             put_ bh ad
 959     get bh = do
 960             h <- getByte bh
 961             case h of
 962               0 -> do aa <- get bh
 963                       return (PrefixCon aa)
 964               1 -> do ab <- get bh
 965                       ac <- get bh
 966                       return (InfixCon ab ac)
 967               _ -> do ad <- get bh
 968                       return (RecCon ad)
 969
 970 instance (Binary datacon) => Binary (DataConDetails datacon) where
 971     put_ bh (DataCons aa) = do
 972             putByte bh 0
 973             put_ bh aa
 974     put_ bh Unknown = do
 975             putByte bh 1
 976     put_ bh (HasCons ab) = do
 977             putByte bh 2
 978             put_ bh ab
 979     get bh = do
 980             h <- getByte bh
 981             case h of
 982               0 -> do aa <- get bh
 983                       return (DataCons aa)
 984               1 -> do return Unknown
 985               _ -> do ab <- get bh
 986                       return (HasCons ab)
 987
 988 instance (Binary id) => Binary (DefMeth id) where
 989     put_ bh NoDefMeth = do
 990             putByte bh 0
 991     put_ bh (DefMeth aa) = do
 992             putByte bh 1
 993             put_ bh aa
 994     put_ bh GenDefMeth = do
 995             putByte bh 2
 996     get bh = do
 997             h <- getByte bh
 998             case h of
 999               0 -> do return NoDefMeth
1000               1 -> do aa <- get bh
1001                       return (DefMeth aa)
1002               _ -> do return GenDefMeth
1003
1004 instance Binary IsCafCC where
1005     put_ bh CafCC = do
1006             putByte bh 0
1007     put_ bh NotCafCC = do
1008             putByte bh 1
1009     get bh = do
1010             h <- getByte bh
1011             case h of
1012               0 -> do return CafCC
1013               _ -> do return NotCafCC
1014
1015 instance Binary IsDupdCC where
1016     put_ bh OriginalCC = do
1017             putByte bh 0
1018     put_ bh DupdCC = do
1019             putByte bh 1
1020     get bh = do
1021             h <- getByte bh
1022             case h of
1023               0 -> do return OriginalCC
1024               _ -> do return DupdCC
1025
1026 instance Binary CostCentre where
1027     put_ bh NoCostCentre = do
1028             putByte bh 0
1029     put_ bh (NormalCC aa ab ac ad) = do
1030             putByte bh 1
1031             put_ bh aa
1032             put_ bh ab
1033             put_ bh ac
1034             put_ bh ad
1035     put_ bh (AllCafsCC ae) = do
1036             putByte bh 2
1037             put_ bh ae
1038     get bh = do
1039             h <- getByte bh
1040             case h of
1041               0 -> do return NoCostCentre
1042               1 -> do aa <- get bh
1043                       ab <- get bh
1044                       ac <- get bh
1045                       ad <- get bh
1046                       return (NormalCC aa ab ac ad)
1047               _ -> do ae <- get bh
1048                       return (AllCafsCC ae)