BinIface.hs 26.5 KB
Newer Older
1 2 3 4 5 6 7
{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
-- 
--  (c) The University of Glasgow 2002
-- 
-- Binary interface file support.

8
module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where
9

10 11
#include "HsVersions.h"

12 13 14 15 16 17 18
import HscTypes
import BasicTypes
import NewDemand
import HsTypes
import HsCore
import HsDecls
import HsBinds
19
import HsPat		( HsConDetails(..) )
20 21 22 23
import TyCon
import Class
import VarEnv
import CostCentre
24 25
import RdrName		( mkRdrUnqual, mkRdrQual )
import Name		( Name, nameOccName, nameModule_maybe )
26
import NameEnv		( NameEnv, lookupNameEnv, nameEnvElts )
27
import Module		( moduleName )
28 29 30 31 32 33 34
import OccName		( OccName )
import RnHsSyn
import DriverState	( v_Build_tag )
import CmdLineOpts	( opt_IgnoreIfacePragmas, opt_HiVersion )
import Panic
import SrcLoc
import Binary
35
import Util
36

37
import DATA_IOREF
38 39
import EXCEPTION	( throwDyn )
import Monad		( when )
40

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
#include "HsVersions.h"

-- ---------------------------------------------------------------------------
-- We write out a ModIface, but read it in as a ParsedIface.
-- There are some big differences, and some subtle ones.  We do most
-- of the conversion on the way out, so there is minimal fuss when we
-- read it back in again (see RnMonad.lhs)

-- The main difference is that all Names in a ModIface are RdrNames in
-- a ParsedIface, so when writing out a Name in binary we make sure it
-- is binary-compatible with a RdrName.

-- Other subtle differences: 
--	- pi_mod is a ModuleName, but mi_mod is a Module.  Hence we put
--	  Modules as ModuleNames.
--	- pi_exports and pi_usages, Names have
-- 	  to be converted to OccNames.
--	- pi_fixity is a NameEnv in ModIface,
-- 	  but a list of (Name,Fixity) pairs in ParsedIface.
--	- versioning is totally different.
--	- deprecations are different.

writeBinIface :: FilePath -> ModIface -> IO ()
writeBinIface hi_path mod_iface
  = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface

readBinIface :: FilePath -> IO ParsedIface
readBinIface hi_path = getBinFileWithDict hi_path


-- %*********************************************************
-- %*						 	    *
-- 		All the Binary instances
-- %*							    *
-- %*********************************************************

77 78 79 80 81 82 83 84 85
-- BasicTypes
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for FixityDirection derive: Binary !-}
{-! for NewOrData derive: Binary !-}
{-! for Boxity derive: Binary !-}
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}

86 87 88 89 90 91 92 93 94 95 96 97 98 99
instance Binary Name where
  -- we must print these as RdrNames, because that's how they will be read in
  put_ bh name
   = case nameModule_maybe name of
       Just mod
	  | this_mod == mod -> put_ bh (mkRdrUnqual occ)
	  | otherwise       -> put_ bh (mkRdrQual (moduleName mod) occ)
       _ 		    -> put_ bh (mkRdrUnqual occ)
    where
      occ 	       = nameOccName name
      (this_mod,_,_,_) = getUserData bh

  get bh = error "can't Binary.get a Name"    

100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
-- NewDemand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for DmdResult derive: Binary !-}
{-! for StrictSig derive: Binary !-}

instance Binary DmdType where
	-- ignore DmdEnv when spitting out the DmdType
  put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
  get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)

-- TyCon
{-! for DataConDetails derive: Binary !-}

-- Class
{-! for DefMeth derive: Binary !-}

-- HsTypes
{-! for HsPred derive: Binary !-}
{-! for HsType derive: Binary !-}
{-! for HsTupCon derive: Binary !-}
{-! for HsTyVarBndr derive: Binary !-}

