+++ /dev/null
-{-% 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.
-
-module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
-
-#include "HsVersions.h"
-
-import HscTypes
-import BasicTypes
-import NewDemand
-import IfaceSyn
-import VarEnv
-import InstEnv ( OverlapFlag(..) )
-import Packages ( PackageIdH(..) )
-import Class ( DefMeth(..) )
-import CostCentre
-import StaticFlags ( opt_HiVersion, v_Build_tag )
-import Kind ( Kind(..) )
-import Panic
-import Binary
-import Util
-import Config ( cGhcUnregisterised )
-
-import DATA_IOREF
-import EXCEPTION ( throwDyn )
-import Monad ( when )
-import Outputable
-
-#include "HsVersions.h"
-
--- ---------------------------------------------------------------------------
-writeBinIface :: FilePath -> ModIface -> IO ()
-writeBinIface hi_path mod_iface
- = putBinFileWithDict hi_path mod_iface
-
-readBinIface :: FilePath -> IO ModIface
-readBinIface hi_path = getBinFileWithDict hi_path
-
-
--- %*********************************************************
--- %* *
--- All the Binary instances
--- %* *
--- %*********************************************************
-
--- BasicTypes
-{-! for IPName derive: Binary !-}
-{-! for Fixity derive: Binary !-}
-{-! for FixityDirection derive: Binary !-}
-{-! for Boxity derive: Binary !-}
-{-! for StrictnessMark derive: Binary !-}
-{-! for Activation derive: Binary !-}
-
--- NewDemand
-{-! for Demand derive: Binary !-}
-{-! for Demands derive: Binary !-}
-{-! for DmdResult derive: Binary !-}
-{-! for StrictSig derive: Binary !-}
-
--- Class
-{-! for DefMeth derive: Binary !-}
-
--- HsTypes
-{-! for HsPred derive: Binary !-}
-{-! for HsType derive: Binary !-}
-{-! for TupCon 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 !-}
-
--- CostCentre
-{-! for IsCafCC derive: Binary !-}
-{-! for IsDupdCC derive: Binary !-}
-{-! for CostCentre derive: Binary !-}
-
-
-
--- ---------------------------------------------------------------------------
--- Reading a binary interface into ParsedIface
-
-instance Binary ModIface where
- put_ bh (ModIface {
- mi_module = mod,
- mi_boot = is_boot,
- mi_mod_vers = mod_vers,
- mi_package = _, -- we ignore the package on output
- mi_orphan = orphan,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_exp_vers = exp_vers,
- mi_fixities = fixities,
- mi_deprecs = deprecs,
- mi_decls = decls,
- mi_insts = insts,
- mi_rules = rules,
- mi_rule_vers = rule_vers }) = do
- put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
- put bh way_descr
- put_ bh mod
- put_ bh is_boot
- put_ bh mod_vers
- put_ bh orphan
- lazyPut bh deps
- lazyPut bh usages
- put_ bh exports
- put_ bh exp_vers
- put_ bh fixities
- lazyPut bh deprecs
- put_ bh decls
- put_ bh insts
- lazyPut bh rules
- put_ bh rule_vers
-
- get bh = do
- check_ver <- get bh
- let our_ver = show opt_HiVersion
- when (check_ver /= our_ver) $
- -- 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))
-
- check_way <- get bh
- ignore_way <- readIORef v_IgnoreHiWay
- way_descr <- getWayDescr
- when (not ignore_way && check_way /= way_descr) $
- -- 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 ways: expected "
- ++ way_descr ++ ", found " ++ check_way))
-
- mod_name <- get bh
- is_boot <- get bh
- mod_vers <- get bh
- orphan <- get bh
- deps <- lazyGet bh
- usages <- {-# SCC "bin_usages" #-} lazyGet bh
- exports <- {-# SCC "bin_exports" #-} get bh
- exp_vers <- get bh
- fixities <- {-# SCC "bin_fixities" #-} get bh
- deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
- decls <- {-# SCC "bin_tycldecls" #-} get bh
- insts <- {-# SCC "bin_insts" #-} get bh
- rules <- {-# SCC "bin_rules" #-} lazyGet bh
- rule_vers <- get bh
- return (ModIface {
- mi_package = HomePackage, -- to be filled in properly later
- mi_module = mod_name,
- mi_boot = is_boot,
- mi_mod_vers = mod_vers,
- mi_orphan = orphan,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_exp_vers = exp_vers,
- mi_fixities = fixities,
- mi_deprecs = deprecs,
- mi_decls = decls,
- mi_globals = Nothing,
- mi_insts = insts,
- mi_rules = rules,
- mi_rule_vers = rule_vers,
- -- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
- mi_fix_fn = mkIfaceFixCache fixities,
- mi_ver_fn = mkIfaceVerCache decls })
-
-GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
-
-getWayDescr :: IO String
-getWayDescr = do
- tag <- readIORef v_Build_tag
- if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
- -- if this is an unregisterised build, make sure our interfaces
- -- can't be used by a registerised build.
-
--------------------------------------------------------------------------
--- Types from: HscTypes
--------------------------------------------------------------------------
-
-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 })
-
-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)
-
-instance Binary Usage 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)
-
- get bh = do
- 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 })
-
-instance Binary a => Binary (Deprecs a) where
- put_ bh NoDeprecs = putByte bh 0
- put_ bh (DeprecAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (DeprecSome ts) = do
- putByte bh 2
- put_ bh ts
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoDeprecs
- 1 -> do aa <- get bh
- return (DeprecAll aa)
- _ -> do aa <- get bh
- return (DeprecSome aa)
-
--------------------------------------------------------------------------
--- Types from: BasicTypes
--------------------------------------------------------------------------
-
-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 MarkedStrict = do
- putByte bh 0
- put_ bh MarkedUnboxed = do
- putByte bh 1
- put_ bh NotMarkedStrict = do
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return MarkedStrict
- 1 -> 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 TupCon where
- put_ bh (TupCon ab ac) = do
- put_ bh ab
- put_ bh ac
- get bh = do
- ab <- get bh
- ac <- get bh
- return (TupCon ab ac)
-
-instance Binary RecFlag where
- put_ bh Recursive = do
- putByte bh 0
- put_ bh NonRecursive = do
- putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return Recursive
- _ -> do return NonRecursive
-
-instance Binary DefMeth where
- put_ bh NoDefMeth = putByte bh 0
- put_ bh DefMeth = putByte bh 1
- put_ bh GenDefMeth = putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoDefMeth
- 1 -> return DefMeth
- _ -> return GenDefMeth
-
-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)
-
-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)
-
--------------------------------------------------------------------------
--- Types from: Demand
--------------------------------------------------------------------------
-
-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)
-
-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
- 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
- -- The wrapper was generated for CPR in
- -- the imported module!
- _ -> do return BotRes
-
-instance Binary StrictSig where
- put_ bh (StrictSig aa) = do
- put_ bh aa
- get bh = do
- aa <- get bh
- return (StrictSig aa)
-
-
--------------------------------------------------------------------------
--- Types from: CostCentre
--------------------------------------------------------------------------
-
-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)
-
--------------------------------------------------------------------------
--- IfaceTypes and friends
--------------------------------------------------------------------------
-
-instance Binary IfaceExtName where
- put_ bh (ExtPkg mod occ) = do
- putByte bh 0
- put_ bh mod
- put_ bh occ
- put_ bh (HomePkg mod occ vers) = do
- putByte bh 1
- put_ bh mod
- put_ bh occ
- put_ bh vers
- put_ bh (LocalTop occ) = do
- putByte bh 2
- put_ bh occ
- put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
- putByte bh 2
- put_ bh occ
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do mod <- get bh
- occ <- get bh
- return (ExtPkg mod occ)
- 1 -> do mod <- get bh
- occ <- get bh
- vers <- get bh
- return (HomePkg mod occ vers)
- _ -> do occ <- get bh
- return (LocalTop occ)
-
-instance Binary IfaceBndr where
- put_ bh (IfaceIdBndr aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (IfaceTvBndr ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (IfaceIdBndr aa)
- _ -> do ab <- get bh
- return (IfaceTvBndr ab)
-
-instance Binary Kind where
- put_ bh LiftedTypeKind = putByte bh 0
- put_ bh UnliftedTypeKind = putByte bh 1
- put_ bh OpenTypeKind = putByte bh 2
- put_ bh ArgTypeKind = putByte bh 3
- put_ bh UbxTupleKind = putByte bh 4
- put_ bh (FunKind k1 k2) = do
- putByte bh 5
- put_ bh k1
- put_ bh k2
- put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return LiftedTypeKind
- 1 -> return UnliftedTypeKind
- 2 -> return OpenTypeKind
- 3 -> return ArgTypeKind
- 4 -> return UbxTupleKind
- _ -> do k1 <- get bh
- k2 <- get bh
- return (FunKind k1 k2)
-
-instance Binary IfaceType where
- put_ bh (IfaceForAllTy aa ab) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- put_ bh (IfaceTyVar ad) = do
- putByte bh 1
- put_ bh ad
- put_ bh (IfaceAppTy ae af) = do
- putByte bh 2
- put_ bh ae
- put_ bh af
- put_ bh (IfaceFunTy ag ah) = do
- putByte bh 3
- put_ bh ag
- put_ bh ah
- put_ bh (IfacePredTy aq) = do
- putByte bh 5
- put_ bh aq
-
- -- Simple compression for common cases of TyConApp
- put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
- put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
- put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
- put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
- -- Unit tuple and pairs
- put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
- put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
- -- Generic cases
- put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
- put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- ab <- get bh
- return (IfaceForAllTy aa ab)
- 1 -> do ad <- get bh
- return (IfaceTyVar ad)
- 2 -> do ae <- get bh
- af <- get bh
- return (IfaceAppTy ae af)
- 3 -> do ag <- get bh
- ah <- get bh
- return (IfaceFunTy ag ah)
- 5 -> do ap <- get bh
- return (IfacePredTy ap)
-
- -- Now the special cases for TyConApp
- 6 -> return (IfaceTyConApp IfaceIntTc [])
- 7 -> return (IfaceTyConApp IfaceCharTc [])
- 8 -> return (IfaceTyConApp IfaceBoolTc [])
- 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
- 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
- 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
- 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
- _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
-
-instance Binary IfaceTyCon where
- -- Int,Char,Bool can't show up here because they can't not be saturated
-
- put_ bh IfaceIntTc = putByte bh 1
- put_ bh IfaceBoolTc = putByte bh 2
- put_ bh IfaceCharTc = putByte bh 3
- put_ bh IfaceListTc = putByte bh 4
- put_ bh IfacePArrTc = putByte bh 5
- put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
- put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
-
- get bh = do
- h <- getByte bh
- case h of
- 1 -> return IfaceIntTc
- 2 -> return IfaceBoolTc
- 3 -> return IfaceCharTc
- 4 -> return IfaceListTc
- 5 -> return IfacePArrTc
- 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
- _ -> do { ext <- get bh; return (IfaceTc ext) }
-
-instance Binary IfacePredType where
- put_ bh (IfaceClassP aa ab) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- put_ bh (IfaceIParam 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 (IfaceClassP aa ab)
- _ -> do ac <- get bh
- ad <- get bh
- return (IfaceIParam ac ad)
-
--------------------------------------------------------------------------
--- IfaceExpr and friends
--------------------------------------------------------------------------
-
-instance Binary IfaceExpr where
- put_ bh (IfaceLcl aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (IfaceType ab) = do
- putByte bh 1
- put_ bh ab
- put_ bh (IfaceTuple ac ad) = do
- putByte bh 2
- put_ bh ac
- put_ bh ad
- put_ bh (IfaceLam ae af) = do
- putByte bh 3
- put_ bh ae
- put_ bh af
- put_ bh (IfaceApp ag ah) = do
- putByte bh 4
- put_ bh ag
- put_ bh ah
--- gaw 2004
- put_ bh (IfaceCase ai aj al ak) = do
- putByte bh 5
- put_ bh ai
- put_ bh aj
--- gaw 2004
- put_ bh al
- put_ bh ak
- put_ bh (IfaceLet al am) = do
- putByte bh 6
- put_ bh al
- put_ bh am
- put_ bh (IfaceNote an ao) = do
- putByte bh 7
- put_ bh an
- put_ bh ao
- put_ bh (IfaceLit ap) = do
- putByte bh 8
- put_ bh ap
- put_ bh (IfaceFCall as at) = do
- putByte bh 9
- put_ bh as
- put_ bh at
- put_ bh (IfaceExt aa) = do
- putByte bh 10
- put_ bh aa
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (IfaceLcl aa)
- 1 -> do ab <- get bh
- return (IfaceType ab)
- 2 -> do ac <- get bh
- ad <- get bh
- return (IfaceTuple ac ad)
- 3 -> do ae <- get bh
- af <- get bh
- return (IfaceLam ae af)
- 4 -> do ag <- get bh
- ah <- get bh
- return (IfaceApp ag ah)
- 5 -> do ai <- get bh
- aj <- get bh
--- gaw 2004
- al <- get bh
- ak <- get bh
--- gaw 2004
- return (IfaceCase ai aj al ak)
- 6 -> do al <- get bh
- am <- get bh
- return (IfaceLet al am)
- 7 -> do an <- get bh
- ao <- get bh
- return (IfaceNote an ao)
- 8 -> do ap <- get bh
- return (IfaceLit ap)
- 9 -> do as <- get bh
- at <- get bh
- return (IfaceFCall as at)
- _ -> do aa <- get bh
- return (IfaceExt aa)
-
-instance Binary IfaceConAlt where
- put_ bh IfaceDefault = do
- putByte bh 0
- put_ bh (IfaceDataAlt aa) = do
- putByte bh 1
- put_ bh aa
- put_ bh (IfaceTupleAlt ab) = do
- putByte bh 2
- put_ bh ab
- put_ bh (IfaceLitAlt ac) = do
- putByte bh 3
- put_ bh ac
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return IfaceDefault
- 1 -> do aa <- get bh
- return (IfaceDataAlt aa)
- 2 -> do ab <- get bh
- return (IfaceTupleAlt ab)
- _ -> do ac <- get bh
- return (IfaceLitAlt ac)
-
-instance Binary IfaceBinding where
- put_ bh (IfaceNonRec aa ab) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- put_ bh (IfaceRec 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 (IfaceNonRec aa ab)
- _ -> do ac <- get bh
- return (IfaceRec ac)
-
-instance Binary IfaceIdInfo where
- put_ bh NoInfo = putByte bh 0
- put_ bh (HasInfo i) = do
- putByte bh 1
- lazyPut bh i -- NB lazyPut
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoInfo
- _ -> do info <- lazyGet bh -- NB lazyGet
- return (HasInfo info)
-
-instance Binary IfaceInfoItem 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 IfaceNote where
- put_ bh (IfaceSCC aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (IfaceCoerce ab) = do
- putByte bh 1
- put_ bh ab
- put_ bh IfaceInlineCall = do
- putByte bh 2
- put_ bh IfaceInlineMe = do
- putByte bh 3
- put_ bh (IfaceCoreNote s) = do
- putByte bh 4
- put_ bh s
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (IfaceSCC aa)
- 1 -> do ab <- get bh
- return (IfaceCoerce ab)
- 2 -> do return IfaceInlineCall
- 3 -> do return IfaceInlineMe
- _ -> do ac <- get bh
- return (IfaceCoreNote ac)
-
-
--------------------------------------------------------------------------
--- IfaceDecl and friends
--------------------------------------------------------------------------
-
-instance Binary IfaceDecl where
- put_ bh (IfaceId name ty idinfo) = do
- putByte bh 0
- put_ bh name
- put_ bh ty
- put_ bh idinfo
- put_ bh (IfaceForeign ae af) =
- error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
- putByte bh 2
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- put_ bh a7
-
- put_ bh (IfaceSyn aq ar as at) = do
- putByte bh 3
- put_ bh aq
- put_ bh ar
- put_ bh as
- put_ bh at
- put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
- putByte bh 4
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- put_ bh a7
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do name <- get bh
- ty <- get bh
- idinfo <- get bh
- return (IfaceId name ty idinfo)
- 1 -> error "Binary.get(TyClDecl): ForeignType"
- 2 -> do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- return (IfaceData a1 a2 a3 a4 a5 a6 a7)
- 3 -> do
- aq <- get bh
- ar <- get bh
- as <- get bh
- at <- get bh
- return (IfaceSyn aq ar as at)
- _ -> do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
-
-instance Binary IfaceInst where
- put_ bh (IfaceInst cls tys dfun flag orph) = do
- put_ bh cls
- put_ bh tys
- put_ bh dfun
- put_ bh flag
- put_ bh orph
- get bh = do cls <- get bh
- tys <- get bh
- dfun <- get bh
- flag <- get bh
- orph <- get bh
- return (IfaceInst cls tys dfun flag orph)
-
-instance Binary OverlapFlag where
- put_ bh NoOverlap = putByte bh 0
- put_ bh OverlapOk = putByte bh 1
- put_ bh Incoherent = putByte bh 2
- get bh = do h <- getByte bh
- case h of
- 0 -> return NoOverlap
- 1 -> return OverlapOk
- 2 -> return Incoherent
-
-instance Binary IfaceConDecls where
- put_ bh IfAbstractTyCon = putByte bh 0
- put_ bh (IfDataTyCon cs) = do { putByte bh 1
- ; put_ bh cs }
- put_ bh (IfNewTyCon c) = do { putByte bh 2
- ; put_ bh c }
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return IfAbstractTyCon
- 1 -> do cs <- get bh
- return (IfDataTyCon cs)
- _ -> do aa <- get bh
- return (IfNewTyCon aa)
-
-instance Binary IfaceConDecl where
- put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
- putByte bh 0
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
- putByte bh 1
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- return (IfVanillaCon a1 a2 a3 a4 a5)
- _ -> do a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- return (IfGadtCon a1 a2 a3 a4 a5 a6)
-
-instance Binary IfaceClassOp where
- put_ bh (IfaceClassOp 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 (IfaceClassOp n def ty)
-
-instance Binary IfaceRule where
- put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- put_ bh a7
- get bh = do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
-
-
projects / ghc-hetmet.git / blobdiff