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         lazyPut 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 as 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         lazyPut 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      <- {-# SCC "bin_usages" #-} get bh
 348         exports     <- {-# SCC "bin_exports" #-} get bh
 349         tycl_decls  <- {-# SCC "bin_tycldecls" #-} get bh
 350         fixities    <- {-# SCC "bin_fixities" #-} get bh
 351         insts       <- {-# SCC "bin_insts" #-} get bh
 352         rules       <- {-# SCC "bin_rules" #-} lazyGet bh
 353         deprecs     <- {-# SCC "bin_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     -- Really use RetCPR even if -fcpr-off
 579                                         -- The wrapper was generated for CPR in
 580                                         -- the imported module!
 581               _ -> do return BotRes
 582
 583 instance Binary StrictSig where
 584     put_ bh (StrictSig aa) = do
 585             put_ bh aa
 586     get bh = do
 587           aa <- get bh
 588           return (StrictSig aa)
 589
 590 instance (Binary name) => Binary (HsTyVarBndr name) where
 591     put_ bh (UserTyVar aa) = do
 592             putByte bh 0
 593             put_ bh aa
 594     put_ bh (IfaceTyVar ab ac) = do
 595             putByte bh 1
 596             put_ bh ab
 597             put_ bh ac
 598     get bh = do
 599             h <- getByte bh
 600             case h of
 601               0 -> do aa <- get bh
 602                       return (UserTyVar aa)
 603               _ -> do ab <- get bh
 604                       ac <- get bh
 605                       return (IfaceTyVar ab ac)
 606
 607 instance (Binary name) => Binary (HsTupCon name) where
 608     put_ bh (HsTupCon aa ab ac) = do
 609             put_ bh aa
 610             put_ bh ab
 611             put_ bh ac
 612     get bh = do
 613           aa <- get bh
 614           ab <- get bh
 615           ac <- get bh
 616           return (HsTupCon aa ab ac)
 617
 618 instance (Binary name) => Binary (HsType name) where
 619     put_ bh (HsForAllTy aa ab ac) = do
 620             putByte bh 0
 621             put_ bh aa
 622             put_ bh ab
 623             put_ bh ac
 624     put_ bh (HsTyVar ad) = do
 625             putByte bh 1
 626             put_ bh ad
 627     put_ bh (HsAppTy ae af) = do
 628             putByte bh 2
 629             put_ bh ae
 630             put_ bh af
 631     put_ bh (HsFunTy ag ah) = do
 632             putByte bh 3
 633             put_ bh ag
 634             put_ bh ah
 635     put_ bh (HsListTy ai) = do
 636             putByte bh 4
 637             put_ bh ai
 638     put_ bh (HsPArrTy aj) = do
 639             putByte bh 5
 640             put_ bh aj
 641     put_ bh (HsTupleTy ak al) = do
 642             putByte bh 6
 643             put_ bh ak
 644             put_ bh al
 645     put_ bh (HsOpTy am an ao) = do
 646             putByte bh 7
 647             put_ bh am
 648             put_ bh an
 649             put_ bh ao
 650     put_ bh (HsNumTy ap) = do
 651             putByte bh 8
 652             put_ bh ap
 653     put_ bh (HsPredTy aq) = do
 654             putByte bh 9
 655             put_ bh aq
 656     put_ bh (HsKindSig ar as) = do
 657             putByte bh 10
 658             put_ bh ar
 659             put_ bh as
 660     get bh = do
 661             h <- getByte bh
 662             case h of
 663               0 -> do aa <- get bh
 664                       ab <- get bh
 665                       ac <- get bh
 666                       return (HsForAllTy aa ab ac)
 667               1 -> do ad <- get bh
 668                       return (HsTyVar ad)
 669               2 -> do ae <- get bh
 670                       af <- get bh
 671                       return (HsAppTy ae af)
 672               3 -> do ag <- get bh
 673                       ah <- get bh
 674                       return (HsFunTy ag ah)
 675               4 -> do ai <- get bh
 676                       return (HsListTy ai)
 677               5 -> do aj <- get bh
 678                       return (HsPArrTy aj)
 679               6 -> do ak <- get bh
 680                       al <- get bh
 681                       return (HsTupleTy ak al)
 682               7 -> do am <- get bh
 683                       an <- get bh
 684                       ao <- get bh
 685                       return (HsOpTy am an ao)
 686               8 -> do ap <- get bh
 687                       return (HsNumTy ap)
 688               9 -> do aq <- get bh
 689                       return (HsPredTy aq)
 690               _ -> do ar <- get bh
 691                       as <- get bh
 692                       return (HsKindSig ar as)
 693
 694 instance (Binary name) => Binary (HsPred name) where
 695     put_ bh (HsClassP aa ab) = do
 696             putByte bh 0
 697             put_ bh aa
 698             put_ bh ab
 699     put_ bh (HsIParam ac ad) = do
 700             putByte bh 1
 701             put_ bh ac
 702             put_ bh ad
 703     get bh = do
 704             h <- getByte bh
 705             case h of
 706               0 -> do aa <- get bh
 707                       ab <- get bh
 708                       return (HsClassP aa ab)
 709               _ -> do ac <- get bh
 710                       ad <- get bh
 711                       return (HsIParam ac ad)
 712
 713 instance (Binary name) => Binary (UfExpr name) where
 714     put_ bh (UfVar aa) = do
 715             putByte bh 0
 716             put_ bh aa
 717     put_ bh (UfType ab) = do
 718             putByte bh 1
 719             put_ bh ab
 720     put_ bh (UfTuple ac ad) = do
 721             putByte bh 2
 722             put_ bh ac
 723             put_ bh ad
 724     put_ bh (UfLam ae af) = do
 725             putByte bh 3
 726             put_ bh ae
 727             put_ bh af
 728     put_ bh (UfApp ag ah) = do
 729             putByte bh 4
 730             put_ bh ag
 731             put_ bh ah
 732     put_ bh (UfCase ai aj ak) = do
 733             putByte bh 5
 734             put_ bh ai
 735             put_ bh aj
 736             put_ bh ak
 737     put_ bh (UfLet al am) = do
 738             putByte bh 6
 739             put_ bh al
 740             put_ bh am
 741     put_ bh (UfNote an ao) = do
 742             putByte bh 7
 743             put_ bh an
 744             put_ bh ao
 745     put_ bh (UfLit ap) = do
 746             putByte bh 8
 747             put_ bh ap
 748     put_ bh (UfLitLit aq ar) = do
 749             putByte bh 9
 750             put_ bh aq
 751             put_ bh ar
 752     put_ bh (UfFCall as at) = do
 753             putByte bh 10
 754             put_ bh as
 755             put_ bh at
 756     get bh = do
 757             h <- getByte bh
 758             case h of
 759               0 -> do aa <- get bh
 760                       return (UfVar aa)
 761               1 -> do ab <- get bh
 762                       return (UfType ab)
 763               2 -> do ac <- get bh
 764                       ad <- get bh
 765                       return (UfTuple ac ad)
 766               3 -> do ae <- get bh
 767                       af <- get bh
 768                       return (UfLam ae af)
 769               4 -> do ag <- get bh
 770                       ah <- get bh
 771                       return (UfApp ag ah)
 772               5 -> do ai <- get bh
 773                       aj <- get bh
 774                       ak <- get bh
 775                       return (UfCase ai aj ak)
 776               6 -> do al <- get bh
 777                       am <- get bh
 778                       return (UfLet al am)
 779               7 -> do an <- get bh
 780                       ao <- get bh
 781                       return (UfNote an ao)
 782               8 -> do ap <- get bh
 783                       return (UfLit ap)
 784               9 -> do aq <- get bh
 785                       ar <- get bh
 786                       return (UfLitLit aq ar)
 787               _ -> do as <- get bh
 788                       at <- get bh
 789                       return (UfFCall as at)
 790
 791 instance (Binary name) => Binary (UfConAlt name) where
 792     put_ bh UfDefault = do
 793             putByte bh 0
 794     put_ bh (UfDataAlt aa) = do
 795             putByte bh 1
 796             put_ bh aa
 797     put_ bh (UfTupleAlt ab) = do
 798             putByte bh 2
 799             put_ bh ab
 800     put_ bh (UfLitAlt ac) = do
 801             putByte bh 3
 802             put_ bh ac
 803     put_ bh (UfLitLitAlt ad ae) = do
 804             putByte bh 4
 805             put_ bh ad
 806             put_ bh ae
 807     get bh = do
 808             h <- getByte bh
 809             case h of
 810               0 -> do return UfDefault
 811               1 -> do aa <- get bh
 812                       return (UfDataAlt aa)
 813               2 -> do ab <- get bh
 814                       return (UfTupleAlt ab)
 815               3 -> do ac <- get bh
 816                       return (UfLitAlt ac)
 817               _ -> do ad <- get bh
 818                       ae <- get bh
 819                       return (UfLitLitAlt ad ae)
 820
 821 instance (Binary name) => Binary (UfBinding name) where
 822     put_ bh (UfNonRec aa ab) = do
 823             putByte bh 0
 824             put_ bh aa
 825             put_ bh ab
 826     put_ bh (UfRec ac) = do
 827             putByte bh 1
 828             put_ bh ac
 829     get bh = do
 830             h <- getByte bh
 831             case h of
 832               0 -> do aa <- get bh
 833                       ab <- get bh
 834                       return (UfNonRec aa ab)
 835               _ -> do ac <- get bh
 836                       return (UfRec ac)
 837
 838 instance (Binary name) => Binary (UfBinder name) where
 839     put_ bh (UfValBinder aa ab) = do
 840             putByte bh 0
 841             put_ bh aa
 842             put_ bh ab
 843     put_ bh (UfTyBinder ac ad) = do
 844             putByte bh 1
 845             put_ bh ac
 846             put_ bh ad
 847     get bh = do
 848             h <- getByte bh
 849             case h of
 850               0 -> do aa <- get bh
 851                       ab <- get bh
 852                       return (UfValBinder aa ab)
 853               _ -> do ac <- get bh
 854                       ad <- get bh
 855                       return (UfTyBinder ac ad)
 856
 857 instance (Binary name) => Binary (HsIdInfo name) where
 858     put_ bh (HsArity aa) = do
 859             putByte bh 0
 860             put_ bh aa
 861     put_ bh (HsStrictness ab) = do
 862             putByte bh 1
 863             put_ bh ab
 864     put_ bh (HsUnfold ac ad) = do
 865             putByte bh 2
 866             put_ bh ac
 867             put_ bh ad
 868     put_ bh HsNoCafRefs = do
 869             putByte bh 3
 870     put_ bh (HsWorker ae af) = do
 871             putByte bh 4
 872             put_ bh ae
 873             put_ bh af
 874     get bh = do
 875             h <- getByte bh
 876             case h of
 877               0 -> do aa <- get bh
 878                       return (HsArity aa)
 879               1 -> do ab <- get bh
 880                       return (HsStrictness ab)
 881               2 -> do ac <- get bh
 882                       ad <- get bh
 883                       return (HsUnfold ac ad)
 884               3 -> do return HsNoCafRefs
 885               _ -> do ae <- get bh
 886                       af <- get bh
 887                       return (HsWorker ae af)
 888
 889 instance (Binary name) => Binary (UfNote name) where
 890     put_ bh (UfSCC aa) = do
 891             putByte bh 0
 892             put_ bh aa
 893     put_ bh (UfCoerce ab) = do
 894             putByte bh 1
 895             put_ bh ab
 896     put_ bh UfInlineCall = do
 897             putByte bh 2
 898     put_ bh UfInlineMe = do
 899             putByte bh 3
 900     get bh = do
 901             h <- getByte bh
 902             case h of
 903               0 -> do aa <- get bh
 904                       return (UfSCC aa)
 905               1 -> do ab <- get bh
 906                       return (UfCoerce ab)
 907               2 -> do return UfInlineCall
 908               _ -> do return UfInlineMe
 909
 910 instance (Binary name) => Binary (BangType name) where
 911     put_ bh (BangType aa ab) = do
 912             put_ bh aa
 913             put_ bh ab
 914     get bh = do
 915           aa <- get bh
 916           ab <- get bh
 917           return (BangType aa ab)
 918
 919 instance (Binary name) => Binary (ConDetails name) where
 920     put_ bh (VanillaCon aa) = do
 921             putByte bh 0
 922             put_ bh aa
 923     put_ bh (InfixCon ab ac) = do
 924             putByte bh 1
 925             put_ bh ab
 926             put_ bh ac
 927     put_ bh (RecCon ad) = do
 928             putByte bh 2
 929             put_ bh ad
 930     get bh = do
 931             h <- getByte bh
 932             case h of
 933               0 -> do aa <- get bh
 934                       return (VanillaCon aa)
 935               1 -> do ab <- get bh
 936                       ac <- get bh
 937                       return (InfixCon ab ac)
 938               _ -> do ad <- get bh
 939                       return (RecCon ad)
 940
 941 instance (Binary datacon) => Binary (DataConDetails datacon) where
 942     put_ bh (DataCons aa) = do
 943             putByte bh 0
 944             put_ bh aa
 945     put_ bh Unknown = do
 946             putByte bh 1
 947     put_ bh (HasCons ab) = do
 948             putByte bh 2
 949             put_ bh ab
 950     get bh = do
 951             h <- getByte bh
 952             case h of
 953               0 -> do aa <- get bh
 954                       return (DataCons aa)
 955               1 -> do return Unknown
 956               _ -> do ab <- get bh
 957                       return (HasCons ab)
 958
 959 instance (Binary id) => Binary (DefMeth id) where
 960     put_ bh NoDefMeth = do
 961             putByte bh 0
 962     put_ bh (DefMeth aa) = do
 963             putByte bh 1
 964             put_ bh aa
 965     put_ bh GenDefMeth = do
 966             putByte bh 2
 967     get bh = do
 968             h <- getByte bh
 969             case h of
 970               0 -> do return NoDefMeth
 971               1 -> do aa <- get bh
 972                       return (DefMeth aa)
 973               _ -> do return GenDefMeth
 974
 975 instance Binary IsCafCC where
 976     put_ bh CafCC = do
 977             putByte bh 0
 978     put_ bh NotCafCC = do
 979             putByte bh 1
 980     get bh = do
 981             h <- getByte bh
 982             case h of
 983               0 -> do return CafCC
 984               _ -> do return NotCafCC
 985
 986 instance Binary IsDupdCC where
 987     put_ bh OriginalCC = do
 988             putByte bh 0
 989     put_ bh DupdCC = do
 990             putByte bh 1
 991     get bh = do
 992             h <- getByte bh
 993             case h of
 994               0 -> do return OriginalCC
 995               _ -> do return DupdCC
 996
 997 instance Binary CostCentre where
 998     put_ bh NoCostCentre = do
 999             putByte bh 0
1000     put_ bh (NormalCC aa ab ac ad) = do
1001             putByte bh 1
1002             put_ bh aa
1003             put_ bh ab
1004             put_ bh ac
1005             put_ bh ad
1006     put_ bh (AllCafsCC ae) = do
1007             putByte bh 2
1008             put_ bh ae
1009     get bh = do
1010             h <- getByte bh
1011             case h of
1012               0 -> do return NoCostCentre
1013               1 -> do aa <- get bh
1014                       ab <- get bh
1015                       ac <- get bh
1016                       ad <- get bh
1017                       return (NormalCC aa ab ac ad)
1018               _ -> do ae <- get bh
1019                       return (AllCafsCC ae)
1020
1021