-- HsCore
{-! for UfExpr derive: Binary !-}
{-! for UfConAlt derive: Binary !-}
{-! for UfBinding derive: Binary !-}
{-! for UfBinder derive: Binary !-}
{-! for HsIdInfo derive: Binary !-}
{-! for UfNote derive: Binary !-}

-- HsDecls
{-! for ConDetails derive: Binary !-}
{-! for BangType derive: Binary !-}

135
instance (Binary name) => Binary (TyClDecl name) where
136 137 138 139 140 141 142
    put_ bh (IfaceSig name ty idinfo _) = do
	    putByte bh 0
	    put_ bh name
	    lazyPut bh ty
	    lazyPut bh idinfo
    put_ bh (ForeignType ae af ag ah) = 
	error "Binary.put_(TyClDecl): ForeignType"
143
    put_ bh (TyData ai aj ak al am _ (Just generics) _) = do
144 145 146 147 148 149 150
	    putByte bh 2
	    put_ bh ai
	    put_ bh aj
	    put_ bh ak
	    put_ bh al
	    put_ bh am
	    -- ignore Derivs
151
	    put_ bh generics -- Record whether generics needed or not
152 153 154 155 156
    put_ bh (TySynonym aq ar as _) = do
	    putByte bh 3
	    put_ bh aq
	    put_ bh ar
	    put_ bh as
157
    put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182
	    putByte bh 4
	    put_ bh ctxt
	    put_ bh nm
	    put_ bh tyvars
	    put_ bh fds
	    put_ bh sigs
		-- ignore methods (there should be none)
		-- ignore SrcLoc
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do
		    name <- get bh
		    ty <- lazyGet bh
		    idinfo <- lazyGet bh
		    let idinfo' | opt_IgnoreIfacePragmas = []
			        | otherwise = idinfo
		    return (IfaceSig name ty idinfo' noSrcLoc)
	      1 -> error "Binary.get(TyClDecl): ForeignType"
	      2 -> do
		    n_or_d <- get bh
		    ctx    <- get bh
		    nm     <- get bh
		    tyvars <- get bh
		    cons   <- get bh
183
		    generics <- get bh
184
		    return (TyData n_or_d ctx nm tyvars cons 
185
				Nothing (Just generics) noSrcLoc)
186 187 188 189 190 191 192 193 194 195 196 197
	      3 -> do
		    aq <- get bh
		    ar <- get bh
		    as <- get bh
		    return (TySynonym aq ar as noSrcLoc)
	      _ -> do
		    ctxt <- get bh
		    nm <- get bh
		    tyvars <- get bh
		    fds <- get bh
		    sigs <- get bh
		    return (ClassDecl ctxt nm tyvars fds sigs 
198
				      Nothing noSrcLoc)
199 200

instance (Binary name) => Binary (ConDecl name) where
201
    put_ bh (ConDecl aa ac ad ae _) = do
202 203 204 205 206 207 208 209 210 211
	    put_ bh aa
	    put_ bh ac
	    put_ bh ad
	    put_ bh ae
		-- ignore SrcLoc
    get bh = do
	  aa <- get bh
	  ac <- get bh
	  ad <- get bh
	  ae <- get bh
212
	  return (ConDecl aa ac ad ae noSrcLoc)
213

214
instance (Binary name) => Binary (InstDecl name) where
215 216 217 218 219 220 221 222 223 224 225
    put_ bh (InstDecl aa _ _ ad _) = do
	    put_ bh aa
		-- ignore MonoBinds
		-- ignore Sigs
	    put_ bh ad
		-- ignore SrcLoc
    get bh = do
	  aa <- get bh
	  ad <- get bh
	  return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)

