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