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