226
instance (Binary name) => Binary (RuleDecl name) where
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
    put_ bh (IfaceRule ag ah ai aj ak al _) = do
	    put_ bh ag
	    put_ bh ah
	    put_ bh ai
	    put_ bh aj
	    put_ bh ak
	    put_ bh al
		-- ignore SrcLoc
    get bh = do     ag <- get bh
		    ah <- get bh
		    ai <- get bh
		    aj <- get bh
		    ak <- get bh
		    al <- get bh
		    return (IfaceRule ag ah ai aj ak al noSrcLoc)

instance (Binary name) => Binary (DeprecDecl name) where
    put_ bh (Deprecation aa ab _) = do
	    put_ bh aa
	    put_ bh ab
		-- ignore SrcLoc
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (Deprecation aa ab noSrcLoc)

-- HsBinds
instance Binary name => Binary (Sig name) where
   put_ bh (ClassOpSig n def ty _) = do	put_ bh n; put_ bh def;	put_ bh ty
   get bh = do
	n <- get bh
	def <- get bh
	ty <- get bh
	return (ClassOpSig n def ty noSrcLoc)

-- CostCentre
{-! for IsCafCC derive: Binary !-}
{-! for IsDupdCC derive: Binary !-}
{-! for CostCentre derive: Binary !-}



instance Binary ModIface where
  put_ bh iface =  do
	build_tag <- readIORef v_Build_tag
	put_ bh (show opt_HiVersion ++ build_tag)
273
	p <- put_ bh (moduleName (mi_module iface))
274 275 276 277
	put_ bh (mi_package iface)
	put_ bh (vers_module (mi_version iface))
	put_ bh (mi_orphan iface)
	-- no: mi_boot
278 279
	lazyPut bh (mi_deps iface)
	lazyPut bh (map usageToOccName (mi_usages iface))
280 281 282 283 284 285 286 287 288 289 290
	put_ bh (vers_exports (mi_version iface),
		 map exportItemToRdrExportItem (mi_exports iface))
	put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
			(vers_decls (mi_version iface)))
	-- no: mi_globals
	put_ bh (collectFixities (mi_fixities iface) 
				 (dcl_tycl (mi_decls iface)))
	put_ bh (dcl_insts (mi_decls iface))
	lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
	lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))

291
  -- Read in as a ParsedIface, not a ModIface.  See above.
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
  get bh = error "Binary.get: ModIface"

declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
   -> [(Version, RenamedTyClDecl)]
declsToVersionedDecls decls env 
  = map add_vers decls
  where add_vers d = 
	   case lookupNameEnv env (tyClDeclName d) of
		Nothing -> (initialVersion, d)
		Just v  -> (v, d)


--NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
deprecsToIfaceDeprecs NoDeprecs = Nothing
deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))


{-! for GenAvailInfo derive: Binary !-}
{-! for WhatsImported derive: Binary !-}

-- For binary interfaces we need to convert the ImportVersion Names to OccNames
314 315 316
usageToOccName :: Usage Name -> Usage OccName
usageToOccName usg
  = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] }
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348

exportItemToRdrExportItem (mn, avails) 
  = (mn, map availInfoToRdrAvailInfo avails)

availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
availInfoToRdrAvailInfo (Avail n)
   = Avail (nameOccName n)
availInfoToRdrAvailInfo (AvailTC n ns)
  = AvailTC (nameOccName n) (map nameOccName ns)

-- ---------------------------------------------------------------------------
-- Reading a binary interface into ParsedIface

instance Binary ParsedIface where
   put_ bh ParsedIface{
		 pi_mod = module_name,
		 pi_pkg = pkg_name,
		 pi_vers = module_ver,
		 pi_orphan = orphan,
		 pi_usages = usages,
		 pi_exports = exports,
		 pi_decls = tycl_decls,
		 pi_fixity = fixities,
		 pi_insts = insts,
		 pi_rules = rules,
		 pi_deprecs = deprecs } = do
	build_tag <- readIORef v_Build_tag
	put_ bh (show opt_HiVersion ++ build_tag)
	put_ bh module_name
	put_ bh pkg_name
	put_ bh module_ver
	put_ bh orphan
349
	lazyPut bh usages
350 351 352 353 354 355 356 357
	put_ bh exports
        put_ bh tycl_decls
	put_ bh fixities
	put_ bh insts
	lazyPut bh rules
	lazyPut bh deprecs
   get bh = do
	check_ver   <- get bh
358
        ignore_ver <- readIORef v_IgnoreHiVersion
359 360
	build_tag <- readIORef v_Build_tag
 	let our_ver = show opt_HiVersion ++ build_tag
361
        when (check_ver /= our_ver && not ignore_ver) $
362 363 364 365 366 367 368 369 370
	   -- use userError because this will be caught by readIface
	   -- which will emit an error msg containing the iface module name.
	   throwDyn (ProgramError (
		"mismatched interface file versions: expected "
		++ our_ver ++ ", found " ++ check_ver))
	module_name <- get bh		-- same rep. as Module, so that's ok
	pkg_name    <- get bh
	module_ver  <- get bh
	orphan      <- get bh
371
	deps	    <- lazyGet bh
sof's avatar
sof committed
372
	usages	    <- {-# SCC "bin_usages" #-} lazyGet bh
373 374 375 376 377 378
	exports	    <- {-# SCC "bin_exports" #-} get bh
        tycl_decls  <- {-# SCC "bin_tycldecls" #-} get bh
	fixities    <- {-# SCC "bin_fixities" #-} get bh
	insts       <- {-# SCC "bin_insts" #-} get bh
	rules	    <- {-# SCC "bin_rules" #-} lazyGet bh
	deprecs     <- {-# SCC "bin_deprecs" #-} lazyGet bh
379 380 381 382 383
	return (ParsedIface {
		 pi_mod = module_name,
		 pi_pkg = pkg_name,
		 pi_vers = module_ver,
		 pi_orphan = orphan,
384
		 pi_deps = deps,
385 386 387 388 389 390 391 392
		 pi_usages = usages,
		 pi_exports = exports,
		 pi_decls = tycl_decls,
		 pi_fixity = fixities,
		 pi_insts = reverse insts,
		 pi_rules = rules,
		 pi_deprecs = deprecs })

393 394
GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)

395 396 397 398 399
-- ----------------------------------------------------------------------------
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}

--  Imported from other files :-

400 401 402 403 404 405 406 407 408 409
instance Binary Dependencies where
    put_ bh deps = do put_ bh (dep_mods deps)
		      put_ bh (dep_pkgs deps)
		      put_ bh (dep_orphs deps)

    get bh = do ms <- get bh 
		ps <- get bh
		os <- get bh
		return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })

410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426
instance (Binary name) => Binary (GenAvailInfo name) where
    put_ bh (Avail aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (AvailTC ab ac) = do
	    putByte bh 1
	    put_ bh ab
	    put_ bh ac
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (Avail aa)
	      _ -> do ab <- get bh
		      ac <- get bh
		      return (AvailTC ab ac)

427 428 429 430 431 432 433 434
instance (Binary name) => Binary (Usage name) where
    put_ bh usg	= do 
	put_ bh (usg_name     usg)
	put_ bh (usg_mod      usg)
	put_ bh (usg_exports  usg)
	put_ bh (usg_entities usg)
	put_ bh (usg_rules    usg)

435
    get bh = do
436 437 438 439 440 441 442 443
	nm    <- get bh
	mod   <- get bh
	exps  <- get bh
	ents  <- get bh
	rules <- get bh
	return (Usage {	usg_name = nm, usg_mod = mod,
			usg_exports = exps, usg_entities = ents,
			usg_rules = rules })
444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527

instance Binary Activation where
    put_ bh NeverActive = do
	    putByte bh 0
    put_ bh AlwaysActive = do
	    putByte bh 1
    put_ bh (ActiveBefore aa) = do
	    putByte bh 2
	    put_ bh aa
    put_ bh (ActiveAfter ab) = do
	    putByte bh 3
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return NeverActive
	      1 -> do return AlwaysActive
	      2 -> do aa <- get bh
		      return (ActiveBefore aa)
	      _ -> do ab <- get bh
		      return (ActiveAfter ab)

instance Binary StrictnessMark where
    put_ bh MarkedUserStrict = do
	    putByte bh 0
    put_ bh MarkedStrict = do
	    putByte bh 1
    put_ bh MarkedUnboxed = do
	    putByte bh 2
    put_ bh NotMarkedStrict = do
	    putByte bh 3
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return MarkedUserStrict
	      1 -> do return MarkedStrict
	      2 -> do return MarkedUnboxed
	      _ -> do return NotMarkedStrict

instance Binary Boxity where
    put_ bh Boxed = do
	    putByte bh 0
    put_ bh Unboxed = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return Boxed
	      _ -> do return Unboxed

instance Binary NewOrData where
    put_ bh NewType = do
	    putByte bh 0
    put_ bh DataType = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return NewType
	      _ -> do return DataType

instance Binary FixityDirection where
    put_ bh InfixL = do
	    putByte bh 0
    put_ bh InfixR = do
	    putByte bh 1
    put_ bh InfixN = do
	    putByte bh 2
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return InfixL
	      1 -> do return InfixR
	      _ -> do return InfixN

instance Binary Fixity where
    put_ bh (Fixity aa ab) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (Fixity aa ab)

528 529 530 531 532 533 534 535 536
instance (Binary name) => Binary (FixitySig name) where
    put_ bh (FixitySig aa ab _) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (FixitySig aa ab noSrcLoc)

537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611
instance (Binary name) => Binary (IPName name) where
    put_ bh (Dupable aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (Linear ab) = do
	    putByte bh 1
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (Dupable aa)
	      _ -> do ab <- get bh
		      return (Linear ab)

instance Binary Demand where
    put_ bh Top = do
	    putByte bh 0
    put_ bh Abs = do
	    putByte bh 1
    put_ bh (Call aa) = do
	    putByte bh 2
	    put_ bh aa
    put_ bh (Eval ab) = do
	    putByte bh 3
	    put_ bh ab
    put_ bh (Defer ac) = do
	    putByte bh 4
	    put_ bh ac
    put_ bh (Box ad) = do
	    putByte bh 5
	    put_ bh ad
    put_ bh Bot = do
	    putByte bh 6
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return Top
	      1 -> do return Abs
	      2 -> do aa <- get bh
		      return (Call aa)
	      3 -> do ab <- get bh
		      return (Eval ab)
	      4 -> do ac <- get bh
		      return (Defer ac)
	      5 -> do ad <- get bh
		      return (Box ad)
	      _ -> do return Bot

instance Binary Demands where
    put_ bh (Poly aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (Prod ab) = do
	    putByte bh 1
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (Poly aa)
	      _ -> do ab <- get bh
		      return (Prod ab)

instance Binary DmdResult where
    put_ bh TopRes = do
	    putByte bh 0
    put_ bh RetCPR = do
	    putByte bh 1
    put_ bh BotRes = do
	    putByte bh 2
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return TopRes
612 613 614
	      1 -> do return RetCPR	-- Really use RetCPR even if -fcpr-off
					-- The wrapper was generated for CPR in 
					-- the imported module!
615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640
	      _ -> do return BotRes

instance Binary StrictSig where
    put_ bh (StrictSig aa) = do
	    put_ bh aa
    get bh = do
	  aa <- get bh
	  return (StrictSig aa)

instance (Binary name) => Binary (HsTyVarBndr name) where
    put_ bh (UserTyVar aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (IfaceTyVar ab ac) = do
	    putByte bh 1
	    put_ bh ab
	    put_ bh ac
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (UserTyVar aa)
	      _ -> do ab <- get bh
		      ac <- get bh
		      return (IfaceTyVar ab ac)

641 642
instance Binary HsTupCon where
    put_ bh (HsTupCon ab ac) = do
643 644 645 646 647
	    put_ bh ab
	    put_ bh ac
    get bh = do
	  ab <- get bh
	  ac <- get bh
648
	  return (HsTupCon ab ac)
649

650 651 652 653 654 655 656 657 658 659 660
instance (Binary name) => Binary (HsTyOp name) where
    put_ bh HsArrow    = putByte bh 0
    put_ bh (HsTyOp n) = do putByte bh 1
			    put_ bh n

    get bh = do h <- getByte bh
		case h of
		  0 -> return HsArrow
		  1 -> do a <- get bh
		          return (HsTyOp a)

661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942
instance (Binary name) => Binary (HsType name) where
    put_ bh (HsForAllTy aa ab ac) = do
	    putByte bh 0
	    put_ bh aa
	    put_ bh ab
	    put_ bh ac
    put_ bh (HsTyVar ad) = do
	    putByte bh 1
	    put_ bh ad
    put_ bh (HsAppTy ae af) = do
	    putByte bh 2
	    put_ bh ae
	    put_ bh af
    put_ bh (HsFunTy ag ah) = do
	    putByte bh 3
	    put_ bh ag
	    put_ bh ah
    put_ bh (HsListTy ai) = do
	    putByte bh 4
	    put_ bh ai
    put_ bh (HsPArrTy aj) = do
	    putByte bh 5
	    put_ bh aj
    put_ bh (HsTupleTy ak al) = do
	    putByte bh 6
	    put_ bh ak
	    put_ bh al
    put_ bh (HsOpTy am an ao) = do
	    putByte bh 7
	    put_ bh am
	    put_ bh an
	    put_ bh ao
    put_ bh (HsNumTy ap) = do
	    putByte bh 8
	    put_ bh ap
    put_ bh (HsPredTy aq) = do
	    putByte bh 9
	    put_ bh aq
    put_ bh (HsKindSig ar as) = do
	    putByte bh 10
	    put_ bh ar
	    put_ bh as
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      ab <- get bh
		      ac <- get bh
		      return (HsForAllTy aa ab ac)
	      1 -> do ad <- get bh
		      return (HsTyVar ad)
	      2 -> do ae <- get bh
		      af <- get bh
		      return (HsAppTy ae af)
	      3 -> do ag <- get bh
		      ah <- get bh
		      return (HsFunTy ag ah)
	      4 -> do ai <- get bh
		      return (HsListTy ai)
	      5 -> do aj <- get bh
		      return (HsPArrTy aj)
	      6 -> do ak <- get bh
		      al <- get bh
		      return (HsTupleTy ak al)
	      7 -> do am <- get bh
		      an <- get bh
		      ao <- get bh
		      return (HsOpTy am an ao)
	      8 -> do ap <- get bh
		      return (HsNumTy ap)
	      9 -> do aq <- get bh
		      return (HsPredTy aq)
	      _ -> do ar <- get bh
		      as <- get bh
		      return (HsKindSig ar as)

instance (Binary name) => Binary (HsPred name) where
    put_ bh (HsClassP aa ab) = do
	    putByte bh 0
	    put_ bh aa
	    put_ bh ab
    put_ bh (HsIParam ac ad) = do
	    putByte bh 1
	    put_ bh ac
	    put_ bh ad
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      ab <- get bh
		      return (HsClassP aa ab)
	      _ -> do ac <- get bh
		      ad <- get bh
		      return (HsIParam ac ad)

instance (Binary name) => Binary (UfExpr name) where
    put_ bh (UfVar aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (UfType ab) = do
	    putByte bh 1
	    put_ bh ab
    put_ bh (UfTuple ac ad) = do
	    putByte bh 2
	    put_ bh ac
	    put_ bh ad
    put_ bh (UfLam ae af) = do
	    putByte bh 3
	    put_ bh ae
	    put_ bh af
    put_ bh (UfApp ag ah) = do
	    putByte bh 4
	    put_ bh ag
	    put_ bh ah
    put_ bh (UfCase ai aj ak) = do
	    putByte bh 5
	    put_ bh ai
	    put_ bh aj
	    put_ bh ak
    put_ bh (UfLet al am) = do
	    putByte bh 6
	    put_ bh al
	    put_ bh am
    put_ bh (UfNote an ao) = do
	    putByte bh 7
	    put_ bh an
	    put_ bh ao
    put_ bh (UfLit ap) = do
	    putByte bh 8
	    put_ bh ap
    put_ bh (UfLitLit aq ar) = do
	    putByte bh 9
	    put_ bh aq
	    put_ bh ar
    put_ bh (UfFCall as at) = do
	    putByte bh 10
	    put_ bh as
	    put_ bh at
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (UfVar aa)
	      1 -> do ab <- get bh
		      return (UfType ab)
	      2 -> do ac <- get bh
		      ad <- get bh
		      return (UfTuple ac ad)
	      3 -> do ae <- get bh
		      af <- get bh
		      return (UfLam ae af)
	      4 -> do ag <- get bh
		      ah <- get bh
		      return (UfApp ag ah)
	      5 -> do ai <- get bh
		      aj <- get bh
		      ak <- get bh
		      return (UfCase ai aj ak)
	      6 -> do al <- get bh
		      am <- get bh
		      return (UfLet al am)
	      7 -> do an <- get bh
		      ao <- get bh
		      return (UfNote an ao)
	      8 -> do ap <- get bh
		      return (UfLit ap)
	      9 -> do aq <- get bh
		      ar <- get bh
		      return (UfLitLit aq ar)
	      _ -> do as <- get bh
		      at <- get bh
		      return (UfFCall as at)

instance (Binary name) => Binary (UfConAlt name) where
    put_ bh UfDefault = do
	    putByte bh 0
    put_ bh (UfDataAlt aa) = do
	    putByte bh 1
	    put_ bh aa
    put_ bh (UfTupleAlt ab) = do
	    putByte bh 2
	    put_ bh ab
    put_ bh (UfLitAlt ac) = do
	    putByte bh 3
	    put_ bh ac
    put_ bh (UfLitLitAlt ad ae) = do
	    putByte bh 4
	    put_ bh ad
	    put_ bh ae
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return UfDefault
	      1 -> do aa <- get bh
		      return (UfDataAlt aa)
	      2 -> do ab <- get bh
		      return (UfTupleAlt ab)
	      3 -> do ac <- get bh
		      return (UfLitAlt ac)
	      _ -> do ad <- get bh
		      ae <- get bh
		      return (UfLitLitAlt ad ae)

instance (Binary name) => Binary (UfBinding name) where
    put_ bh (UfNonRec aa ab) = do
	    putByte bh 0
	    put_ bh aa
	    put_ bh ab
    put_ bh (UfRec ac) = do
	    putByte bh 1
	    put_ bh ac
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      ab <- get bh
		      return (UfNonRec aa ab)
	      _ -> do ac <- get bh
		      return (UfRec ac)

instance (Binary name) => Binary (UfBinder name) where
    put_ bh (UfValBinder aa ab) = do
	    putByte bh 0
	    put_ bh aa
	    put_ bh ab
    put_ bh (UfTyBinder ac ad) = do
	    putByte bh 1
	    put_ bh ac
	    put_ bh ad
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      ab <- get bh
		      return (UfValBinder aa ab)
	      _ -> do ac <- get bh
		      ad <- get bh
		      return (UfTyBinder ac ad)

instance (Binary name) => Binary (HsIdInfo name) where
    put_ bh (HsArity aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (HsStrictness ab) = do
	    putByte bh 1
	    put_ bh ab
    put_ bh (HsUnfold ac ad) = do
	    putByte bh 2
	    put_ bh ac
	    put_ bh ad
    put_ bh HsNoCafRefs = do
	    putByte bh 3
    put_ bh (HsWorker ae af) = do
	    putByte bh 4
	    put_ bh ae
	    put_ bh af
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (HsArity aa)
	      1 -> do ab <- get bh
		      return (HsStrictness ab)
	      2 -> do ac <- get bh
		      ad <- get bh
		      return (HsUnfold ac ad)
	      3 -> do return HsNoCafRefs
	      _ -> do ae <- get bh
		      af <- get bh
		      return (HsWorker ae af)

instance (Binary name) => Binary (UfNote name) where
    put_ bh (UfSCC aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (UfCoerce ab) = do
	    putByte bh 1
	    put_ bh ab
    put_ bh UfInlineCall = do
	    putByte bh 2
    put_ bh UfInlineMe = do
	    putByte bh 3
943 944 945
    put_ bh (UfCoreNote s) = do
            putByte bh 4
            put_ bh s
946 947 948 949 950 951 952 953
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (UfSCC aa)
	      1 -> do ab <- get bh
		      return (UfCoerce ab)
	      2 -> do return UfInlineCall
954 955 956
	      3 -> do return UfInlineMe
              _ -> do ac <- get bh
                      return (UfCoreNote ac)
957 958 959 960 961 962 963 964 965 966

instance (Binary name) => Binary (BangType name) where
    put_ bh (BangType aa ab) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (BangType aa ab)

967 968
instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
    put_ bh (PrefixCon aa) = do
969 970 971 972 973 974 975 976 977 978 979 980 981
	    putByte bh 0
	    put_ bh aa
    put_ bh (InfixCon ab ac) = do
	    putByte bh 1
	    put_ bh ab
	    put_ bh ac
    put_ bh (RecCon ad) = do
	    putByte bh 2
	    put_ bh ad
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
982
		      return (PrefixCon aa)
983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067
	      1 -> do ab <- get bh
		      ac <- get bh
		      return (InfixCon ab ac)
	      _ -> do ad <- get bh
		      return (RecCon ad)

instance (Binary datacon) => Binary (DataConDetails datacon) where
    put_ bh (DataCons aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh Unknown = do
	    putByte bh 1
    put_ bh (HasCons ab) = do
	    putByte bh 2
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (DataCons aa)
	      1 -> do return Unknown
	      _ -> do ab <- get bh
		      return (HasCons ab)

instance (Binary id) => Binary (DefMeth id) where
    put_ bh NoDefMeth = do
	    putByte bh 0
    put_ bh (DefMeth aa) = do
	    putByte bh 1
	    put_ bh aa
    put_ bh GenDefMeth = do
	    putByte bh 2
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return NoDefMeth
	      1 -> do aa <- get bh
		      return (DefMeth aa)
	      _ -> do return GenDefMeth

instance Binary IsCafCC where
    put_ bh CafCC = do
	    putByte bh 0
    put_ bh NotCafCC = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CafCC
	      _ -> do return NotCafCC

instance Binary IsDupdCC where
    put_ bh OriginalCC = do
	    putByte bh 0
    put_ bh DupdCC = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return OriginalCC
	      _ -> do return DupdCC

instance Binary CostCentre where
    put_ bh NoCostCentre = do
	    putByte bh 0
    put_ bh (NormalCC aa ab ac ad) = do
	    putByte bh 1
	    put_ bh aa
	    put_ bh ab
	    put_ bh ac
	    put_ bh ad
    put_ bh (AllCafsCC ae) = do
	    putByte bh 2
	    put_ bh ae
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return NoCostCentre
	      1 -> do aa <- get bh
		      ab <- get bh
		      ac <- get bh
		      ad <- get bh
		      return (NormalCC aa ab ac ad)
	      _ -> do ae <- get bh
		      return (AllCafsCC ae)