--- /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_IgnoreHiVersion ) where
+
+#include "HsVersions.h"
+
+import HscTypes
+import BasicTypes
+import NewDemand
+import IfaceSyn
+import VarEnv
+import TyCon ( DataConDetails(..) )
+import Class ( DefMeth(..) )
+import CostCentre
+import Module ( moduleName, mkModule )
+import OccName ( OccName )
+import DriverState ( v_Build_tag )
+import CmdLineOpts ( opt_HiVersion )
+import Panic
+import Binary
+import Util
+
+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 NewOrData 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 !-}
+
+-- TyCon
+{-! for DataConDetails 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_mod_vers = mod_vers,
+ mi_package = pkg_name,
+ 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
+ build_tag <- readIORef v_Build_tag
+ put_ bh (show opt_HiVersion ++ build_tag)
+ put_ bh pkg_name
+ put_ bh (moduleName mod)
+ 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
+ ignore_ver <- readIORef v_IgnoreHiVersion
+ build_tag <- readIORef v_Build_tag
+ let our_ver = show opt_HiVersion ++ build_tag
+ when (check_ver /= our_ver && not ignore_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))
+
+ pkg_name <- get bh
+ mod_name <- 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 = pkg_name,
+ mi_module = mkModule pkg_name mod_name,
+ -- We write the module as a ModuleName, becuase whether
+ -- or not it's a home-package module depends on the importer
+ -- mkModule reconstructs the Module, by comparing the static
+ -- opt_InPackage flag with the package name in the interface file
+ mi_mod_vers = mod_vers,
+ mi_boot = False, -- Binary interfaces are never .hi-boot files!
+ 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,
+ -- And build the cached values
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_ver_fn = mkIfaceVerCache decls })
+
+GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)
+
+-------------------------------------------------------------------------
+-- 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 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 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 IfaceKind where
+ put_ bh IfaceLiftedTypeKind = putByte bh 0
+ put_ bh IfaceUnliftedTypeKind = putByte bh 1
+ put_ bh IfaceOpenTypeKind = putByte bh 2
+ put_ bh (IfaceFunKind k1 k2) = do
+ putByte bh 3
+ put_ bh k1
+ put_ bh k2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfaceLiftedTypeKind
+ 1 -> return IfaceUnliftedTypeKind
+ 2 -> return IfaceOpenTypeKind
+ _ -> do k1 <- get bh
+ k2 <- get bh
+ return (IfaceFunKind 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 IfaceListTc = putByte bh 1
+ put_ bh IfacePArrTc = putByte bh 2
+ put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
+ put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 1 -> return IfaceListTc
+ 2 -> return IfacePArrTc
+ _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+
+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
+ put_ bh (IfaceCase ai aj ak) = do
+ putByte bh 5
+ put_ bh ai
+ put_ bh aj
+ 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
+ ak <- get bh
+ return (IfaceCase ai aj 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
+ put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo"
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoInfo
+ _ -> do info <- lazyGet bh
+ 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 a8) = 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 a8
+
+ 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
+ a8 <- get bh
+ return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
+ 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 ty dfun) = do
+ put_ bh ty
+ put_ bh dfun
+ get bh = do ty <- get bh
+ dfun <- get bh
+ return (IfaceInst ty dfun)
+
+instance Binary IfaceConDecl where
+ put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfaceConDecl 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
+ -- IfaceBuiltinRule should not happen here
+ put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfaceRule a1 a2 a3 a4 a5 a6)
+
+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
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (DataCons aa)
+ _ -> do return Unknown
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+\begin{code}
+module BuildTyCl (
+ buildSynTyCon, buildAlgTyCon, buildDataCon,
+ buildClass,
+ newTyConRhs -- Just a useful little function with no obvious home
+ ) where
+
+#include "HsVersions.h"
+
+import IfaceEnv ( newImplicitBinder )
+import TcRnMonad
+
+import Subst ( substTyWith )
+import Util ( zipLazy )
+import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName )
+import VarSet
+import DataCon ( DataCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
+import Var ( tyVarKind, TyVar )
+import TysWiredIn ( unitTy )
+import BasicTypes ( RecFlag, NewOrData( ..), StrictnessMark(..) )
+import Name ( Name )
+import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
+ mkClassDataConOcc, mkSuperDictSelOcc )
+import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
+import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
+import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+ tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
+ ArgVrcs, DataConDetails( ..), AlgTyConFlavour(..) )
+import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind,
+ tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type )
+import Outputable
+import List ( nubBy )
+
+\end{code}
+
+
+\begin{code}
+------------------------------------------------------
+buildSynTyCon name tvs rhs_ty arg_vrcs
+ = mkSynTyCon name kind tvs rhs_ty arg_vrcs
+ where
+ kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+
+
+------------------------------------------------------
+buildAlgTyCon :: NewOrData -> Name -> [TyVar] -> ThetaType
+ -> DataConDetails DataCon
+ -> ArgVrcs -> RecFlag
+ -> Bool -- True <=> want generics functions
+ -> TcRnIf m n TyCon
+
+buildAlgTyCon new_or_data tc_name tvs ctxt cons arg_vrcs is_rec want_generics
+ = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs
+ cons sel_ids flavour is_rec want_generics
+ ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+ ; sel_ids = mkRecordSelectors tycon cons
+ ; flavour = case new_or_data of
+ NewType -> NewTyCon (mkNewTyConRep tycon)
+ DataType -> DataTyCon (all_nullary cons)
+ }
+ ; return tycon }
+ where
+ all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+ all_nullary Unknown = False -- Safe choice for unknown data types
+ -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
+ -- but that looks at the *representation* arity, and isEnumerationType
+ -- refers to the *source* code definition
+
+------------------------------------------------------
+buildDataCon :: Name
+ -> [StrictnessMark]
+ -> [Name] -- Field labels
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [Type] -> TyCon
+ -> TcRnIf m n DataCon
+-- A wrapper for DataCon.mkDataCon that
+-- a) makes the worker Id
+-- b) makes the wrapper Id if necessary, including
+-- allocating its unique (hence monadic)
+buildDataCon src_name arg_stricts field_lbl_names
+ tyvars ctxt ex_tyvars ex_ctxt
+ arg_tys tycon
+ = newImplicitBinder src_name mkDataConWrapperOcc `thenM` \ wrap_name ->
+ newImplicitBinder src_name mkDataConWorkerOcc `thenM` \ work_name ->
+ -- This last one takes the name of the data constructor in the source
+ -- code, which (for Haskell source anyway) will be in the SrcDataName name
+ -- space, and makes it into a "real data constructor name"
+ let
+ -- Make the FieldLabels
+ -- The zipLazy avoids forcing the arg_tys too early
+ final_lbls = [ mkFieldLabel name tycon ty tag
+ | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags)
+ `zipLazy` arg_tys
+ ]
+
+ ctxt' = thinContext arg_tys ctxt
+ data_con = mkDataCon src_name arg_stricts final_lbls
+ tyvars ctxt'
+ ex_tyvars ex_ctxt
+ arg_tys tycon dc_ids
+ dc_ids = mkDataConIds wrap_name work_name data_con
+ in
+ returnM data_con
+
+-- The context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+thinContext arg_tys ctxt
+ = filter in_arg_tys ctxt
+ where
+ arg_tyvars = tyVarsOfTypes arg_tys
+ in_arg_tys pred = not $ isEmptyVarSet $
+ tyVarsOfPred pred `intersectVarSet` arg_tyvars
+
+------------------------------------------------------
+mkRecordSelectors tycon data_cons
+ = -- We'll check later that fields with the same name
+ -- from different constructors have the same type.
+ [ mkRecordSelId tycon field
+ | field <- nubBy eq_name fields ]
+ where
+ fields = [ field | con <- visibleDataCons data_cons,
+ field <- dataConFieldLabels con ]
+ eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
+
+
+------------------------------------------------------
+newTyConRhs :: TyCon -> Type -- The defn of a newtype, as written by the programmer
+newTyConRhs tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
+
+mkNewTyConRep :: TyCon -- The original type constructor
+ -> Type -- Chosen representation type
+ -- (guaranteed not to be another newtype)
+
+-- Find the representation type for this newtype TyCon
+-- Remember that the representation type is the ultimate representation
+-- type, looking through other newtypes.
+--
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+--
+-- The trick is to to deal correctly with recursive newtypes
+-- such as newtype T = MkT T
+
+mkNewTyConRep tc
+ | null (tyConDataCons tc) = unitTy
+ -- External Core programs can have newtypes with no data constructors
+ | otherwise = go [] tc
+ where
+ -- Invariant: tc is a NewTyCon
+ -- tcs have been seen before
+ go tcs tc
+ | tc `elem` tcs = unitTy
+ | otherwise
+ = case splitTyConApp_maybe rep_ty of
+ Nothing -> rep_ty
+ Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
+ | otherwise -> go1 (tc:tcs) tc' tys
+ where
+ rep_ty = newTyConRhs tc
+
+ go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
+\end{code}
+
+
+\begin{code}
+buildClass :: Name -> [TyVar] -> ThetaType
+ -> [FunDep TyVar] -- Functional dependencies
+ -> [(Name, DefMeth, Type)] -- Method info
+ -> RecFlag -> ArgVrcs -- Info for type constructor
+ -> TcRnIf m n Class
+
+buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs
+ = do { tycon_name <- newImplicitBinder class_name mkClassTyConOcc
+ ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
+ -- The class name is the 'parent' for this datacon, not its tycon,
+ -- because one should import the class to get the binding for
+ -- the datacon
+ ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc)
+ [1..length sc_theta]
+ -- We number off the superclass selectors, 1, 2, 3 etc so that we
+ -- can construct names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
+
+ ; fixM (\ clas -> do { -- Only name generation inside loop
+
+ let { op_tys = [ty | (_,_,ty) <- sig_stuff]
+ ; sc_tys = mkPredTys sc_theta
+ ; dict_component_tys = sc_tys ++ op_tys
+ ; sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
+ ; op_items = [ (mkDictSelId op_name clas, dm_info)
+ | (op_name, dm_info, _) <- sig_stuff ] }
+ -- Build the selector id and default method id
+
+ ; dict_con <- buildDataCon datacon_name
+ (map (const NotMarkedStrict) dict_component_tys)
+ [{- No labelled fields -}]
+ tvs [{-No context-}]
+ [{-No existential tyvars-}] [{-Or context-}]
+ dict_component_tys
+ (classTyCon clas)
+
+ ; let { clas = mkClass class_name tvs fds
+ sc_theta sc_sel_ids op_items
+ tycon
+
+ ; tycon = mkClassTyCon tycon_name clas_kind tvs
+ tc_vrcs dict_con
+ clas flavour tc_isrec
+ -- A class can be recursive, and in the case of newtypes
+ -- this matters. For example
+ -- class C a where { op :: C b => a -> b -> Int }
+ -- Because C has only one operation, it is represented by
+ -- a newtype, and it should be a *recursive* newtype.
+ -- [If we don't make it a recursive newtype, we'll expand the
+ -- newtype like a synonym, but that will lead to an infinite type]
+
+ ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+
+ ; flavour = case dict_component_tys of
+ [rep_ty] -> NewTyCon (mkNewTyConRep tycon)
+ other -> DataTyCon False -- Not an enumeration
+ }
+ ; return clas
+ })}
+\end{code}
+
+
--- /dev/null
+(c) The University of Glasgow 2002
+
+\begin{code}
+module IfaceEnv (
+ newGlobalBinder, newIPName, newImplicitBinder,
+ lookupIfaceTop, lookupIfaceExt,
+ lookupOrig, lookupImplicitOrig, lookupIfaceTc,
+ newIfaceName, newIfaceNames,
+ extendIfaceIdEnv, extendIfaceTyVarEnv,
+ tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
+ tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
+
+ -- Name-cache stuff
+ allocateGlobalBinder, extendOrigNameCache, initNameCache
+ ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} TcIface( tcImportDecl )
+
+import TcRnMonad
+import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
+import HscTypes ( NameCache(..), HscEnv(..),
+ TyThing, tyThingClass, tyThingTyCon,
+ ExternalPackageState(..), OrigNameCache, lookupType )
+import TyCon ( TyCon, tyConName )
+import Class ( Class )
+import DataCon ( DataCon, dataConWorkId, dataConName )
+import Var ( TyVar, Id, varName )
+import Name ( Name, nameUnique, nameModule, nameModuleName,
+ nameOccName, nameSrcLoc,
+ getOccName, nameParent_maybe,
+ isWiredInName, nameIsLocalOrFrom, mkIPName,
+ mkExternalName, mkInternalName )
+import NameEnv
+import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
+ lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
+import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name )
+import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
+ tupleTyCon, tupleCon )
+import HscTypes ( ExternalPackageState, NameCache, TyThing(..) )
+import Module ( Module, ModuleName, moduleName, mkPackageModule,
+ emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
+import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
+import FiniteMap ( emptyFM, lookupFM, addToFM )
+import BasicTypes ( IPName(..), mapIPName )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import Maybes ( orElse )
+
+import Outputable
+\end{code}
+
+
+%*********************************************************
+%* *
+ Allocating new Names in the Name Cache
+%* *
+%*********************************************************
+
+\begin{code}
+newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
+-- Used for source code and interface files, to make the
+-- Name for a thing, given its Module and OccName
+--
+-- The cache may already already have a binding for this thing,
+-- because we may have seen an occurrence before, but now is the
+-- moment when we know its Module and SrcLoc in their full glory
+
+newGlobalBinder mod occ mb_parent loc
+ = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
+ ; name_supply <- getNameCache
+ ; let (name_supply', name) = allocateGlobalBinder
+ name_supply mod occ
+ mb_parent loc
+ ; setNameCache name_supply'
+ ; return name }
+
+allocateGlobalBinder
+ :: NameCache
+ -> Module -> OccName -> Maybe Name -> SrcLoc
+ -> (NameCache, Name)
+allocateGlobalBinder name_supply mod occ mb_parent loc
+ = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of
+ -- A hit in the cache! We are at the binding site of the name.
+ -- This is the moment when we know the defining Module and SrcLoc
+ -- of the Name, so we set these fields in the Name we return.
+ --
+ -- This is essential, to get the right Module in a Name.
+ -- Also: then (bogus) multiple bindings of the same Name
+ -- get different SrcLocs can can be reported as such.
+ --
+ -- Possible other reason: it might be in the cache because we
+ -- encountered an occurrence before the binding site for an
+ -- implicitly-imported Name. Perhaps the current SrcLoc is
+ -- better... but not really: it'll still just say 'imported'
+ --
+ -- IMPORTANT: Don't mess with wired-in names.
+ -- Their wired-in-ness is in their NameSort
+ -- and their Module is correct.
+
+ Just name | isWiredInName name -> (name_supply, name)
+ | otherwise -> (new_name_supply, name')
+ where
+ uniq = nameUnique name
+ name' = mkExternalName uniq mod occ mb_parent loc
+ new_cache = extend_name_cache (nsNames name_supply) mod occ name'
+ new_name_supply = name_supply {nsNames = new_cache}
+
+ -- Miss in the cache!
+ -- Build a completely new Name, and put it in the cache
+ Nothing -> (new_name_supply, name)
+ where
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ uniq = uniqFromSupply us1
+ name = mkExternalName uniq mod occ mb_parent loc
+ new_cache = extend_name_cache (nsNames name_supply) mod occ name
+ new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+
+newImplicitBinder :: Name -- Base name
+ -> (OccName -> OccName) -- Occurrence name modifier
+ -> TcRnIf m n Name -- Implicit name
+-- Called in BuildTyCl to allocate the implicit binders of type/class decls
+-- For source type/class decls, this is the first occurrence
+-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
+--
+-- An *implicit* name has the base-name as parent
+newImplicitBinder base_name mk_sys_occ
+ = newGlobalBinder (nameModule base_name)
+ (mk_sys_occ (nameOccName base_name))
+ (Just parent_name)
+ (nameSrcLoc base_name)
+ where
+ parent_name = case nameParent_maybe base_name of
+ Just parent_name -> parent_name
+ Nothing -> base_name
+
+lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
+-- This one starts with a ModuleName, not a Module, because
+-- we may be simply looking at an occurrence M.x in an interface file.
+-- We may enounter this well before finding the binding site for M.x
+--
+-- So, even if we get a miss in the original-name cache, we
+-- make a new External Name.
+-- We fake up
+-- Module to AnotherPackage
+-- SrcLoc to noSrcLoc
+-- They'll be overwritten, in due course, by LoadIface.loadDecl.
+lookupOrig mod_name occ = lookupOrig_help mod_name occ Nothing
+
+lookupImplicitOrig :: Name -> OccName -> TcRnIf m n Name
+-- Same as lookupOrig, but install (Just parent) as the
+-- parent Name. This is used when looking at the exports
+-- of an interface:
+-- Suppose module M exports type A.T, and constructor A.MkT
+-- Then, we know that A.MkT is an implicit name of A.T,
+-- even though we aren't at the binding site of A.T
+-- And it's important, because we may simply re-export A.T
+-- without ever sucking in the declaration itself.
+lookupImplicitOrig name occ
+ = lookupOrig_help (nameModuleName name) occ (Just name)
+
+lookupOrig_help :: ModuleName -> OccName -> Maybe Name -> TcRnIf a b Name
+-- Local helper, not exported
+lookupOrig_help mod_name occ mb_parent
+ = do { -- First ensure that mod_name and occ are evaluated
+ -- If not, chaos can ensue:
+ -- we read the name-cache
+ -- then pull on mod (say)
+ -- which does some stuff that modifies the name cache
+ -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+ mod `seq` occ `seq` return ()
+
+ ; name_supply <- getNameCache
+ ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
+ Just name -> returnM name ;
+ Nothing -> do
+
+ { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ ; uniq = uniqFromSupply us1
+ ; name = mkExternalName uniq tmp_mod occ mb_parent noSrcLoc
+ ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name
+ ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+ ; tmp_mod = mkPackageModule mod_name
+ -- Guess at the package-ness for now, becuase we don't know whether
+ -- this imported module is from the home package or not.
+ -- If we ever need it, we'll open its interface, and update the cache
+ -- with a better name (newGlobalBinder)
+ }
+ ; setNameCache new_name_supply
+ ; return name }
+ }}
+
+newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
+newIPName occ_name_ip
+ = getNameCache `thenM` \ name_supply ->
+ let
+ ipcache = nsIPs name_supply
+ in
+ case lookupFM ipcache key of
+ Just name_ip -> returnM name_ip
+ Nothing -> setNameCache new_ns `thenM_`
+ returnM name_ip
+ where
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ uniq = uniqFromSupply us1
+ name_ip = mapIPName (mkIPName uniq) occ_name_ip
+ new_ipcache = addToFM ipcache key name_ip
+ new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+ where
+ key = occ_name_ip -- Ensures that ?x and %x get distinct Names
+\end{code}
+
+ Local helper functions (not exported)
+
+\begin{code}
+lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name
+lookupOrigNameCache nc mod_name occ
+ | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- Boxed tuples from one,
+ Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
+ = -- Special case for tuples; there are too many
+ -- of them to pre-populate the original-name cache
+ Just (mk_tup_name tup_info)
+ where
+ mk_tup_name (ns, boxity, arity)
+ | ns == tcName = tyConName (tupleTyCon boxity arity)
+ | ns == dataName = dataConName (tupleCon boxity arity)
+ | otherwise = varName (dataConWorkId (tupleCon boxity arity))
+
+lookupOrigNameCache nc mod_name occ -- The normal case
+ = case lookupModuleEnvByName nc mod_name of
+ Nothing -> Nothing
+ Just occ_env -> lookupOccEnv occ_env occ
+
+extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
+extendOrigNameCache nc name
+ = extend_name_cache nc (nameModule name) (nameOccName name) name
+
+extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
+extend_name_cache nc mod occ name
+ = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
+ where
+ combine occ_env _ = extendOccEnv occ_env occ name
+
+getNameCache :: TcRnIf a b NameCache
+getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
+ readMutVar nc_var }
+
+setNameCache :: NameCache -> TcRnIf a b ()
+setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
+ writeMutVar nc_var nc }
+\end{code}
+
+
+\begin{code}
+initNameCache :: UniqSupply -> [Name] -> NameCache
+initNameCache us names
+ = NameCache { nsUniqs = us,
+ nsNames = initOrigNames names,
+ nsIPs = emptyFM }
+
+initOrigNames :: [Name] -> OrigNameCache
+initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
+\end{code}
+
+
+%************************************************************************
+%* *
+ Getting from Names to TyThings
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceGlobal :: Name -> IfM a TyThing
+tcIfaceGlobal name
+ = do { eps <- getEps
+ ; hpt <- getHpt
+ ; case lookupType hpt (eps_PTE eps) name of {
+ Just thing -> return thing ;
+ Nothing ->
+
+ setLclEnv () $ do
+ { env <- getGblEnv
+ ; case if_rec_types env of
+ Just (mod, get_type_env)
+ | nameIsLocalOrFrom mod name
+ -> do -- It's defined in the module being compiled
+ { type_env <- get_type_env
+ ; case lookupNameEnv type_env name of
+ Just thing -> return thing
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ (ppr name $$ ppr type_env) }
+
+ other -> tcImportDecl name -- It's imported; go get it
+ }}}
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon IfaceIntTc = return intTyCon
+tcIfaceTyCon IfaceBoolTc = return boolTyCon
+tcIfaceTyCon IfaceCharTc = return charTyCon
+tcIfaceTyCon IfaceListTc = return listTyCon
+tcIfaceTyCon IfacePArrTc = return parrTyCon
+tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
+ ; thing <- tcIfaceGlobal name
+ ; return (tyThingTyCon thing) }
+
+tcIfaceClass :: IfaceExtName -> IfL Class
+tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
+ ; thing <- tcIfaceGlobal name
+ ; return (tyThingClass thing) }
+
+tcIfaceDataCon :: IfaceExtName -> IfL DataCon
+tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
+ ; thing <- tcIfaceGlobal name
+ ; case thing of
+ ADataCon dc -> return dc
+ other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
+
+tcIfaceExtId :: IfaceExtName -> IfL Id
+tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
+ ; thing <- tcIfaceGlobal name
+ ; case thing of
+ AnId id -> return id
+ other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
+
+------------------------------------------
+tcIfaceLclId :: OccName -> IfL Id
+tcIfaceLclId occ
+ = do { lcl <- getLclEnv
+ ; return (lookupOccEnv (if_id_env lcl) occ
+ `orElse`
+ pprPanic "tcIfaceLclId" (ppr occ)) }
+
+tcIfaceTyVar :: OccName -> IfL TyVar
+tcIfaceTyVar occ
+ = do { lcl <- getLclEnv
+ ; return (lookupOccEnv (if_tv_env lcl) occ
+ `orElse`
+ pprPanic "tcIfaceTyVar" (ppr occ)) }
+
+extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
+extendIfaceIdEnv ids thing_inside
+ = do { env <- getLclEnv
+ ; let { id_env' = extendOccEnvList (if_id_env env) pairs
+ ; pairs = [(getOccName id, id) | id <- ids] }
+ ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+
+extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
+extendIfaceTyVarEnv tyvars thing_inside
+ = do { env <- getLclEnv
+ ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
+ ; pairs = [(getOccName tv, tv) | tv <- tyvars] }
+ ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Getting from RdrNames to Names
+%* *
+%************************************************************************
+
+IfaceDecls etc are populated with RdrNames. The RdrNames may either be
+
+ Orig or Unqual when the interface is read from a file
+
+ Exact when the interface is kept by GHCi, and is now
+ being re-linked with the type environment
+
+At an occurrence site, to convert the RdrName to Name:
+ Unqual look up in LocalRdrEnv
+ Orig look up in OrigNameCache
+ Exact return the Name
+
+At a binding site, to bind the RdrName
+ Unqual we extend the LocalRdrEnv
+ Orig or Unqual we don't extend the LocalRdrEnv (no need)
+
+First, we deal with the RdrName -> Name mapping
+
+\begin{code}
+lookupIfaceTc :: IfaceTyCon -> IfL Name
+lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
+lookupIfaceTc other_tc = return (ifaceTyConName other_tc)
+
+lookupIfaceExt :: IfaceExtName -> IfL Name
+lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ
+lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
+lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ
+lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
+
+lookupIfaceTop :: OccName -> IfL Name
+-- Look up a top-level name from the current Iface module
+lookupIfaceTop occ
+ = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
+
+newIfaceName :: OccName -> IfL Name
+newIfaceName occ
+ = do { uniq <- newUnique
+ ; return (mkInternalName uniq occ noSrcLoc) }
+
+newIfaceNames :: [OccName] -> IfL [Name]
+newIfaceNames occs
+ = do { uniqs <- newUniqueSupply
+ ; return [ mkInternalName uniq occ noSrcLoc
+ | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+%************************************************************************
+%* *
+\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
+%* *
+%************************************************************************
+
+We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
+@TyVars@ as well. Currently trying the former... MEGA SIGH.
+
+\begin{code}
+module IfaceSyn (
+ module IfaceType, -- Re-export all this
+
+ IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..),
+ IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+
+ -- Converting things to IfaceSyn
+ tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
+
+ -- Equality
+ IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
+ eqIfDecl, eqIfInst, eqIfRule,
+
+ -- Pretty printing
+ pprIfaceExpr, pprIfaceDecl
+ ) where
+
+#include "HsVersions.h"
+
+import CoreSyn
+import IfaceType
+
+import FunDeps ( pprFundeps )
+import NewDemand ( StrictSig, pprIfaceStrictSig )
+import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred )
+import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy,
+ mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType )
+import InstEnv ( DFunId )
+import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
+import NewDemand ( isTopSig )
+import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
+ arityInfo, cafInfo, newStrictnessInfo,
+ workerInfo, unfoldingInfo, inlinePragInfo )
+import TyCon ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
+ isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
+ isTupleTyCon, tupleTyConBoxity,
+ tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
+ tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName )
+import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
+ dataConTyCon )
+import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
+import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
+ lookupOccEnv, extendOccEnv, emptyOccEnv,
+ OccSet, unionOccSets, unitOccSet )
+import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName )
+import Module ( ModuleName )
+import CostCentre ( CostCentre, pprCostCentreCore )
+import Literal ( Literal )
+import ForeignCall ( ForeignCall )
+import TysPrim ( alphaTyVars )
+import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..),
+ RecFlag(..), boolToRecFlag, Boxity(..),
+ tupleParens )
+import Outputable
+import FastString
+import Maybes ( catMaybes )
+import Util ( lengthIs )
+
+infixl 3 &&&
+infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
+\end{code}
+
+
+%************************************************************************
+%* *
+ Data type declarations
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceDecl
+ = IfaceId { ifName :: OccName,
+ ifType :: IfaceType,
+ ifIdInfo :: IfaceIdInfo }
+
+ | IfaceData { ifND :: NewOrData,
+ ifCtxt :: IfaceContext, -- Context
+ ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifCons :: DataConDetails IfaceConDecl,
+ ifRec :: RecFlag, -- Recursive or not?
+ ifVrcs :: ArgVrcs,
+ ifGeneric :: Bool -- True <=> generic converter functions available
+ } -- We need this for imported data decls, since the
+ -- imported modules may have been compiled with
+ -- different flags to the current compilation unit
+
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifVrcs :: ArgVrcs,
+ ifSynRhs :: IfaceType -- synonym expansion
+ }
+
+ | IfaceClass { ifCtxt :: IfaceContext, -- Context...
+ ifName :: OccName, -- Name of the class
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifFDs :: [FunDep OccName], -- Functional dependencies
+ ifSigs :: [IfaceClassOp], -- Method signatures
+ ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
+ ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
+ }
+
+ | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
+ ifExtName :: Maybe FastString }
+
+data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
+ -- Nothing => no default method
+ -- Just False => ordinary polymorphic default method
+ -- Just True => generic default method
+
+data IfaceConDecl
+ = IfaceConDecl OccName -- Constructor name
+ [IfaceTvBndr] -- Existental tyvars
+ IfaceContext -- Existential context
+ [IfaceType] -- Arg types
+ [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types
+ [OccName] -- ...ditto... (field labels)
+
+data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified
+ -- so that it'll compare alpha-wise
+ ifDFun :: OccName } -- And the dfun
+ -- There's always a separate IfaceDecl for the DFun, which gives
+ -- its IdInfo with its full type and version number.
+ -- The instance declarations taken together have a version number,
+ -- and we don't want that to wobble gratuitously
+ -- If this instance decl is *used*, we'll record a usage on the dfun;
+ -- and if the head does not change it won't be used if it wasn't before
+
+data IfaceRule
+ = IfaceRule {
+ ifRuleName :: RuleName,
+ ifActivation :: Activation,
+ ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
+ ifRuleHead :: IfaceExtName, -- Head of lhs
+ ifRuleArgs :: [IfaceExpr], -- Args of LHS
+ ifRuleRhs :: IfaceExpr
+ }
+ | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can
+ -- wait in the RulePol
+
+data IfaceIdInfo
+ = NoInfo -- When writing interface file without -O
+ | HasInfo [IfaceInfoItem] -- Has info, and here it is
+ | DiscardedInfo -- HasInfo in the .hi file, but discarded
+ -- when it was read in
+-- Here's why we need this NoInfo/DiscardedInfo stuff
+-- * Compile with -O module A, and B which imports A.f
+-- * Change function f in A, and recompile without -O
+-- * If we read in A.hi and discard IdInfo, the
+-- new (empty) IdInfo for f looks like the
+-- old (discarded) IdInfo for f
+-- => no new version # for f
+-- * But that might mean that we fail to recompile B, when
+-- actually we should
+--
+-- * We also want to ensure that if A.hi was *already* compiled
+-- without -O we *don't* then recompile B
+--
+-- When we discard IdInfo on *reading* we make it into DiscardedInfo
+-- On *writing* we make it NoInfo
+-- DiscardedInfo is never written into a file
+
+data IfaceInfoItem
+ = HsArity Arity
+ | HsStrictness StrictSig
+ | HsUnfold Activation IfaceExpr
+ | HsNoCafRefs
+ | HsWorker OccName Arity -- Worker, if any see IdInfo.WorkerInfo
+ -- for why we want arity here.
+-- NB: Specialisations and rules come in separately and are
+-- only later attached to the Id. Partial reason: some are orphans.
+
+--------------------------------
+data IfaceExpr
+ = IfaceLcl OccName
+ | IfaceExt IfaceExtName
+ | IfaceType IfaceType
+ | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
+ | IfaceLam IfaceBndr IfaceExpr
+ | IfaceApp IfaceExpr IfaceExpr
+ | IfaceCase IfaceExpr OccName [IfaceAlt]
+ | IfaceLet IfaceBinding IfaceExpr
+ | IfaceNote IfaceNote IfaceExpr
+ | IfaceLit Literal
+ | IfaceFCall ForeignCall IfaceType
+
+data IfaceNote = IfaceSCC CostCentre
+ | IfaceCoerce IfaceType
+ | IfaceInlineCall
+ | IfaceInlineMe
+ | IfaceCoreNote String
+
+type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
+ -- Note: OccName, not IfaceBndr (and same with the case binder)
+ -- We reconstruct the kind/type of the thing from the context
+ -- thus saving bulk in interface files
+
+data IfaceConAlt = IfaceDefault
+ | IfaceDataAlt OccName
+ | IfaceTupleAlt Boxity
+ | IfaceLitAlt Literal
+
+data IfaceBinding
+ = IfaceNonRec IfaceIdBndr IfaceExpr
+ | IfaceRec [(IfaceIdBndr, IfaceExpr)]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[HsCore-print]{Printing Core unfoldings}
+%* *
+%************************************************************************
+
+----------------------------- Printing IfaceDecl ------------------------------------
+
+\begin{code}
+instance Outputable IfaceDecl where
+ ppr = pprIfaceDecl
+
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
+ = sep [ ppr var <+> dcolon <+> ppr ty,
+ nest 2 (ppr info) ]
+
+pprIfaceDecl (IfaceForeign {ifName = tycon})
+ = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
+ = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars)
+ 4 (vcat [equals <+> ppr mono_ty,
+ pprVrcs vrcs])
+
+pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon,
+ ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
+ = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars)
+ 4 (vcat [pprVrcs vrcs, pprRec isrec, pp_condecls condecls])
+
+pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
+ ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
+ = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds)
+ 4 (vcat [pprVrcs vrcs,
+ pprRec isrec,
+ sep (map ppr sigs)])
+
+pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
+pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
+
+instance Outputable IfaceClassOp where
+ ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
+
+pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
+pp_decl_head context thing tyvars
+ = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
+
+pp_condecls Unknown = ptext SLIT("{- abstract -}")
+pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
+
+instance Outputable IfaceConDecl where
+ ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
+ = pprIfaceForAllPart ex_tvs ex_ctxt $
+ sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
+ if null strs then empty
+ else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
+ if null fields then empty
+ else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
+
+instance Outputable IfaceRule where
+ ppr (IfaceRule name act bndrs fn args rhs)
+ = sep [hsep [doubleQuotes (ftext name), ppr act,
+ ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
+ nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
+ ptext SLIT("=") <+> ppr rhs])
+ ]
+ ppr (IfaceBuiltinRule name rule)
+ = ptext SLIT("Built-in rule for") <+> ppr name
+
+instance Outputable IfaceInst where
+ ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty})
+ = hang (ptext SLIT("instance") <+> ppr ty)
+ 2 (equals <+> ppr dfun_id)
+\end{code}
+
+
+----------------------------- Printing IfaceExpr ------------------------------------
+
+\begin{code}
+instance Outputable IfaceExpr where
+ ppr e = pprIfaceExpr noParens e
+
+pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
+ -- The function adds parens in context that need
+ -- an atomic value (e.g. function args)
+
+pprIfaceExpr add_par (IfaceLcl v) = ppr v
+pprIfaceExpr add_par (IfaceExt v) = ppr v
+pprIfaceExpr add_par (IfaceLit l) = ppr l
+pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
+
+pprIfaceExpr add_par e@(IfaceLam _ _)
+ = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
+ pprIfaceExpr noParens body])
+ where
+ (bndrs,body) = collect [] e
+ collect bs (IfaceLam b e) = collect (b:bs) e
+ collect bs e = (reverse bs, e)
+
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+ = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
+ pprIfaceExpr noParens rhs <+> char '}'])
+
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+ = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ <+> ppr bndr <+> char '{',
+ nest 2 (sep (map ppr_alt alts)) <+> char '}'])
+
+pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
+ = add_par (sep [ptext SLIT("let {"),
+ nest 2 (ppr_bind (b, rhs)),
+ ptext SLIT("} in"),
+ pprIfaceExpr noParens body])
+
+pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
+ = add_par (sep [ptext SLIT("letrec {"),
+ nest 2 (sep (map ppr_bind pairs)),
+ ptext SLIT("} in"),
+ pprIfaceExpr noParens body])
+
+pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
+
+ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
+ arrow <+> pprIfaceExpr noParens rhs]
+
+ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
+ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
+
+ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
+ equals <+> pprIfaceExpr noParens rhs]
+
+------------------
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
+pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
+
+------------------
+instance Outputable IfaceNote where
+ ppr (IfaceSCC cc) = pprCostCentreCore cc
+ ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
+ ppr IfaceInlineCall = ptext SLIT("__inline_call")
+ ppr IfaceInlineMe = ptext SLIT("__inline_me")
+ ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+
+instance Outputable IfaceConAlt where
+ ppr IfaceDefault = text "DEFAULT"
+ ppr (IfaceLitAlt l) = ppr l
+ ppr (IfaceDataAlt d) = ppr d
+ -- IfaceTupleAlt is handled by the case-alternative printer
+
+------------------
+instance Outputable IfaceIdInfo where
+ ppr NoInfo = empty
+ ppr DiscardedInfo = ptext SLIT("<discarded>")
+ ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
+
+ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
+ parens (pprIfaceExpr noParens unf)]
+ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
+ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
+ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
+ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
+\end{code}
+
+
+%************************************************************************
+%* *
+ Converting things to their Iface equivalents
+%* *
+%************************************************************************
+
+
+\begin{code}
+tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+tyThingToIfaceDecl discard_prags ext (AnId id)
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType ext (idType id),
+ ifIdInfo = info }
+ where
+ info | discard_prags = NoInfo
+ | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
+
+tyThingToIfaceDecl _ ext (AClass clas)
+ = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
+ ifName = getOccName clas,
+ ifTyVars = toIfaceTvBndrs clas_tyvars,
+ ifFDs = map toIfaceFD clas_fds,
+ ifSigs = map toIfaceClassOp op_stuff,
+ ifRec = boolToRecFlag (isRecursiveTyCon tycon),
+ ifVrcs = tyConArgVrcs tycon }
+ where
+ (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
+ tycon = classTyCon clas
+
+ toIfaceClassOp (sel_id, def_meth)
+ = ASSERT(sel_tyvars == clas_tyvars)
+ IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
+ where
+ -- Be careful when splitting the type, because of things
+ -- like class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- and class Baz a where
+ -- op :: (Ord a) => a -> a
+ (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+ op_ty = funResultTy rho_ty
+
+ toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
+
+tyThingToIfaceDecl _ ext (ATyCon tycon)
+ | isSynTyCon tycon
+ = IfaceSyn { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifVrcs = tyConArgVrcs tycon,
+ ifSynRhs = toIfaceType ext syn_ty }
+
+ | isAlgTyCon tycon
+ = IfaceData { ifND = new_or_data,
+ ifCtxt = toIfaceContext ext (tyConTheta tycon),
+ ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifCons = ifaceConDecls (tyConDataConDetails tycon),
+ ifRec = boolToRecFlag (isRecursiveTyCon tycon),
+ ifVrcs = tyConArgVrcs tycon,
+ ifGeneric = tyConHasGenerics tycon }
+
+ | isForeignTyCon tycon
+ = IfaceForeign { ifName = getOccName tycon,
+ ifExtName = tyConExtName tycon }
+
+ | isPrimTyCon tycon || isFunTyCon tycon
+ -- Needed in GHCi for ':info Int#', for example
+ = IfaceData { ifND = DataType,
+ ifCtxt = [],
+ ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
+ ifCons = Unknown,
+ ifGeneric = False,
+ ifRec = NonRecursive,
+ ifVrcs = tyConArgVrcs tycon }
+
+ | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
+ where
+ tyvars = tyConTyVars tycon
+ (_, syn_ty) = getSynTyConDefn tycon
+ new_or_data | isNewTyCon tycon = NewType
+ | otherwise = DataType
+
+ ifaceConDecls Unknown = Unknown
+ ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
+
+ ifaceConDecl data_con
+ = IfaceConDecl (getOccName (dataConName data_con))
+ (toIfaceTvBndrs ex_tyvars)
+ (toIfaceContext ext ex_theta)
+ (map (toIfaceType ext) arg_tys)
+ strict_marks
+ (map getOccName field_labels)
+ where
+ (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con
+ field_labels = dataConFieldLabels data_con
+ strict_marks = dataConStrictMarks data_con
+
+ -- This case only happens in the call to ifaceThing in InteractiveUI
+ -- Otherwise DataCons are filtered out in ifaceThing_acc
+tyThingToIfaceDecl _ ext (ADataCon dc)
+ = IfaceId { ifName = getOccName dc,
+ ifType = toIfaceType ext full_ty,
+ ifIdInfo = NoInfo }
+ where
+ (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
+
+ -- The "stupid context" isn't part of the wrapper-Id type
+ -- (for better or worse -- see note in DataCon.lhs), so we
+ -- have to make it up here
+ full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
+ (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
+
+--------------------------
+dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
+dfunToIfaceInst mod dfun_id
+ = IfaceInst { ifDFun = getOccName dfun_id,
+ ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
+ where
+ (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+ head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
+ -- No need to record the instance context;
+ -- it's in the dfun anyway
+
+ tidy_ty = tidyTopType (deNoteType head_ty)
+ -- The deNoteType is very important. It removes all type
+ -- synonyms from the instance type in interface files.
+ -- That in turn makes sure that when reading in instance decls
+ -- from interface files that the 'gating' mechanism works properly.
+ -- Otherwise you could have
+ -- type Tibble = T Int
+ -- instance Foo Tibble where ...
+ -- and this instance decl wouldn't get imported into a module
+ -- that mentioned T but not Tibble.
+
+
+--------------------------
+toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo ext id_info
+ = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
+ wrkr_hsinfo, unfold_hsinfo]
+ where
+ ------------ Arity --------------
+ arity_info = arityInfo id_info
+ arity_hsinfo | arity_info == 0 = Nothing
+ | otherwise = Just (HsArity arity_info)
+
+ ------------ Caf Info --------------
+ caf_info = cafInfo id_info
+ caf_hsinfo = case caf_info of
+ NoCafRefs -> Just HsNoCafRefs
+ _other -> Nothing
+
+ ------------ Strictness --------------
+ -- No point in explicitly exporting TopSig
+ strict_hsinfo = case newStrictnessInfo id_info of
+ Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
+ _other -> Nothing
+
+ ------------ Worker --------------
+ work_info = workerInfo id_info
+ has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
+ wrkr_hsinfo = case work_info of
+ HasWorker work_id wrap_arity ->
+ Just (HsWorker (getOccName work_id) wrap_arity)
+ NoWorker -> Nothing
+
+ ------------ Unfolding --------------
+ -- The unfolding is redundant if there is a worker
+ unfold_info = unfoldingInfo id_info
+ inline_prag = inlinePragInfo id_info
+ rhs = unfoldingTemplate unfold_info
+ unfold_hsinfo | neverUnfold unfold_info
+ || has_worker = Nothing
+ | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
+
+--------------------------
+coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
+coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
+ = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
+
+coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
+ = IfaceRule { ifRuleName = name, ifActivation = act,
+ ifRuleBndrs = map (toIfaceBndr ext) bndrs,
+ ifRuleHead = ext (getName id),
+ ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
+ -- Use LHS name-fn for the args
+ ifRuleRhs = toIfaceExpr ext rhs }
+
+bogusIfaceRule :: IfaceExtName -> IfaceRule
+bogusIfaceRule id_name
+ = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name)
+
+---------------------
+toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
+toIfaceExpr ext (Var v) = toIfaceVar ext v
+toIfaceExpr ext (Lit l) = IfaceLit l
+toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
+toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
+toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
+toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
+toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
+toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
+
+---------------------
+toIfaceNote ext (SCC cc) = IfaceSCC cc
+toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
+toIfaceNote ext InlineCall = IfaceInlineCall
+toIfaceNote ext InlineMe = IfaceInlineMe
+toIfaceNote ext (CoreNote s) = IfaceCoreNote s
+
+---------------------
+toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
+toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
+
+---------------------
+toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
+
+---------------------
+toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
+ | otherwise = IfaceDataAlt (getOccName dc)
+ where
+ tc = dataConTyCon dc
+
+toIfaceCon (LitAlt l) = IfaceLitAlt l
+toIfaceCon DEFAULT = IfaceDefault
+
+---------------------
+toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
+toIfaceApp ext (Var v) as
+ = case isDataConWorkId_maybe v of
+ -- We convert the *worker* for tuples into IfaceTuples
+ Just dc | isTupleTyCon tc && saturated
+ -> IfaceTuple (tupleTyConBoxity tc) tup_args
+ where
+ val_args = dropWhile isTypeArg as
+ saturated = val_args `lengthIs` idArity v
+ tup_args = map (toIfaceExpr ext) val_args
+ tc = dataConTyCon dc
+
+ other -> mkIfaceApps ext (toIfaceVar ext v) as
+
+toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
+
+mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
+
+---------------------
+toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
+toIfaceVar ext v
+ | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
+ -- Foreign calls have special syntax
+ | isExternalName name = IfaceExt (ext name)
+ | otherwise = IfaceLcl (nameOccName name)
+ where
+ name = idName v
+
+---------------------
+-- mkLhsNameFn ignores versioning info altogether
+-- Used for the LHS of instance decls and rules, where we
+-- there's no point in recording version info
+mkLhsNameFn :: ModuleName -> Name -> IfaceExtName
+mkLhsNameFn this_mod name
+ | mod == this_mod = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModuleName name
+ occ = nameOccName name
+\end{code}
+
+
+%************************************************************************
+%* *
+ Equality, for interface file version generaion only
+%* *
+%************************************************************************
+
+Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
+EqBut, which gives the set of *locally-defined* things whose version must be equal
+for the whole thing to be equal. So the key function is eqIfExt, which compares
+IfaceExtNames.
+
+Of course, equality is also done modulo alpha conversion.
+
+\begin{code}
+data IfaceEq
+ = Equal -- Definitely exactly the same
+ | NotEqual -- Definitely different
+ | EqBut OccSet -- The same provided these local things have not changed
+
+bool :: Bool -> IfaceEq
+bool True = Equal
+bool False = NotEqual
+
+zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
+zapEq (EqBut _) = Equal
+zapEq other = other
+
+(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
+Equal &&& x = x
+NotEqual &&& x = NotEqual
+EqBut occs &&& Equal = EqBut occs
+EqBut occs &&& NotEqual = NotEqual
+EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
+
+---------------------
+eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
+-- This function is the core of the EqBut stuff
+eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
+eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
+eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
+eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
+eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
+eqIfExt n1 n2 = NotEqual
+\end{code}
+
+
+\begin{code}
+---------------------
+eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
+eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
+ = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
+
+eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
+ = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
+
+eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
+ = bool (ifName d1 == ifName d2 &&
+ ifND d1 == ifND d2 &&
+ ifRec d1 == ifRec d2 &&
+ ifVrcs d1 == ifVrcs d2 &&
+ ifGeneric d1 == ifGeneric d2) &&&
+ eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
+ eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
+ eq_hsCD env (ifCons d1) (ifCons d2)
+ )
+
+eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
+ = bool (ifName d1 == ifName d2) &&&
+ eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
+ eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
+ )
+
+eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
+ = bool (ifName d1 == ifName d2 &&
+ ifRec d1 == ifRec d2 &&
+ ifVrcs d1 == ifVrcs d2) &&&
+ eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
+ eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
+ eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
+ eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
+ )
+
+eqIfDecl _ _ = NotEqual -- default case
+
+-- Helper
+eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
+eqWith = eq_ifTvBndrs emptyEqEnv
+
+-----------------------
+eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&&
+ zapEq (ifInstHead d1 `eqIfType` ifInstHead d2)
+ -- zapEq: for instances, ignore the EqBut part
+
+eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
+ (IfaceRule n2 a2 bs2 f2 es2 rhs2)
+ = bool (n1==n2 && a1==a2) &&&
+ f1 `eqIfExt` f2 &&&
+ eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
+ zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
+ -- zapEq: for the LHSs, ignore the EqBut part
+ eq_ifaceExpr env rhs1 rhs2)
+eqIfRule _ _ = NotEqual
+
+eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
+eq_hsCD env Unknown Unknown = Equal
+eq_hsCD env d1 d2 = NotEqual
+
+eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
+ (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
+ = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&&
+ eq_ifTvBndrs env tvs1 tvs2 (\ env ->
+ eq_ifContext env cxt1 cxt2 &&&
+ eq_ifTypes env args1 args2)
+
+eq_hsFD env (ns1,ms1) (ns2,ms2)
+ = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
+
+eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
+ = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
+\end{code}
+
+
+\begin{code}
+-----------------
+eqIfIdInfo NoInfo NoInfo = Equal
+eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen?
+eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
+eqIfIdInfo i1 i2 = NotEqual
+
+eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
+eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
+eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
+eq_item HsNoCafRefs HsNoCafRefs = Equal
+eq_item (HsWorker occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2)
+eq_item _ _ = NotEqual
+
+-----------------
+eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
+eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
+eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
+eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
+eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
+eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
+eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
+eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
+eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
+eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
+
+eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
+ = eq_ifaceExpr env s1 s2 &&&
+ eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
+ where
+ eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
+ = bool (eq_ifaceConAlt c1 c2) &&&
+ eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
+
+eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
+ = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
+
+eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
+ = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
+ where
+ (bs1,rs1) = unzip as1
+ (bs2,rs2) = unzip as2
+
+
+eq_ifaceExpr env _ _ = NotEqual
+
+-----------------
+eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
+eq_ifaceConAlt IfaceDefault IfaceDefault = True
+eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
+eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
+eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
+eq_ifaceConAlt _ _ = False
+
+-----------------
+eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
+eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
+eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
+eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
+eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
+eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
+eq_ifaceNote env _ _ = NotEqual
+\end{code}
+
+\begin{code}
+---------------------
+eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
+
+-------------------
+eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
+eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
+eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
+eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
+eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
+eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
+eq_ifType env _ _ = NotEqual
+
+-------------------
+eq_ifTypes env = eqListBy (eq_ifType env)
+
+-------------------
+eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
+
+-------------------
+eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
+eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
+eq_ifPredType env _ _ = NotEqual
+
+-------------------
+eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
+eqIfTc IfaceIntTc IfaceIntTc = Equal
+eqIfTc IfaceCharTc IfaceCharTc = Equal
+eqIfTc IfaceBoolTc IfaceBoolTc = Equal
+eqIfTc IfaceListTc IfaceListTc = Equal
+eqIfTc IfacePArrTc IfacePArrTc = Equal
+eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
+eqIfTc _ _ = NotEqual
+\end{code}
+
+-----------------------------------------------------------
+ Support code for equality checking
+-----------------------------------------------------------
+
+\begin{code}
+------------------------------------
+type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
+
+eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
+eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
+ Just n1 -> bool (n1 == n2)
+ Nothing -> bool (n1 == n2)
+
+extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
+extendEqEnv env n1 n2 | n1 == n2 = env
+ | otherwise = extendOccEnv env n1 n2
+
+emptyEqEnv :: EqEnv
+emptyEqEnv = emptyOccEnv
+
+------------------------------------
+type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
+
+eq_ifNakedBndr :: ExtEnv OccName
+eq_ifBndr :: ExtEnv IfaceBndr
+eq_ifTvBndr :: ExtEnv IfaceTvBndr
+eq_ifIdBndr :: ExtEnv IfaceIdBndr
+
+eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
+
+eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
+eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
+eq_ifBndr _ _ _ _ = NotEqual
+
+eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2)
+eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
+
+eq_ifBndrs :: ExtEnv [IfaceBndr]
+eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
+eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
+eq_ifNakedBndrs :: ExtEnv [OccName]
+eq_ifBndrs = eq_bndrs_with eq_ifBndr
+eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
+eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
+eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
+
+eq_bndrs_with eq env [] [] k = k env
+eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
+eq_bndrs_with eq env _ _ _ = NotEqual
+\end{code}
+
+\begin{code}
+eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
+eqListBy eq [] [] = Equal
+eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
+eqListBy eq xs ys = NotEqual
+
+eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
+eqMaybeBy eq Nothing Nothing = Equal
+eqMaybeBy eq (Just x) (Just y) = eq x y
+eqMaybeBy eq x y = NotEqual
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+
+ This module defines intereace types and binders
+
+\begin{code}
+module IfaceType (
+ IfaceType(..), IfaceKind(..), IfacePredType(..), IfaceTyCon(..),
+ IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
+
+ IfaceExtName(..), mkIfaceExtName, ifaceTyConName,
+
+ -- Conversion from Type -> IfaceType
+ toIfaceType, toIfaceKind, toIfacePred, toIfaceContext,
+ toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
+
+ -- Printing
+ pprIfaceKind, pprParendIfaceKind,
+ pprIfaceType, pprParendIfaceType, pprIfaceContext,
+ pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
+ getIfaceExt,
+ tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
+
+ ) where
+
+#include "HsVersions.h"
+
+import Type ( openTypeKind, liftedTypeKind, unliftedTypeKind,
+ splitFunTy_maybe, eqKind )
+import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
+import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
+import Var ( isId, tyVarKind, idType )
+import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
+import OccName ( OccName )
+import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName )
+import Module ( ModuleName )
+import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
+import Outputable
+import FastString
+
+#ifdef DEBUG
+import TypeRep( crudePprType )
+#endif
+\end{code}
+
+
+%************************************************************************
+%* *
+ IfaceExtName
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceExtName
+ = ExtPkg ModuleName OccName -- From an external package; no version #
+ -- Also used for wired-in things regardless
+ -- of whether they are home-pkg or not
+
+ | HomePkg ModuleName OccName Version -- From another module in home package;
+ -- has version #
+
+ | LocalTop OccName -- Top-level from the same module as
+ -- the enclosing IfaceDecl
+
+ | LocalTopSub -- Same as LocalTop, but for a class method or constr
+ OccName -- Class-meth/constr name
+ OccName -- Parent class/datatype name
+ -- LocalTopSub is written into iface files as LocalTop; the parent
+ -- info is only used when computing version information in MkIface
+
+mkIfaceExtName name = ExtPkg (nameModuleName name) (nameOccName name)
+ -- Local helper for wired-in names
+\end{code}
+
+
+%************************************************************************
+%* *
+ Local (nested) binders
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceBndr -- Local (non-top-level) binders
+ = IfaceIdBndr IfaceIdBndr
+ | IfaceTvBndr IfaceTvBndr
+
+type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local
+type IfaceTvBndr = (OccName, IfaceKind)
+
+-------------------------------
+data IfaceKind
+ = IfaceLiftedTypeKind
+ | IfaceOpenTypeKind
+ | IfaceUnliftedTypeKind
+ | IfaceFunKind IfaceKind IfaceKind
+ deriving( Eq )
+
+-------------------------------
+data IfaceType
+ = IfaceTyVar OccName -- Type variable only, not tycon
+ | IfaceAppTy IfaceType IfaceType
+ | IfaceForAllTy IfaceTvBndr IfaceType
+ | IfacePredTy IfacePredType
+ | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
+ -- Includes newtypes, synonyms, tuples
+ | IfaceFunTy IfaceType IfaceType
+
+data IfacePredType -- NewTypes are handled as ordinary TyConApps
+ = IfaceClassP IfaceExtName [IfaceType]
+ | IfaceIParam (IPName OccName) IfaceType
+
+type IfaceContext = [IfacePredType]
+
+data IfaceTyCon -- Abbreviations for common tycons with known names
+ = IfaceTc IfaceExtName -- The common case
+ | IfaceIntTc | IfaceBoolTc | IfaceCharTc
+ | IfaceListTc | IfacePArrTc
+ | IfaceTupTc Boxity Arity
+
+ifaceTyConName :: IfaceTyCon -> Name -- Works for all except IfaceTc
+ifaceTyConName IfaceIntTc = intTyConName
+ifaceTyConName IfaceBoolTc = boolTyConName
+ifaceTyConName IfaceCharTc = charTyConName
+ifaceTyConName IfaceListTc = listTyConName
+ifaceTyConName IfacePArrTc = parrTyConName
+ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar)
+ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Functions over IFaceTypes
+%* *
+%************************************************************************
+
+
+\begin{code}
+splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], IfaceContext, IfaceType)
+-- Mainly for printing purposes
+splitIfaceSigmaTy ty
+ = (tvs,theta,tau)
+ where
+ (tvs, rho) = split_foralls ty
+ (theta, tau) = split_rho rho
+
+ split_foralls (IfaceForAllTy tv ty)
+ = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
+ split_foralls rho = ([], rho)
+
+ split_rho (IfaceFunTy (IfacePredTy st) ty)
+ = case split_rho ty of { (sts, tau) -> (st:sts, tau) }
+ split_rho tau = ([], tau)
+\end{code}
+
+%************************************************************************
+%* *
+ Pretty-printing
+%* *
+%************************************************************************
+
+Precedence
+~~~~~~~~~~
+@ppr_ty@ takes an @Int@ that is the precedence of the context.
+The precedence levels are:
+\begin{description}
+\item[tOP_PREC] No parens required.
+\item[fUN_PREC] Left hand argument of a function arrow.
+\item[tYCON_PREC] Argument of a type constructor.
+\end{description}
+
+\begin{code}
+tOP_PREC = (0 :: Int) -- type in ParseIface.y
+fUN_PREC = (1 :: Int) -- btype in ParseIface.y
+tYCON_PREC = (2 :: Int) -- atype in ParseIface.y
+
+noParens :: SDoc -> SDoc
+noParens pp = pp
+
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = parens pretty
+\end{code}
+
+
+----------------------------- Printing binders ------------------------------------
+
+\begin{code}
+instance Outputable IfaceExtName where
+ ppr (ExtPkg mod occ) = ppr mod <> dot <> ppr occ
+ ppr (HomePkg mod occ vers) = ppr mod <> dot <> ppr occ <> braces (ppr vers)
+ ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these
+ ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
+
+getIfaceExt :: ((Name -> IfaceExtName) -> SDoc) -> SDoc
+-- Uses the print-unqual info from the SDoc to make an 'ext'
+-- which in turn tells toIfaceType when to make a qualified name
+-- This is only used when making Iface stuff to print out for the user;
+-- e.g. we use this in pprType
+getIfaceExt thing_inside
+ = getPprStyle $ \ sty ->
+ let
+ ext nm | unqualStyle sty nm = LocalTop (nameOccName nm)
+ | isInternalName nm = LocalTop (nameOccName nm)
+ -- This only happens for Kind constructors, which
+ -- don't come from any particular module and are unqualified
+ -- This hack will go away when kinds are separated from types
+ | otherwise = ExtPkg (nameModuleName nm) (nameOccName nm)
+ in
+ thing_inside ext
+
+instance Outputable IfaceBndr where
+ ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
+ ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr
+
+pprIfaceBndrs :: [IfaceBndr] -> SDoc
+pprIfaceBndrs bs = sep (map ppr bs)
+
+pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
+
+pprIfaceTvBndr :: IfaceTvBndr -> SDoc
+pprIfaceTvBndr (tv, IfaceLiftedTypeKind) = ppr tv
+pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
+
+pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
+pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars)
+\end{code}
+
+----------------------------- Printing IfaceType ------------------------------------
+
+\begin{code}
+---------------------------------
+instance Outputable IfaceKind where
+ ppr k = pprIfaceKind tOP_PREC k
+
+pprParendIfaceKind :: IfaceKind -> SDoc
+pprParendIfaceKind k = pprIfaceKind tYCON_PREC k
+
+pprIfaceKind prec IfaceLiftedTypeKind = ptext SLIT("*")
+pprIfaceKind prec IfaceUnliftedTypeKind = ptext SLIT("#")
+pprIfaceKind prec IfaceOpenTypeKind = ptext SLIT("?")
+pprIfaceKind prec (IfaceFunKind k1 k2) = maybeParen prec fUN_PREC $
+ sep [ pprIfaceKind fUN_PREC k1, arrow <+> ppr k2]
+
+---------------------------------
+instance Outputable IfaceType where
+ ppr ty = ppr_ty ty
+
+ppr_ty = pprIfaceType tOP_PREC
+pprParendIfaceType = pprIfaceType tYCON_PREC
+
+pprIfaceType :: Int -> IfaceType -> SDoc
+
+
+ -- Simple cases
+pprIfaceType ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
+pprIfaceType ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
+pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st)
+
+ -- Function types
+pprIfaceType ctxt_prec (IfaceFunTy ty1 ty2)
+ = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ maybeParen ctxt_prec fUN_PREC $
+ sep (pprIfaceType fUN_PREC ty1 : ppr_fun_tail ty2)
+ where
+ ppr_fun_tail (IfaceFunTy ty1 ty2)
+ = (arrow <+> pprIfaceType fUN_PREC ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty
+ = [arrow <+> ppr_ty other_ty]
+
+pprIfaceType ctxt_prec (IfaceAppTy ty1 ty2)
+ = maybeParen ctxt_prec tYCON_PREC $
+ pprIfaceType fUN_PREC ty1 <+> pprParendIfaceType ty2
+
+pprIfaceType ctxt_prec ty@(IfaceForAllTy _ _)
+ = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (ppr_ty tau))
+ where
+ (tvs, theta, tau) = splitIfaceSigmaTy ty
+
+-------------------
+pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc
+pprIfaceForAllPart tvs ctxt doc
+ = sep [ppr_tvs, pprIfaceContext ctxt, doc]
+ where
+ ppr_tvs | null tvs = empty
+ | otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot
+
+-------------------
+ppr_tc_app ctxt_prec tc [] = ppr tc
+ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (ppr_ty ty)
+ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (ppr_ty ty)
+ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
+ | arity == length tys
+ = tupleParens bx (sep (punctuate comma (map ppr_ty tys)))
+ppr_tc_app ctxt_prec tc tys
+ = maybeParen ctxt_prec tYCON_PREC
+ (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+
+-------------------
+instance Outputable IfacePredType where
+ -- Print without parens
+ ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty]
+ ppr (IfaceClassP cls ts) = ppr cls <+> sep (map pprParendIfaceType ts)
+
+instance Outputable IfaceTyCon where
+ ppr (IfaceTc ext) = ppr ext
+ ppr other_tc = ppr (ifaceTyConName other_tc)
+
+-------------------
+pprIfaceContext :: IfaceContext -> SDoc
+-- Prints "(C a, D b) =>", including the arrow
+pprIfaceContext [] = empty
+pprIfaceContext theta = parens (sep (punctuate comma (map ppr theta)))
+ <+> ptext SLIT("=>")
+
+pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+\end{code}
+
+%************************************************************************
+%* *
+ Conversion from Type to IfaceType
+%* *
+%************************************************************************
+
+\begin{code}
+----------------
+toIfaceTvBndr tyvar = (getOccName tyvar, toIfaceKind (tyVarKind tyvar))
+toIfaceIdBndr ext id = (getOccName id, toIfaceType ext (idType id))
+toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
+
+toIfaceBndr ext var
+ | isId var = IfaceIdBndr (toIfaceIdBndr ext var)
+ | otherwise = IfaceTvBndr (toIfaceTvBndr var)
+
+---------------------
+toIfaceKind :: Kind -> IfaceKind
+toIfaceKind k
+ | k `eqKind` openTypeKind = IfaceOpenTypeKind
+ | k `eqKind` liftedTypeKind = IfaceLiftedTypeKind
+ | k `eqKind` unliftedTypeKind = IfaceUnliftedTypeKind
+ | Just (arg,res) <- splitFunTy_maybe k
+ = IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
+#ifdef DEBUG
+ | otherwise = pprPanic "toIfaceKind" (crudePprType k)
+#endif
+
+---------------------
+toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
+toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv)
+toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
+toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
+toIfaceType ext (NewTcApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
+toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
+toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
+toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st)
+toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app
+toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty
+
+----------------
+mkIfaceTc :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
+mkIfaceTc ext tc
+ | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | nm == intTyConName = IfaceIntTc
+ | nm == boolTyConName = IfaceBoolTc
+ | nm == charTyConName = IfaceCharTc
+ | nm == listTyConName = IfaceListTc
+ | nm == parrTyConName = IfacePArrTc
+ | otherwise = IfaceTc (ext nm)
+ where
+ nm = getName tc
+
+----------------
+toIfaceTypes ext ts = map (toIfaceType ext) ts
+
+----------------
+toIfacePred ext (ClassP cls ts) = IfaceClassP (ext (getName cls)) (toIfaceTypes ext ts)
+toIfacePred ext (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (toIfaceType ext t)
+
+----------------
+toIfaceContext :: (Name -> IfaceExtName) -> ThetaType -> IfaceContext
+toIfaceContext ext cs = map (toIfacePred ext) cs
+\end{code}
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{Dealing with interface files}
+
+\begin{code}
+module LoadIface (
+ loadHomeInterface, loadInterface, loadSysInterface,
+ loadSrcInterface, loadOrphanModules,
+ readIface, -- Used when reading the module's old interface
+ predInstGates, ifaceInstGates, ifaceStats,
+ initExternalPackageState
+ ) where
+
+#include "HsVersions.h"
+
+import DriverState ( v_GhcMode, isCompManagerMode )
+import DriverUtil ( replaceFilenameSuffix )
+import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ),
+ opt_InPackage )
+import Parser ( parseIface )
+
+import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..),
+ IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
+ IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
+import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
+import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
+ ExternalPackageState(..), emptyTypeEnv, emptyPool,
+ lookupIfaceByModName, emptyPackageIfaceTable,
+ IsBootInterface, mkIfaceFixCache,
+ Pool(..), DeclPool, InstPool,
+ RulePool, Gated, addRuleToPool
+ )
+
+import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
+import TcType ( Type, tcSplitTyConApp_maybe )
+import Type ( funTyCon )
+import TcRnMonad
+
+import PrelNames ( gHC_PRIM_Name )
+import PrelInfo ( ghcPrimExports )
+import PrelRules ( builtinRules )
+import Rules ( emptyRuleBase )
+import InstEnv ( emptyInstEnv )
+import Name ( Name {-instance NamedThing-}, getOccName,
+ nameModuleName, isInternalName )
+import NameEnv
+import MkId ( seqId )
+import Packages ( basePackage )
+import Module ( Module, ModuleName, ModLocation(ml_hi_file),
+ moduleName, isHomeModule, moduleEnvElts,
+ extendModuleEnv, lookupModuleEnvByName, moduleUserString
+ )
+import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc,
+ mkDataConWrapperOcc, mkDataConWorkerOcc )
+import Class ( Class, className )
+import TyCon ( DataConDetails(..), tyConName )
+import SrcLoc ( mkSrcLoc, importedSrcLoc )
+import Maybes ( isJust, mapCatMaybes )
+import StringBuffer ( hGetStringBuffer )
+import FastString ( mkFastString )
+import ErrUtils ( Message )
+import Finder ( findModule, findPackageModule,
+ hiBootExt, hiBootVerExt )
+import Lexer
+import Outputable
+import BinIface ( readBinIface )
+import Panic
+
+import DATA_IOREF ( readIORef )
+
+import Directory
+\end{code}
+
+
+%************************************************************************
+%* *
+ loadSrcInterface, loadOrphanModules
+
+ These two are called from TcM-land
+%* *
+%************************************************************************
+
+\begin{code}
+loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface
+-- This is called for each 'import' declaration in the source code
+-- On a failure, fail in the mnad with an error message
+
+loadSrcInterface doc mod_name want_boot
+ = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
+ (ImportByUser want_boot)
+ ; case mb_iface of
+ Left err -> failWithTc (elaborate err)
+ Right iface -> return iface
+ }
+ where
+ elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
+ quotes (ppr mod_name) <> colon) 4 err
+
+loadOrphanModules :: [ModuleName] -> TcM ()
+loadOrphanModules mods
+ | null mods = returnM ()
+ | otherwise = initIfaceTcRn $
+ do { traceIf (text "Loading orphan modules:" <+>
+ fsep (map ppr mods))
+ ; mappM_ load mods
+ ; returnM () }
+ where
+ load mod = loadSysInterface (mk_doc mod) mod
+ mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
+\end{code}
+
+%*********************************************************
+%* *
+ loadHomeInterface
+ Called from Iface-land
+%* *
+%*********************************************************
+
+\begin{code}
+loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface
+loadHomeInterface doc name
+ = ASSERT2( not (isInternalName name), ppr name <+> parens doc )
+ loadSysInterface doc (nameModuleName name)
+
+loadSysInterface :: SDoc -> ModuleName -> IfM lcl ModIface
+-- A wrapper for loadInterface that Throws an exception if it fails
+loadSysInterface doc mod_name
+ = do { mb_iface <- loadInterface doc mod_name ImportBySystem
+ ; case mb_iface of
+ Left err -> ghcError (ProgramError (showSDoc err))
+ Right iface -> return iface }
+\end{code}
+
+
+%*********************************************************
+%* *
+ loadInterface
+
+ The main function to load an interface
+ for an imported module, and put it in
+ the External Package State
+%* *
+%*********************************************************
+
+\begin{code}
+loadInterface :: SDoc -> ModuleName -> WhereFrom
+ -> IfM lcl (Either Message ModIface)
+-- If it can't find a suitable interface file, we
+-- a) modify the PackageIfaceTable to have an empty entry
+-- (to avoid repeated complaints)
+-- b) return (Left message)
+--
+-- It's not necessarily an error for there not to be an interface
+-- file -- perhaps the module has changed, and that interface
+-- is no longer used -- but the caller can deal with that by
+-- catching the exception
+
+loadInterface doc_str mod_name from
+ = do { -- Read the state
+ env <- getTopEnv
+ ; let { hpt = hsc_HPT env
+ ; eps_var = hsc_EPS env }
+ ; eps <- readMutVar eps_var
+ ; let { pit = eps_PIT eps }
+
+ -- Check whether we have the interface already
+ ; case lookupIfaceByModName hpt pit mod_name of {
+ Just iface
+ -> returnM (Right iface) ; -- Already loaded
+ -- The (src_imp == mi_boot iface) test checks that the already-loaded
+ -- interface isn't a boot iface. This can conceivably happen,
+ -- if an earlier import had a
+ -- before we got to real imports. I think.
+ other -> do
+
+ { if_gbl_env <- getGblEnv
+ ; let { hi_boot_file = case from of
+ ImportByUser usr_boot -> usr_boot
+ ImportBySystem -> sys_boot
+
+ ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name
+ ; sys_boot = case mb_dep of
+ Just (_, is_boot) -> is_boot
+ Nothing -> False
+ -- The boot-ness of the requested interface,
+ } -- based on the dependencies in directly-imported modules
+
+ -- READ THE MODULE IN
+ ; read_result <- findAndReadIface doc_str mod_name hi_boot_file
+ ; case read_result of {
+ Left err -> do
+ { let { -- Not found, so add an empty iface to
+ -- the EPS map so that we don't look again
+ fake_iface = emptyModIface opt_InPackage mod_name
+ ; new_pit = extendModuleEnv pit (mi_module fake_iface) fake_iface
+ ; new_eps = eps { eps_PIT = new_pit } }
+ ; writeMutVar eps_var new_eps
+ ; returnM (Left err) } ;
+
+ -- Found and parsed!
+ Right iface ->
+
+ let { mod = mi_module iface } in
+
+ -- Sanity check. If we're system-importing a module we know nothing at all
+ -- about, it should be from a different package to this one
+ WARN( case from of { ImportBySystem -> True; other -> False } &&
+ not (isJust mb_dep) &&
+ isHomeModule mod,
+ ppr mod )
+
+ initIfaceLcl (moduleName mod) $ do
+ -- Load the new ModIface into the External Package State
+ -- Even home-package interfaces loaded by loadInterface
+ -- (which only happens in OneShot mode; in Batch/Interactive
+ -- mode, home-package modules are loaded one by one into the HPT)
+ -- are put in the EPS.
+ --
+ -- The main thing is to add the ModIface to the PIT, but
+ -- we also take the
+ -- IfaceDecls, IfaceInst, IfaceRules
+ -- out of the ModIface and put them into the big EPS pools
+
+ -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
+ --- names is done correctly (notably, whether this is an .hi file or .hi-boot file).
+ -- If we do loadExport first the wrong info gets into the cache (unless we
+ -- explicitly tag each export which seems a bit of a bore)
+
+ { new_eps_decls <- loadDecls mod (eps_decls eps) (mi_decls iface)
+ ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface)
+ ; new_eps_rules <- loadRules mod (eps_rules eps) (mi_rules iface)
+
+ ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
+ mi_insts = panic "No mi_insts in PIT",
+ mi_rules = panic "No mi_rules in PIT" }
+
+ ; new_eps = eps { eps_PIT = extendModuleEnv pit mod final_iface,
+ eps_decls = new_eps_decls,
+ eps_rules = new_eps_rules,
+ eps_insts = new_eps_insts } }
+ ; writeMutVar eps_var new_eps
+ ; return (Right final_iface)
+ }}}}}
+
+-----------------------------------------------------
+-- Loading type/class/value decls
+-- We pass the full Module name here, replete with
+-- its package info, so that we can build a Name for
+-- each binder with the right package info in it
+-- All subsequent lookups, including crucially lookups during typechecking
+-- the declaration itself, will find the fully-glorious Name
+-----------------------------------------------------
+
+loadDecls :: Module -> DeclPool
+ -> [(Version, IfaceDecl)]
+ -> IfM lcl DeclPool
+loadDecls mod (Pool decls_map n_in n_out) decls
+ = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls
+ ; returnM (Pool decls_map' (n_in + length decls) n_out) }
+
+loadDecl ignore_prags mod decls_map (_version, decl)
+ = do { main_name <- mk_new_bndr Nothing (ifName decl)
+ ; let decl' | ignore_prags = zapIdInfo decl
+ | otherwise = decl
+
+ -- Populate the name cache with final versions of all the subordinate names
+ ; mapM_ (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl')
+
+ -- Extend the decls pool with a mapping for the main name (only)
+ ; returnM (extendNameEnv decls_map main_name decl') }
+ where
+ -- mk_new_bndr allocates in the name cache the final canonical
+ -- name for the thing, with the correct
+ -- * package info
+ -- * parent
+ -- * location
+ -- imported name, to fix the module correctly in the cache
+ mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
+ loc = importedSrcLoc (moduleUserString mod)
+
+zapIdInfo decl@(IfaceId { ifIdInfo = HasInfo _ }) = decl { ifIdInfo = DiscardedInfo }
+zapIdInfo decl = decl
+
+-----------------
+ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- Rather revolting, because it has to predict what gets bound
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
+ = [tc_occ, dc_occ] ++
+ [op | IfaceClassOp op _ _ <- sigs] ++
+ [mkSuperDictSelOcc n cls_occ | n <- [1..length sc_ctxt]] ++
+ -- The worker and wrapper for the DataCon of the class TyCon
+ -- are based off the data-con name
+ [mkDataConWrapperOcc dc_occ, mkDataConWorkerOcc dc_occ]
+ where
+ tc_occ = mkClassTyConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
+
+ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = []
+ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons})
+ = foldr ((++) . conDeclBndrs) [] cons
+
+ifaceDeclSubBndrs other = []
+
+conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
+ = [con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
+ ++ fields
+
+
+-----------------------------------------------------
+-- Loading instance decls
+-----------------------------------------------------
+
+loadInsts :: Module -> InstPool -> [IfaceInst] -> IfL InstPool
+loadInsts mod (Pool pool n_in n_out) decls
+ = do { new_pool <- foldlM (loadInstDecl (moduleName mod)) pool decls
+ ; returnM (Pool new_pool
+ (n_in + length decls)
+ n_out) }
+
+loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty})
+ = do {
+ -- Find out what type constructors and classes are "gates" for the
+ -- instance declaration. If all these "gates" are slurped in then
+ -- we should slurp the instance decl too.
+ --
+ -- We *don't* want to count names in the context part as gates, though.
+ -- For example:
+ -- instance Foo a => Baz (T a) where ...
+ --
+ -- Here the gates are Baz and T, but *not* Foo.
+ --
+ -- HOWEVER: functional dependencies make things more complicated
+ -- class C a b | a->b where ...
+ -- instance C Foo Baz where ...
+ -- Here, the gates are really only C and Foo, *not* Baz.
+ -- That is, if C and Foo are visible, even if Baz isn't, we must
+ -- slurp the decl.
+ --
+ -- Rather than take fundeps into account "properly", we just slurp
+ -- if C is visible and *any one* of the Names in the types
+ -- This is a slightly brutal approximation, but most instance decls
+ -- are regular H98 ones and it's perfect for them.
+ --
+ -- NOTICE that we rename the type before extracting its free
+ -- variables. The free-variable finder for a renamed HsType
+ -- does the Right Thing for built-in syntax like [] and (,).
+ let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
+ ; cls <- lookupIfaceExt cls_ext
+ ; tcs <- mapM lookupIfaceTc tc_exts
+ ; let { new_pool = extendNameEnv_C combine pool cls [(tcs, (mod,decl))]
+ ; combine old _ = (tcs,(mod,decl)) : old }
+ ; returnM new_pool
+ }
+
+-----------------------------------------------------
+-- Loading Rules
+-----------------------------------------------------
+
+loadRules :: Module -> RulePool -> [IfaceRule] -> IfL RulePool
+loadRules mod pool@(Pool rule_pool n_in n_out) rules
+ = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; if ignore_prags then
+ returnM pool
+ else do
+ { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
+ ; returnM (Pool new_pool (n_in + length rules) n_out) } }
+
+loadRule :: ModuleName -> NameEnv [Gated IfaceRule] -> IfaceRule -> IfL (NameEnv [Gated IfaceRule])
+-- "Gate" the rule simply by a crude notion of the free vars of
+-- the LHS. It can be crude, because having too few free vars is safe.
+loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
+ = do { names <- mapM lookupIfaceExt (fn : arg_fvs)
+ ; returnM (addRuleToPool pool (mod_name, decl) names) }
+ where
+ arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg]
+
+---------------------------
+crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName]
+-- A crude approximation to the free external names of an IfExpr
+-- Returns a subset of the true answer
+crudeIfExprGblFvs (IfaceType ty) = get_tcs ty
+crudeIfExprGblFvs (IfaceExt v) = [v]
+crudeIfExprGblFvs other = [] -- Well, I said it was crude
+
+get_tcs :: IfaceType -> [IfaceExtName]
+-- Get a crude subset of the TyCons of an IfaceType
+get_tcs (IfaceTyVar _) = []
+get_tcs (IfaceAppTy t1 t2) = get_tcs t1 ++ get_tcs t2
+get_tcs (IfaceFunTy t1 t2) = get_tcs t1 ++ get_tcs t2
+get_tcs (IfaceForAllTy _ t) = get_tcs t
+get_tcs (IfacePredTy st) = case st of
+ IfaceClassP cl ts -> get_tcs_s ts
+ IfaceIParam _ t -> get_tcs t
+get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts
+get_tcs (IfaceTyConApp other ts) = get_tcs_s ts
+
+-- The lists are always small => appending is fine
+get_tcs_s :: [IfaceType] -> [IfaceExtName]
+get_tcs_s tys = foldr ((++) . get_tcs) [] tys
+\end{code}
+
+
+%*********************************************************
+%* *
+ Gating
+%* *
+%*********************************************************
+
+Extract the gates of an instance declaration
+
+\begin{code}
+ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon])
+-- Return the class, and the tycons mentioned in the rest of the head
+-- We only pick the TyCon at the root of each type, to avoid
+-- difficulties with overlap. For example, suppose there are interfaces
+-- in the pool for
+-- C Int b
+-- C a [b]
+-- C a [T]
+-- Then, if we are trying to resolve (C Int x), we need the first
+-- if we are trying to resolve (C x [y]), we need *both* the latter
+-- two, even though T is not involved yet, so that we spot the overlap
+
+ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t
+ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t
+ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys
+ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
+ -- The other cases should not happen
+
+instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys)
+ where
+ root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName)
+ root_tycon (IfaceTyConApp tc _) = Just tc
+ root_tycon other = Nothing
+
+funTyConExtName = mkIfaceExtName (tyConName funTyCon)
+
+
+predInstGates :: Class -> [Type] -> (Name, [Name])
+-- The same function, only this time on the predicate found in a dictionary
+predInstGates cls tys
+ = (className cls, mapCatMaybes root_tycon tys)
+ where
+ root_tycon ty = case tcSplitTyConApp_maybe ty of
+ Just (tc, _) -> Just (tyConName tc)
+ Nothing -> Nothing
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Reading an interface file}
+%* *
+%*********************************************************
+
+\begin{code}
+findAndReadIface :: SDoc -> ModuleName
+ -> IsBootInterface -- True <=> Look for a .hi-boot file
+ -- False <=> Look for .hi file
+ -> IfM lcl (Either Message ModIface)
+ -- Nothing <=> file not found, or unreadable, or illegible
+ -- Just x <=> successfully found and parsed
+
+ -- It *doesn't* add an error to the monad, because
+ -- sometimes it's ok to fail... see notes with loadInterface
+
+findAndReadIface doc_str mod_name hi_boot_file
+ = do { traceIf (sep [hsep [ptext SLIT("Reading"),
+ if hi_boot_file
+ then ptext SLIT("[boot]")
+ else empty,
+ ptext SLIT("interface for"),
+ ppr mod_name <> semi],
+ nest 4 (ptext SLIT("reason:") <+> doc_str)])
+
+ -- Check for GHC.Prim, and return its static interface
+ ; if mod_name == gHC_PRIM_Name
+ then returnM (Right ghcPrimIface)
+ else do
+
+ -- Look for the file
+ ; mb_found <- ioToIOEnv (findHiFile mod_name hi_boot_file)
+ ; case mb_found of {
+ Left files -> do
+ { traceIf (ptext SLIT("...not found"))
+ ; dflags <- getDOpts
+ ; returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) } ;
+
+ Right file_path -> do
+
+ -- Found file, so read it
+ { traceIf (ptext SLIT("readIFace") <+> text file_path)
+ ; read_result <- readIface mod_name file_path hi_boot_file
+ ; case read_result of
+ Left err -> returnM (Left (badIfaceFile file_path err))
+ Right iface -> returnM (Right iface)
+ }}}
+
+findHiFile :: ModuleName -> IsBootInterface
+ -> IO (Either [FilePath] FilePath)
+findHiFile mod_name hi_boot_file
+ = do {
+ -- In interactive or --make mode, we are *not allowed* to demand-load
+ -- a home package .hi file. So don't even look for them.
+ -- This helps in the case where you are sitting in eg. ghc/lib/std
+ -- and start up GHCi - it won't complain that all the modules it tries
+ -- to load are found in the home location.
+ ghci_mode <- readIORef v_GhcMode ;
+ let { home_allowed = hi_boot_file ||
+ not (isCompManagerMode ghci_mode) } ;
+ maybe_found <- if home_allowed
+ then findModule mod_name
+ else findPackageModule mod_name ;
+
+ case maybe_found of {
+ Left files -> return (Left files) ;
+
+ Right (_, loc) -> do { -- Don't need module returned by finder
+
+ -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
+ let { hi_path = ml_hi_file loc ;
+ hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
+ hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
+ };
+
+ if not hi_boot_file then
+ return (Right hi_path)
+ else do {
+ hi_ver_exists <- doesFileExist hi_boot_ver_path ;
+ if hi_ver_exists then return (Right hi_boot_ver_path)
+ else return (Right hi_boot_path)
+ }}}}
+\end{code}
+
+@readIface@ tries just the one file.
+
+\begin{code}
+readIface :: ModuleName -> String -> IsBootInterface
+ -> IfM lcl (Either Message ModIface)
+ -- Left err <=> file not found, or unreadable, or illegible
+ -- Right iface <=> successfully found and parsed
+
+readIface wanted_mod_name file_path is_hi_boot_file
+ = do { dflags <- getDOpts
+ ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) }
+
+read_iface dflags wanted_mod file_path is_hi_boot_file
+ | is_hi_boot_file -- Read ascii
+ = do { res <- tryMost (hGetStringBuffer file_path) ;
+ case res of {
+ Left exn -> return (Left (text (showException exn))) ;
+ Right buffer ->
+ case unP parseIface (mkPState buffer loc dflags) of
+ PFailed loc1 loc2 err -> return (Left (showPFailed loc1 loc2 err))
+ POk _ iface
+ | wanted_mod == actual_mod -> return (Right iface)
+ | otherwise -> return (Left err)
+ where
+ actual_mod = moduleName (mi_module iface)
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
+ }}
+
+ | otherwise -- Read binary
+ = do { res <- tryMost (readBinIface file_path)
+ ; case res of
+ Right iface -> return (Right iface)
+ Left exn -> return (Left (text (showException exn))) }
+ where
+ loc = mkSrcLoc (mkFastString file_path) 1 0
+\end{code}
+
+
+%*********************************************************
+%* *
+ Wired-in interface for GHC.Prim
+%* *
+%*********************************************************
+
+\begin{code}
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+ = EPS {
+ eps_PIT = emptyPackageIfaceTable,
+ eps_PTE = emptyTypeEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_rule_base = emptyRuleBase,
+ eps_decls = emptyPool,
+ eps_insts = emptyPool,
+ eps_rules = foldr add emptyPool builtinRules
+ }
+ where
+ -- Initialise the EPS rule pool with the built-in rules
+ add (fn_name, core_rule) (Pool rules n_in n_out)
+ = Pool rules' (n_in+1) n_out
+ where
+ rules' = addRuleToPool rules iface_rule [fn_name]
+ iface_rule = (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)
+\end{code}
+
+
+%*********************************************************
+%* *
+ Wired-in interface for GHC.Prim
+%* *
+%*********************************************************
+
+\begin{code}
+ghcPrimIface :: ModIface
+ghcPrimIface
+ = (emptyModIface basePackage gHC_PRIM_Name) {
+ mi_exports = [(gHC_PRIM_Name, ghcPrimExports)],
+ mi_decls = [],
+ mi_fixities = fixities,
+ mi_fix_fn = mkIfaceFixCache fixities
+ }
+ where
+ fixities = [(getOccName seqId, Fixity 0 InfixR)]
+ -- seq is infixr 0
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Statistics}
+%* *
+%*********************************************************
+
+\begin{code}
+ifaceStats :: ExternalPackageState -> SDoc
+ifaceStats eps
+ = hcat [text "Renamer stats: ", stats]
+ where
+ n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
+ -- This is really only right for a one-shot compile
+
+ Pool _ n_decls_in n_decls_out = eps_decls eps
+ Pool _ n_insts_in n_insts_out = eps_insts eps
+ Pool _ n_rules_in n_rules_out = eps_rules eps
+
+ stats = vcat
+ [int n_mods <+> text "interfaces read",
+ hsep [ int n_decls_out, text "type/class/variable imported, out of",
+ int n_decls_in, text "read"],
+ hsep [ int n_insts_out, text "instance decls imported, out of",
+ int n_insts_in, text "read"],
+ hsep [ int n_rules_out, text "rule decls imported, out of",
+ int n_rules_in, text "read"]
+ ]
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Errors}
+%* *
+%*********************************************************
+
+\begin{code}
+badIfaceFile file err
+ = vcat [ptext SLIT("Bad interface file:") <+> text file,
+ nest 4 err]
+
+hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message
+hiModuleNameMismatchWarn requested_mod read_mod =
+ hsep [ ptext SLIT("Something is amiss; requested module name")
+ , ppr requested_mod
+ , ptext SLIT("differs from name found in the interface file")
+ , ppr read_mod
+ ]
+
+noIfaceErr dflags mod_name boot_file files
+ = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
+ $$ extra
+ where
+ extra
+ | verbosity dflags < 3 =
+ text "(use -v to see a list of the files searched for)"
+ | otherwise =
+ hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+
+\begin{code}
+module MkIface (
+ showIface, -- Print the iface in Foo.hi
+
+ mkUsageInfo, -- Construct the usage info for a module
+
+ mkIface, -- Build a ModIface from a ModGuts,
+ -- including computing version information
+
+ checkOldIface -- See if recompilation is required, by
+ -- comparing version information
+ ) where
+\end{code}
+
+ -----------------------------------------------
+ MkIface.lhs deals with versioning
+ -----------------------------------------------
+
+Here's the version-related info in an interface file
+
+ module Foo 8 -- module-version
+ 3 -- export-list-version
+ 2 -- rule-version
+ Usages: -- Version info for what this compilation of Foo imported
+ Baz 3 -- Module version
+ [4] -- The export-list version if Foo depended on it
+ (g,2) -- Function and its version
+ (T,1) -- Type and its version
+
+ <version> f :: Int -> Int {- Unfolding: \x -> Wib.t[2] x -}
+ -- The [2] says that f's unfolding
+ -- mentions verison 2 of Wib.t
+
+ -----------------------------------------------
+ Basic idea
+ -----------------------------------------------
+
+Basic idea:
+ * In the mi_usages information in an interface, we record the
+ version number of each free variable of the module
+
+ * In mkIface, we compute the version number of each exported thing A.f
+ by comparing its A.f's info with its new info, and bumping its
+ version number if it differs. If A.f mentions B.g, and B.g's version
+ number has changed, then we count A.f as having changed too.
+
+ * In checkOldIface we compare the mi_usages for the module with
+ the actual version info for all each thing recorded in mi_usages
+
+
+Fixities
+~~~~~~~~
+We count A.f as changing if its fixity changes
+
+Rules
+~~~~~
+If a rule changes, we want to recompile any module that might be
+affected by that rule. For non-orphan rules, this is relatively easy.
+If module M defines f, and a rule for f, just arrange that the version
+number for M.f changes if any of the rules for M.f change. Any module
+that does not depend on M.f can't be affected by the rule-change
+either.
+
+Orphan rules (ones whose 'head function' is not defined in M) are
+harder. Here's what we do.
+
+ * We have a per-module orphan-rule version number which changes if
+ any orphan rule changes. (It's unaffected by non-orphan rules.)
+
+ * We record usage info for any orphan module 'below' this one,
+ giving the orphan-rule version number. We recompile if this
+ changes.
+
+The net effect is that if an orphan rule changes, we recompile every
+module above it. That's very conservative, but it's devilishly hard
+to know what it might affect, so we just have to be conservative.
+
+Instance decls
+~~~~~~~~~~~~~~
+In an iface file we have
+ module A where
+ instance Eq a => Eq [a] = dfun29
+ dfun29 :: ...
+
+We have a version number for dfun29, covering its unfolding
+etc. Suppose we are compiling a module M that imports A only
+indirectly. If typechecking M uses this instance decl, we record the
+dependency on A.dfun29 as if it were a free variable of the module
+(via the tcg_inst_usages accumulator). That means that A will appear
+in M's usage list. If the shape of the instance declaration changes,
+then so will dfun29's version, triggering a recompilation.
+
+Adding an instance declaration, or changing an instance decl that is
+not currently used, is more tricky. (This really only makes a
+difference when we have overlapping instance decls, because then the
+new instance decl might kick in to override the old one.) We handle
+this in a very similar way that we handle rules above.
+
+ * For non-orphan instance decls, identify one locally-defined tycon/class
+ mentioned in the decl. Treat the instance decl as part of the defn of that
+ tycon/class, so that if the shape of the instance decl changes, so does the
+ tycon/class; that in turn will force recompilation of anything that uses
+ that tycon/class.
+
+ * For orphan instance decls, act the same way as for orphan rules.
+ Indeed, we use the same global orphan-rule version number.
+
+mkUsageInfo
+~~~~~~~~~~~
+mkUsageInfo figures out what the ``usage information'' for this
+moudule is; that is, what it must record in its interface file as the
+things it uses.
+
+We produce a line for every module B below the module, A, currently being
+compiled:
+ import B <n> ;
+to record the fact that A does import B indirectly. This is used to decide
+to look to look for B.hi rather than B.hi-boot when compiling a module that
+imports A. This line says that A imports B, but uses nothing in it.
+So we'll get an early bale-out when compiling A if B's version changes.
+
+The usage information records:
+
+\begin{itemize}
+\item (a) anything reachable from its body code
+\item (b) any module exported with a @module Foo@
+\item (c) anything reachable from an exported item
+\end{itemize}
+
+Why (b)? Because if @Foo@ changes then this module's export list
+will change, so we must recompile this module at least as far as
+making a new interface file --- but in practice that means complete
+recompilation.
+
+Why (c)? Consider this:
+\begin{verbatim}
+ module A( f, g ) where | module B( f ) where
+ import B( f ) | f = h 3
+ g = ... | h = ...
+\end{verbatim}
+
+Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in
+@A@'s usages? Our idea is that we aren't going to touch A.hi if it is
+*identical* to what it was before. If anything about @B.f@ changes
+than anyone who imports @A@ should be recompiled in case they use
+@B.f@ (they'll get an early exit if they don't). So, if anything
+about @B.f@ changes we'd better make sure that something in A.hi
+changes, and the convenient way to do that is to record the version
+number @B.f@ in A.hi in the usage list. If B.f changes that'll force a
+complete recompiation of A, which is overkill but it's the only way to
+write a new, slightly different, A.hi.
+
+But the example is tricker. Even if @B.f@ doesn't change at all,
+@B.h@ may do so, and this change may not be reflected in @f@'s version
+number. But with -O, a module that imports A must be recompiled if
+@B.h@ changes! So A must record a dependency on @B.h@. So we treat
+the occurrence of @B.f@ in the export list *just as if* it were in the
+code of A, and thereby haul in all the stuff reachable from it.
+
+ *** Conclusion: if A mentions B.f in its export list,
+ behave just as if A mentioned B.f in its source code,
+ and slurp in B.f and all its transitive closure ***
+
+[NB: If B was compiled with -O, but A isn't, we should really *still*
+haul in all the unfoldings for B, in case the module that imports A *is*
+compiled with -O. I think this is the case.]
+
+
+\begin{code}
+#include "HsVersions.h"
+
+import HsSyn
+import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
+ IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..),
+ eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
+ eqMaybeBy, eqListBy,
+ tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule )
+import LoadIface ( readIface, loadInterface, ifaceInstGates )
+import BasicTypes ( Version, initialVersion, bumpVersion )
+import TcRnMonad
+import TcRnTypes ( ImportAvails(..), mkModDeps )
+import HscTypes ( ModIface(..),
+ ModGuts(..), ModGuts, IfaceExport,
+ GhciMode(..),
+ HscEnv(..), hscEPS,
+ Dependencies(..), FixItem(..),
+ isImplicitTyThing,
+ mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
+ typeEnvElts,
+ Avails, AvailInfo, GenAvailInfo(..), availName,
+ ExternalPackageState(..),
+ Usage(..), IsBootInterface,
+ Deprecs(..), IfaceDeprecs, Deprecations,
+ lookupIfaceByModName
+ )
+
+
+import CmdLineOpts
+import Name ( Name, nameModule, nameOccName, nameParent, isExternalName,
+ nameParent_maybe, isWiredInName, NamedThing(..) )
+import NameEnv
+import NameSet
+import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C,
+ OccSet, emptyOccSet, elemOccSet, occSetElts,
+ extendOccSet, extendOccSetList,
+ isEmptyOccSet, intersectOccSet, intersectsOccSet )
+import TyCon ( visibleDataCons )
+import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
+ ModLocation(..), mkSysModuleNameFS, moduleUserString,
+ ModuleEnv, emptyModuleEnv, lookupModuleEnv,
+ extendModuleEnv_C, moduleEnvElts
+ )
+import Outputable
+import DriverUtil ( createDirectoryHierarchy, directoryOf )
+import Util ( sortLt, seqList )
+import Binary ( getBinFileWithDict )
+import BinIface ( writeBinIface, v_IgnoreHiVersion )
+import Unique ( Unique, Uniquable(..) )
+import ErrUtils ( dumpIfSet_dyn, showPass )
+import Digraph ( stronglyConnComp, SCC(..) )
+import FiniteMap
+import FastString
+
+import DATA_IOREF ( writeIORef )
+import Monad ( when )
+import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust )
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Completing an interface}
+%* *
+%************************************************************************
+
+\begin{code}
+mkIface :: HscEnv
+ -> ModLocation
+ -> Maybe ModIface -- The old interface, if we have it
+ -> ModGuts -- The compiled, tidied module
+ -> IO ModIface -- The new one, complete with decls and versions
+-- mkFinalIface
+-- a) completes the interface
+-- b) writes it out to a file if necessary
+
+mkIface hsc_env location maybe_old_iface
+ guts@ModGuts{ mg_module = this_mod,
+ mg_usages = usages,
+ mg_deps = deps,
+ mg_exports = exports,
+ mg_fix_env = fix_env,
+ mg_deprecs = src_deprecs,
+ mg_insts = insts,
+ mg_rules = rules,
+ mg_types = type_env }
+ = do { eps <- hscEPS hsc_env
+ ; let { this_mod_name = moduleName this_mod
+ ; ext_nm = mkExtNameFn hsc_env eps this_mod_name
+ ; decls = [ tyThingToIfaceDecl omit_prags ext_nm thing
+ | thing <- typeEnvElts type_env
+ , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ]
+ -- Don't put implicit Ids and class tycons in the interface file
+ -- Nor wired-in things (GHC knows about them already)
+
+ ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
+ ; deprecs = mkIfaceDeprec src_deprecs
+ ; iface_rules
+ | omit_prags = []
+ | otherwise = sortLt lt_rule $
+ map (coreRuleToIfaceRule this_mod_name ext_nm) rules
+ ; iface_insts = sortLt lt_inst (map (dfunToIfaceInst this_mod_name) insts)
+
+ ; intermediate_iface = ModIface {
+ mi_module = this_mod,
+ mi_package = opt_InPackage,
+ mi_boot = False,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = groupAvails this_mod exports,
+ mi_insts = iface_insts,
+ mi_rules = iface_rules,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+
+ -- Left out deliberately: filled in by addVersionInfo
+ mi_mod_vers = initialVersion,
+ mi_exp_vers = initialVersion,
+ mi_rule_vers = initialVersion,
+ mi_orphan = False, -- Always set by addVersionInfo, but
+ -- it's a strict field, so we can't omit it.
+ mi_decls = deliberatelyOmitted "decls",
+ mi_ver_fn = deliberatelyOmitted "ver_fn",
+
+ -- And build the cached values
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities }
+
+ -- Add version information
+ ; (new_iface, no_change_at_all, pp_diffs)
+ = _scc_ "versioninfo"
+ addVersionInfo maybe_old_iface intermediate_iface decls
+ }
+
+ -- Write the interface file, if necessary
+ ; when (not no_change_at_all && ghci_mode /= Interactive) $ do
+ createDirectoryHierarchy (directoryOf hi_file_path)
+ writeBinIface hi_file_path new_iface
+
+ -- Debug printing
+ ; when (dopt Opt_D_dump_hi_diffs dflags)
+ (printDump (write_diffs maybe_old_iface no_change_at_all pp_diffs))
+ ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+ (pprModIface new_iface)
+
+ ; return new_iface }
+ where
+ r1 `lt_rule` r2 = ifRuleName r1 < ifRuleName r2
+ i1 `lt_inst` i2 = ifDFun i1 < ifDFun i2
+
+ dflags = hsc_dflags hsc_env
+ ghci_mode = hsc_mode hsc_env
+ hi_file_path = ml_hi_file location
+ omit_prags = dopt Opt_OmitInterfacePragmas dflags
+
+deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
+-----------------------------
+mkExtNameFn :: HscEnv -> ExternalPackageState -> ModuleName -> Name -> IfaceExtName
+mkExtNameFn hsc_env eps this_mod
+ = ext_nm
+ where
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+
+ ext_nm name
+ | mod_nm == this_mod = case nameParent_maybe name of
+ Nothing -> LocalTop occ
+ Just par -> LocalTopSub occ (nameOccName par)
+ | isWiredInName name = ExtPkg mod_nm occ
+ | isHomeModule mod = HomePkg mod_nm occ vers
+ | otherwise = ExtPkg mod_nm occ
+ where
+ mod = nameModule name
+ mod_nm = moduleName mod
+ occ = nameOccName name
+ par_occ = nameOccName (nameParent name)
+ -- The version of the *parent* is the one want
+ vers = lookupVersion mod_nm par_occ
+
+ lookupVersion :: ModuleName -> OccName -> Version
+ -- Even though we're looking up a home-package thing, in
+ -- one-shot mode the imported interfaces may be in the PIT
+ lookupVersion mod occ
+ = mi_ver_fn iface occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr occ)
+ where
+ iface = lookupIfaceByModName hpt pit mod `orElse`
+ pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+
+-----------------------------
+-- Compute version numbers for local decls
+
+addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
+ -> ModIface -- The new interface decls (lacking decls)
+ -> [IfaceDecl] -- The new decls
+ -> (ModIface,
+ Bool, -- True <=> no changes at all; no need to write new Iface
+ SDoc) -- Differences
+
+addVersionInfo Nothing new_iface new_decls
+-- No old interface, so definitely write a new one!
+ = (new_iface { mi_orphan = anyNothing getInstKey (mi_insts new_iface)
+ || anyNothing getRuleKey (mi_rules new_iface),
+ mi_decls = [(initialVersion, decl) | decl <- new_decls],
+ mi_ver_fn = \n -> Just initialVersion },
+ False, text "No old interface available")
+
+addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers,
+ mi_exp_vers = old_exp_vers,
+ mi_rule_vers = old_rule_vers,
+ mi_decls = old_decls,
+ mi_ver_fn = old_decl_vers,
+ mi_fix_fn = old_fixities }))
+ new_iface@(ModIface { mi_fix_fn = new_fixities })
+ new_decls
+
+ | no_change_at_all = (old_iface, True, empty)
+ | otherwise = (final_iface, False, pp_diffs)
+ where
+ final_iface = new_iface { mi_mod_vers = bump_unless no_output_change old_mod_vers,
+ mi_exp_vers = bump_unless no_export_change old_exp_vers,
+ mi_rule_vers = bump_unless no_rule_change old_rule_vers,
+ mi_orphan = not (null new_orph_rules && null new_orph_insts),
+ mi_decls = decls_w_vers,
+ mi_ver_fn = mkIfaceVerCache decls_w_vers }
+
+ decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
+
+ -------------------
+ (new_non_orph_insts, new_orph_insts) = mkRuleMap getInstKey (mi_insts new_iface)
+ (old_non_orph_insts, old_orph_insts) = mkRuleMap getInstKey (mi_insts old_iface)
+ same_insts occ = eqMaybeBy (eqListBy eqIfInst)
+ (lookupOccEnv old_non_orph_insts occ)
+ (lookupOccEnv new_non_orph_insts occ)
+
+ (old_non_orph_rules, old_orph_rules) = mkRuleMap getRuleKey (mi_rules old_iface)
+ (new_non_orph_rules, new_orph_rules) = mkRuleMap getRuleKey (mi_rules new_iface)
+ same_rules occ = eqMaybeBy (eqListBy eqIfRule)
+ (lookupOccEnv old_non_orph_rules occ)
+ (lookupOccEnv new_non_orph_rules occ)
+ -------------------
+ -- Computing what changed
+ no_output_change = no_decl_change && no_rule_change &&
+ no_export_change && no_deprec_change
+ no_export_change = mi_exports new_iface == mi_exports old_iface -- Kept sorted
+ no_decl_change = isEmptyOccSet changed_occs
+ no_rule_change = not (changedWrt changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
+ || changedWrt changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts))
+ no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
+
+ -- If the usages havn't changed either, we don't need to write the interface file
+ -- Question: should we also check for equality of mi_deps?
+ no_other_changes = mi_usages new_iface == mi_usages old_iface
+ no_change_at_all = no_output_change && no_other_changes
+
+ pp_diffs = vcat [pp_decl_diffs,
+ pp_change no_export_change "Export list"
+ (ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)),
+ pp_change no_rule_change "Rules"
+ (ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)),
+ pp_change no_deprec_change "Deprecations" empty,
+ pp_change no_other_changes "Usages" empty]
+ pp_change True what info = empty
+ pp_change False what info = text what <+> ptext SLIT("changed") <+> info
+
+ -------------------
+ old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
+ same_fixity n = bool (old_fixities n == new_fixities n)
+
+ -------------------
+ -- Adding version info
+ new_version = bumpVersion old_mod_vers
+ add_vers decl | occ `elemOccSet` changed_occs = new_version
+ | otherwise = expectJust "add_vers" (old_decl_vers occ)
+ -- If it's unchanged, there jolly well
+ where -- should be an old version number
+ occ = ifName decl
+
+ -------------------
+ changed_occs :: OccSet
+ changed_occs = computeChangedOccs eq_info
+
+ eq_info :: [(OccName, IfaceEq)]
+ eq_info = map check_eq new_decls
+ check_eq new_decl | Just old_decl <- lookupOccEnv old_decl_env occ
+ = (occ, new_decl `eqIfDecl` old_decl &&&
+ eq_indirects new_decl)
+ | otherwise {- No corresponding old decl -}
+ = (occ, NotEqual)
+ where
+ occ = ifName new_decl
+
+ eq_indirects :: IfaceDecl -> IfaceEq
+ -- When seeing if two decls are the same, remember to
+ -- check whether any relevant fixity or rules have changed
+ eq_indirects (IfaceId {ifName = occ}) = eq_ind_occ occ
+ eq_indirects (IfaceClass {ifName = cls_occ, ifSigs = sigs})
+ = same_insts cls_occ &&&
+ eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
+ eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
+ = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
+ eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons]
+ eq_indirects other = Equal -- Synonyms and foreign declarations
+
+ eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
+ eq_ind_occ occ = same_fixity occ &&& same_rules occ
+ eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal
+
+ -------------------
+ -- Diffs
+ pp_decl_diffs :: SDoc -- Nothing => no changes
+ pp_decl_diffs
+ | isEmptyOccSet changed_occs = empty
+ | otherwise
+ = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs),
+ ptext SLIT("Version change for these decls:"),
+ nest 2 (vcat (map show_change new_decls))]
+
+ eq_env = mkOccEnv eq_info
+ show_change new_decl
+ | not (occ `elemOccSet` changed_occs) = empty
+ | otherwise
+ = vcat [ppr occ <+> ppr (old_decl_vers occ) <+> arrow <+> ppr new_version,
+ nest 2 why]
+ where
+ occ = ifName new_decl
+ why = case lookupOccEnv eq_env occ of
+ Just (EqBut occs) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"),
+ nest 2 (braces (fsep (map ppr (occSetElts
+ (occs `intersectOccSet` changed_occs)))))]
+ Just NotEqual
+ | Just old_decl <- lookupOccEnv old_decl_env occ
+ -> vcat [ptext SLIT("Old:") <+> ppr old_decl,
+ ptext SLIT("New:") <+> ppr new_decl]
+ | otherwise
+ -> ppr occ <+> ptext SLIT("only in new interface")
+ other -> pprPanic "MkIface.show_change" (ppr occ)
+
+
+computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet
+computeChangedOccs eq_info
+ = foldl add_changes emptyOccSet (stronglyConnComp edges)
+ where
+ edges :: [((OccName,IfaceEq), Unique, [Unique])]
+ edges = [ (node, getUnique occ, map getUnique occs)
+ | node@(occ, iface_eq) <- eq_info
+ , let occs = case iface_eq of
+ EqBut occ_set -> occSetElts occ_set
+ other -> [] ]
+
+ -- Changes in declarations
+ add_changes :: OccSet -> SCC (OccName, IfaceEq) -> OccSet
+ add_changes so_far (AcyclicSCC (occ, iface_eq))
+ | changedWrt so_far iface_eq -- This one has changed
+ = extendOccSet so_far occ
+ add_changes so_far (CyclicSCC pairs)
+ | changedWrt so_far (foldr1 (&&&) (map snd pairs)) -- One of this group has changed
+ = extendOccSetList so_far (map fst pairs)
+ add_changes so_far other = so_far
+
+changedWrt :: OccSet -> IfaceEq -> Bool
+changedWrt so_far Equal = False
+changedWrt so_far NotEqual = True
+changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
+
+----------------------
+-- mkRuleMap partitions instance decls or rules into
+-- (a) an OccEnv for ones that are not orphans,
+-- mapping the local OccName to a list of its decls
+-- (b) a list of orphan decls
+mkRuleMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ
+ -- Nothing for an orphan decl
+ -> [decl] -- Sorted into canonical order
+ -> (OccEnv [decl], -- Non-orphan decls associated with their key;
+ -- each sublist in canonical order
+ [decl]) -- Orphan decls; in canonical order
+mkRuleMap get_key decls
+ = foldl go (emptyOccEnv, []) decls
+ where
+ go (non_orphs, orphs) d
+ | Just occ <- get_key d
+ = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
+ | otherwise = (non_orphs, d:orphs)
+
+-- getXxKey: find at least one local OccName that belongs to this decl
+
+getInstKey :: IfaceInst -> Maybe OccName
+getInstKey (IfaceInst {ifInstHead = inst_ty})
+ = case [occ | LocalTop occ <- cls_ext : tc_exts] of
+ [] -> Nothing
+ (occ:_) -> Just occ
+ where
+ (cls_ext, tcs) = ifaceInstGates inst_ty
+ tc_exts = [tc | IfaceTc tc <- tcs]
+ -- Ignore the wired-in IfaceTyCons; the class will do as the key
+
+getRuleKey :: IfaceRule -> Maybe OccName
+getRuleKey (IfaceRule {ifRuleHead = LocalTop occ}) = Just occ
+getRuleKey other = Nothing
+
+anyNothing :: (a -> Maybe b) -> [a] -> Bool
+anyNothing p [] = False
+anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs
+
+----------------------
+mkIfaceDeprec :: Deprecations -> IfaceDeprecs
+mkIfaceDeprec NoDeprecs = NoDeprecs
+mkIfaceDeprec (DeprecAll t) = DeprecAll t
+mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLt (<) (nameEnvElts env))
+
+----------------------
+write_diffs :: Maybe ModIface -> Bool -> SDoc -> SDoc
+write_diffs Nothing _ _ = ptext SLIT("NO OLD INTERFACE FILE")
+write_diffs (Just _) True _ = ptext SLIT("INTERFACE UNCHANGED")
+write_diffs (Just _) False diffs = sep [ptext SLIT("INTERFACE HAS CHANGED"), nest 2 diffs]
+
+----------------------
+bump_unless :: Bool -> Version -> Version
+bump_unless True v = v -- True <=> no change
+bump_unless False v = bumpVersion v
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Keeping track of what we've slurped, and version numbers}
+%* *
+%*********************************************************
+
+
+\begin{code}
+mkUsageInfo :: HscEnv -> ImportAvails -> NameSet -> IO [Usage]
+mkUsageInfo hsc_env
+ (ImportAvails { imp_mods = dir_imp_mods,
+ imp_dep_mods = dep_mods })
+ used_names
+ = do { eps <- hscEPS hsc_env
+ ; return (mk_usage_info (eps_PIT eps) (hsc_HPT hsc_env)
+ dir_imp_mods dep_mods used_names) }
+
+mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names
+ = -- seq the list of Usages returned: occasionally these
+ -- don't get evaluated for a while and we can end up hanging on to
+ -- the entire collection of Ifaces.
+ usages `seqList` usages
+ where
+ used_names = mkNameSet $ -- Eliminate duplicates
+ [ nameParent n -- Just record usage on the 'main' names
+ | n <- nameSetToList proto_used_names
+ , not (isWiredInName n) -- Don't record usages for wired-in names
+ , isExternalName n -- Ignore internal names
+ ]
+
+ -- ent_map groups together all the things imported and used
+ -- from a particular module in this package
+ ent_map :: ModuleEnv [OccName]
+ ent_map = foldNameSet add_mv emptyModuleEnv used_names
+ add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [occ]
+ where
+ occ = nameOccName name
+ mod = nameModule name
+ add_item occs _ = occ:occs
+
+ usages = mapCatMaybes mkUsage (moduleEnvElts dep_mods)
+ -- ToDo: do we need to sort into canonical order?
+
+ import_all mod = case lookupModuleEnv dir_imp_mods mod of
+ Just (_,imp_all) -> isNothing imp_all
+ Nothing -> False
+
+ -- We want to create a Usage for a home module if
+ -- a) we used something from; has something in used_names
+ -- b) we imported all of it, even if we used nothing from it
+ -- (need to recompile if its export list changes: export_vers)
+ -- c) is a home-package orphan module (need to recompile if its
+ -- instance decls change: rules_vers)
+ mkUsage :: (ModuleName, Bool) -> Maybe Usage
+ mkUsage (mod_name, _)
+ | isNothing maybe_iface -- We can't depend on it if we didn't
+ || not (isHomeModule mod) -- even open the interface!
+ || (null used_occs
+ && not all_imported
+ && not orphan_mod)
+ = Nothing -- Record no usage info
+
+ | otherwise
+ = Just (Usage { usg_name = moduleName mod,
+ usg_mod = mod_vers,
+ usg_exports = export_vers,
+ usg_entities = ent_vers,
+ usg_rules = rules_vers })
+ where
+ maybe_iface = lookupIfaceByModName hpt pit mod_name
+ -- In one-shot mode, the interfaces for home-package
+ -- modules accumulate in the PIT not HPT. Sigh.
+
+ Just iface = maybe_iface
+ mod = mi_module iface
+ orphan_mod = mi_orphan iface
+ version_env = mi_ver_fn iface
+ mod_vers = mi_mod_vers iface
+ rules_vers = mi_rule_vers iface
+ all_imported = import_all mod
+ export_vers | all_imported = Just (mi_exp_vers iface)
+ | otherwise = Nothing
+
+ -- The sort is to put them into canonical order
+ used_occs = lookupModuleEnv ent_map mod `orElse` []
+ ent_vers :: [(OccName,Version)]
+ ent_vers = [ (occ, version_env occ `orElse` initialVersion)
+ | occ <- sortLt (<) used_occs]
+\end{code}
+
+\begin{code}
+groupAvails :: Module -> Avails -> [(ModuleName, [GenAvailInfo OccName])]
+ -- Group by module and sort by occurrence
+ -- This keeps the list in canonical order
+groupAvails this_mod avails
+ = [ (mkSysModuleNameFS fs, sortLt lt avails)
+ | (fs,avails) <- fmToList groupFM
+ ]
+ where
+ groupFM :: FiniteMap FastString [GenAvailInfo OccName]
+ -- Deliberately use the FastString so we
+ -- get a canonical ordering
+ groupFM = foldl add emptyFM avails
+
+ add env avail = addToFM_C (\old _ -> avail':old) env mod_fs [avail']
+ where
+ mod_fs = moduleNameFS (moduleName avail_mod)
+ avail_mod = nameModule (availName avail)
+ avail' = sortAvail avail
+
+ a1 `lt` a2 = availName a1 < availName a2
+
+sortAvail :: AvailInfo -> GenAvailInfo OccName
+-- Convert to OccName, and sort the sub-names into canonical order
+-- The canonical order has the "main name" at the beginning
+-- (if it's there at all)
+sortAvail (Avail n) = Avail (nameOccName n)
+sortAvail (AvailTC n ns)
+ | n `elem` ns = AvailTC occ (occ : mk_occs (filter (/= n) ns))
+ | otherwise = AvailTC occ ( mk_occs ns)
+ where
+ occ = nameOccName n
+ mk_occs ns = sortLt (<) (map nameOccName ns)
+\end{code}
+
+%************************************************************************
+%* *
+ Load the old interface file for this module (unless
+ we have it aleady), and check whether it is up to date
+
+%* *
+%************************************************************************
+
+\begin{code}
+checkOldIface :: HscEnv
+ -> Module
+ -> FilePath -- Where the interface file is
+ -> Bool -- Source unchanged
+ -> Maybe ModIface -- Old interface from compilation manager, if any
+ -> IO (RecompileRequired, Maybe ModIface)
+
+checkOldIface hsc_env mod iface_path source_unchanged maybe_iface
+ = do { showPass (hsc_dflags hsc_env)
+ ("Checking old interface for " ++ moduleUserString mod) ;
+
+ ; initIfaceIO hsc_env $
+ check_old_iface mod iface_path source_unchanged maybe_iface
+ }
+
+check_old_iface this_mod iface_path source_unchanged maybe_iface
+ = -- CHECK WHETHER THE SOURCE HAS CHANGED
+ ifM (not source_unchanged)
+ (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
+ `thenM_`
+
+ -- If the source has changed and we're in interactive mode, avoid reading
+ -- an interface; just return the one we might have been supplied with.
+ getGhciMode `thenM` \ ghci_mode ->
+ if (ghci_mode == Interactive) && not source_unchanged then
+ returnM (outOfDate, maybe_iface)
+ else
+
+ case maybe_iface of {
+ Just old_iface -> -- Use the one we already have
+ checkVersions source_unchanged old_iface `thenM` \ recomp ->
+ returnM (recomp, Just old_iface)
+
+ ; Nothing ->
+
+ -- Try and read the old interface for the current module
+ -- from the .hi file left from the last time we compiled it
+ readIface (moduleName this_mod) iface_path False `thenM` \ read_result ->
+ case read_result of {
+ Left err -> -- Old interface file not found, or garbled; give up
+ traceHiDiffs (text "FYI: cannot read old interface file:"
+ $$ nest 4 err) `thenM_`
+ returnM (outOfDate, Nothing)
+
+ ; Right iface ->
+
+ -- We have got the old iface; check its versions
+ checkVersions source_unchanged iface `thenM` \ recomp ->
+ returnM (recomp, Just iface)
+ }}
+\end{code}
+
+@recompileRequired@ is called from the HscMain. It checks whether
+a recompilation is required. It needs access to the persistent state,
+finder, etc, because it may have to load lots of interface files to
+check their versions.
+
+\begin{code}
+type RecompileRequired = Bool
+upToDate = False -- Recompile not required
+outOfDate = True -- Recompile required
+
+checkVersions :: Bool -- True <=> source unchanged
+ -> ModIface -- Old interface
+ -> IfG RecompileRequired
+checkVersions source_unchanged iface
+ | not source_unchanged
+ = returnM outOfDate
+ | otherwise
+ = traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon) `thenM_`
+
+ -- Source code unchanged and no errors yet... carry on
+ -- First put the dependent-module info in the envt, just temporarily,
+ -- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
+ -- It's just temporary because either the usage check will succeed
+ -- (in which case we are done with this module) or it'll fail (in which
+ -- case we'll compile the module from scratch anyhow).
+ updGblEnv (\ gbl -> gbl { if_is_boot = mod_deps }) (
+ checkList [checkModUsage u | u <- mi_usages iface]
+ )
+ where
+ -- This is a bit of a hack really
+ mod_deps :: ModuleEnv (ModuleName, IsBootInterface)
+ mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+checkModUsage :: Usage -> IfG RecompileRequired
+-- Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+
+checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
+ usg_rules = old_rule_vers,
+ usg_exports = maybe_old_export_vers,
+ usg_entities = old_decl_vers })
+ = -- Load the imported interface is possible
+ let
+ doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
+ in
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
+
+ loadInterface doc_str mod_name ImportBySystem `thenM` \ mb_iface ->
+ -- Load the interface, but don't complain on failure;
+ -- Instead, get an Either back which we can test
+
+ case mb_iface of {
+ Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ ppr mod_name]));
+ -- Couldn't find or parse a module mentioned in the
+ -- old interface file. Don't complain -- it might just be that
+ -- the current module doesn't need that import and it's been deleted
+
+ Right iface ->
+ let
+ new_mod_vers = mi_mod_vers iface
+ new_decl_vers = mi_ver_fn iface
+ new_export_vers = mi_exp_vers iface
+ new_rule_vers = mi_rule_vers iface
+ in
+ -- CHECK MODULE
+ checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
+ if not recompile then
+ returnM upToDate
+ else
+
+ -- CHECK EXPORT LIST
+ if checkExportList maybe_old_export_vers new_export_vers then
+ out_of_date_vers (ptext SLIT(" Export list changed"))
+ (fromJust maybe_old_export_vers)
+ new_export_vers
+ else
+
+ -- CHECK RULES
+ if old_rule_vers /= new_rule_vers then
+ out_of_date_vers (ptext SLIT(" Rules changed"))
+ old_rule_vers new_rule_vers
+ else
+
+ -- CHECK ITEMS ONE BY ONE
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
+ if recompile then
+ returnM outOfDate -- This one failed, so just bail out now
+ else
+ up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
+ }
+
+------------------------
+checkModuleVersion old_mod_vers new_mod_vers
+ | new_mod_vers == old_mod_vers
+ = up_to_date (ptext SLIT("Module version unchanged"))
+
+ | otherwise
+ = out_of_date_vers (ptext SLIT(" Module version has changed"))
+ old_mod_vers new_mod_vers
+
+------------------------
+checkExportList Nothing new_vers = upToDate
+checkExportList (Just v) new_vers = v /= new_vers
+
+------------------------
+checkEntityUsage new_vers (name,old_vers)
+ = case new_vers name of
+
+ Nothing -> -- We used it before, but it ain't there now
+ out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
+
+ Just new_vers -- It's there, but is it up to date?
+ | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
+ returnM upToDate
+ | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
+ old_vers new_vers
+
+up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
+out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+out_of_date_vers msg old_vers new_vers
+ = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
+
+----------------------
+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
+-- This helper is used in two places
+checkList [] = returnM upToDate
+checkList (check:checks) = check `thenM` \ recompile ->
+ if recompile then
+ returnM outOfDate
+ else
+ checkList checks
+\end{code}
+
+%************************************************************************
+%* *
+ Printing interfaces
+%* *
+%************************************************************************
+
+\begin{code}
+showIface :: FilePath -> IO ()
+-- Raad binary interface, and print it out
+showIface filename = do
+ -- skip the version check; we don't want to worry about profiled vs.
+ -- non-profiled interfaces, for example.
+ writeIORef v_IgnoreHiVersion True
+ iface <- Binary.getBinFileWithDict filename
+ printDump (pprModIface iface)
+ where
+\end{code}
+
+
+\begin{code}
+pprModIface :: ModIface -> SDoc
+-- Show a ModIface
+pprModIface iface
+ = vcat [ ptext SLIT("interface")
+ <+> doubleQuotes (ftext (mi_package iface))
+ <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface)
+ <+> pp_sub_vers
+ <+> (if mi_orphan iface then char '!' else empty)
+ <+> int opt_HiVersion
+ <+> ptext SLIT("where")
+ , vcat (map pprExport (mi_exports iface))
+ , pprDeps (mi_deps iface)
+ , vcat (map pprUsage (mi_usages iface))
+ , pprFixities (mi_fixities iface)
+ , vcat (map pprIfaceDecl (mi_decls iface))
+ , vcat (map ppr (mi_insts iface))
+ , vcat (map ppr (mi_rules iface))
+ , pprDeprecs (mi_deprecs iface)
+ ]
+ where
+ exp_vers = mi_exp_vers iface
+ rule_vers = mi_rule_vers iface
+
+ pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
+ | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
+\end{code}
+
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+
+\begin{code}
+pprExport :: IfaceExport -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ]
+ where
+ pp_avail :: GenAvailInfo OccName -> SDoc
+ pp_avail (Avail occ) = ppr occ
+ pp_avail (AvailTC _ []) = empty
+ pp_avail (AvailTC n (n':ns))
+ | n==n' = ppr n <> pp_export ns
+ | otherwise = ppr n <> char '|' <> pp_export (n':ns)
+
+ pp_export [] = empty
+ pp_export names = braces (hsep (map ppr names))
+
+pprUsage :: Usage -> SDoc
+pprUsage usage
+ = hsep [ptext SLIT("import"), ppr (usg_name usage),
+ int (usg_mod usage),
+ pp_export_version (usg_exports usage),
+ int (usg_rules usage),
+ pp_versions (usg_entities usage) ]
+ where
+ pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ]
+ pp_export_version Nothing = empty
+ pp_export_version (Just v) = int v
+
+pprDeps :: Dependencies -> SDoc
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs})
+ = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods),
+ ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs),
+ ptext SLIT("orphans:") <+> fsep (map ppr orphs)
+ ]
+ where
+ ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+ ppr_boot True = text "[boot]"
+ ppr_boot False = empty
+
+pprIfaceDecl :: (Version, IfaceDecl) -> SDoc
+pprIfaceDecl (ver, decl)
+ = ppr_vers ver <+> ppr decl
+ where
+ -- Print the version for the decl
+ ppr_vers v | v == initialVersion = empty
+ | otherwise = int v
+
+pprFixities :: [(OccName, Fixity)] -> SDoc
+pprFixities [] = empty
+pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes
+ where
+ pprFix (occ,fix) = ppr fix <+> ppr occ
+
+pprDeprecs NoDeprecs = empty
+pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt)
+pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs)
+ where
+ pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt)
+\end{code}
--- /dev/null
+__interface TcIface 1 0 where
+
+1 tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing ;
+
--- /dev/null
+module TcIface where
+
+tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[TcIfaceSig]{Type checking of type signatures in interface files}
+
+\begin{code}
+module TcIface (
+ tcImportDecl, typecheckIface,
+ tcIfaceKind, loadImportedInsts,
+ tcExtCoreBindings
+ ) where
+#include "HsVersions.h"
+
+import IfaceSyn
+import LoadIface ( loadHomeInterface, predInstGates )
+import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig,
+ extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
+ tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
+ tcIfaceDataCon, tcIfaceLclId,
+ newIfaceName, newIfaceNames )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
+import TcRnMonad
+import Type ( Kind, openTypeKind, liftedTypeKind,
+ unliftedTypeKind, mkArrowKind, splitTyConApp,
+ mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+import TypeRep ( Type(..), PredType(..) )
+import TyCon ( TyCon, tyConName )
+import HscTypes ( ExternalPackageState(..), PackageInstEnv,
+ TyThing(..), implicitTyThings,
+ ModIface(..), ModDetails(..), InstPool,
+ TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
+ DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
+import InstEnv ( extendInstEnv )
+import CoreSyn
+import Rules ( extendRuleBaseList )
+import CoreUtils ( exprType )
+import CoreUnfold
+import CoreLint ( lintUnfolding )
+import WorkWrap ( mkWrapper )
+import InstEnv ( DFunId )
+import Id ( Id, mkVanillaGlobal, mkLocalId )
+import MkId ( mkFCallId )
+import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
+ setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
+ setArityInfo, setInlinePragInfo, setCafInfo,
+ vanillaIdInfo, newStrictnessInfo )
+import Class ( Class )
+import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
+import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
+import TysWiredIn ( tupleCon )
+import Var ( TyVar, mkTyVar, tyVarKind )
+import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
+ isWiredInName, wiredInNameTyThing_maybe, nameParent )
+import NameEnv
+import OccName ( OccName )
+import Module ( Module, ModuleName, moduleName )
+import UniqSupply ( initUs_ )
+import Outputable
+import SrcLoc ( noSrcLoc )
+import Util ( zipWithEqual, dropList, equalLength )
+import Maybes ( expectJust )
+import CmdLineOpts ( DynFlag(..) )
+\end{code}
+
+This module takes
+
+ IfaceDecl -> TyThing
+ IfaceType -> Type
+ etc
+
+An IfaceDecl is populated with RdrNames, and these are not renamed to
+Names before typechecking, because there should be no scope errors etc.
+
+ -- For (b) consider: f = $(...h....)
+ -- where h is imported, and calls f via an hi-boot file.
+ -- This is bad! But it is not seen as a staging error, because h
+ -- is indeed imported. We don't want the type-checker to black-hole
+ -- when simplifying and compiling the splice!
+ --
+ -- Simple solution: discard any unfolding that mentions a variable
+ -- bound in this module (and hence not yet processed).
+ -- The discarding happens when forkM finds a type error.
+
+%************************************************************************
+%* *
+%* tcImportDecl is the key function for "faulting in" *
+%* imported things
+%* *
+%************************************************************************
+
+The main idea is this. We are chugging along type-checking source code, and
+find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find
+it in the EPS type envt. So it
+ 1 loads GHC.Base.hi
+ 2 gets the decl for GHC.Base.map
+ 3 typechecks it via tcIfaceDecl
+ 4 and adds it to the type env in the EPS
+
+Note that DURING STEP 4, we may find that map's type mentions a type
+constructor that also
+
+Notice that for imported things we read the current version from the EPS
+mutable variable. This is important in situations like
+ ...$(e1)...$(e2)...
+where the code that e1 expands to might import some defns that
+also turn out to be needed by the code that e2 expands to.
+
+\begin{code}
+tcImportDecl :: Name -> IfG TyThing
+-- Get the TyThing for this Name from an interface file
+tcImportDecl name
+ = do {
+ -- Make sure the interface is loaded
+ ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
+ ; traceIf nd_doc
+ ; loadHomeInterface nd_doc name
+
+ -- Get the real name of the thing, with a correct nameParent field.
+ -- Before the interface is loaded, we may have a non-commital 'Nothing' in
+ -- the namePareent field (made up by IfaceEnv.lookupOrig), but
+ -- loading the interface updates the name cache.
+ -- We need the right nameParent field in getThing
+ ; real_name <- lookupOrig (nameModuleName name) (nameOccName name)
+
+ -- Get the decl out of the EPS
+ ; main_thing <- ASSERT( real_name == name ) -- Unique should not change!
+ getThing real_name
+
+ -- Record the import in the type env,
+ -- slurp any rules it allows in
+ ; recordImportOf main_thing
+
+ ; let { extra | getName main_thing == real_name = empty
+ | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) }
+ ; traceIf (ptext SLIT("...imported decl for") <+> ppr main_thing <+> extra)
+
+
+ -- Look up the wanted Name in the type envt; it might be
+ -- one of the subordinate members of the input thing
+ ; if real_name == getName main_thing
+ then return main_thing
+ else do
+ { eps <- getEps
+ ; return (expectJust "tcImportDecl" $
+ lookupTypeEnv (eps_PTE eps) real_name) }}
+
+recordImportOf :: TyThing -> IfG ()
+-- Update the EPS to record the import of the Thing
+-- (a) augment the type environment; this is done even for wired-in
+-- things, so that we don't go through this rigmarole a second time
+-- (b) slurp in any rules to maintain the invariant that any rule
+-- whose gates are all in the type envt, is in eps_rule_base
+
+recordImportOf thing
+ = do { (new_things, iface_rules) <- updateEps (\ eps ->
+ let { new_things = thing : implicitTyThings thing
+ ; new_type_env = extendTypeEnvList (eps_PTE eps) new_things
+ -- NB: opportunity for a very subtle loop here!
+ -- If working out what the implicitTyThings are involves poking
+ -- any of the fork'd thunks in 'thing', then here's what happens
+ -- * recordImportOf succeed, extending type-env with a thunk
+ -- * the next guy to pull on type-env forces the thunk
+ -- * which pokes the suspended forks
+ -- * which, to execute, need to consult type-env (to check
+ -- entirely unrelated types, perhaps)
+
+ ; (new_rules, iface_rules) = selectRules (eps_rules eps)
+ (map getName new_things)
+ new_type_env }
+ in (eps { eps_PTE = new_type_env, eps_rules = new_rules },
+ (new_things, iface_rules))
+ )
+
+ -- Now type-check those rules (which may side-effect the EPS again)
+ ; traceIf (text "tcImport: extend type env" <+> ppr new_things)
+ ; core_rules <- mapM tc_rule iface_rules
+ ; updateEps_ (\ eps ->
+ eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
+ ) }
+
+tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
+
+getThing :: Name -> IfG TyThing
+-- Find and typecheck the thing; the Name might be a "subordinate name"
+-- of the "main thing" (e.g. the constructor of a data type declaration)
+-- The Thing we return is the parent "main thing"
+
+getThing name
+ | Just thing <- wiredInNameTyThing_maybe name
+ = return thing
+
+ | otherwise = do -- The normal case, not wired in
+ { -- Get the decl from the pool
+ decl <- updateEps (\ eps ->
+ let
+ (decls', decl) = selectDecl (eps_decls eps) name
+ in
+ (eps { eps_decls = decls' }, decl))
+
+ -- Typecheck it
+ -- Side-effects EPS by faulting in any needed decls
+ -- (via nested calls to tcImportDecl)
+ ; initIfaceLcl (nameModuleName name) (tcIfaceDecl decl) }
+
+
+selectDecl :: DeclPool -> Name -> (DeclPool, IfaceDecl)
+-- Use nameParent to get the parent name of the thing
+selectDecl (Pool decls_map n_in n_out) name
+ = (Pool decls' n_in (n_out+1), decl)
+ where
+ main_name = nameParent name
+ decl = case lookupNameEnv decls_map main_name of
+ Nothing -> pprPanic "selectDecl" (ppr main_name <+> ppr name) ;
+ Just decl -> decl
+
+ decls' = delFromNameEnv decls_map main_name
+\end{code}
+
+%************************************************************************
+%* *
+ Other interfaces
+%* *
+%************************************************************************
+
+\begin{code}
+typecheckIface :: ModIface -> IfG ModDetails
+-- Used when we decide not to recompile, but intead to use the
+-- interface to construct the type environment for the module
+typecheckIface iface
+ = initIfaceLcl (moduleName (mi_module iface)) $
+ do { ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface)
+ ; rules <- mapM tcIfaceRule (mi_rules iface)
+ ; dfuns <- mapM tcIfaceInst (mi_insts iface)
+ ; return (ModDetails { md_types = mkTypeEnv ty_things,
+ md_insts = dfuns,
+ md_rules = rules }) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type and class declarations
+%* *
+%************************************************************************
+
+When typechecking a data type decl, we *lazily* (via forkM) typecheck
+the constructor argument types. This is in the hope that we may never
+poke on those argument types, and hence may never need to load the
+interface files for types mentioned in the arg types.
+
+E.g.
+ data Foo.S = MkS Baz.T
+Mabye we can get away without even loading the interface for Baz!
+
+This is not just a performance thing. Suppose we have
+ data Foo.S = MkS Baz.T
+ data Baz.T = MkT Foo.S
+(in different interface files, of course).
+Now, first we load and typecheck Foo.S, and add it to the type envt.
+If we do explore MkS's argument, we'll load and typecheck Baz.T.
+If we explore MkT's argument we'll find Foo.S already in the envt.
+
+If we typechecked constructor args eagerly, when loading Foo.S we'd try to
+typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
+which isn't done yet.
+
+All very cunning. However, there is a rather subtle gotcha which bit
+me when developing this stuff. When we typecheck the decl for S, we
+extend the type envt with S, MkS, and all its implicit Ids. Suppose
+(a bug, but it happened) that the list of implicit Ids depended in
+turn on the constructor arg types. Then the following sequence of
+events takes place:
+ * we build a thunk <t> for the constructor arg tys
+ * we build a thunk for the extended type environment (depends on <t>)
+ * we write the extended type envt into the global EPS mutvar
+
+Now we look something up in the type envt
+ * that pulls on <t>
+ * which reads the global type envt out of the global EPS mutvar
+ * but that depends in turn on <t>
+
+It's subtle, because, it'd work fine if we typechecked the constructor args
+eagerly -- they don't need the extended type envt. They just get the extended
+type envt by accident, because they look at it later.
+
+What this means is that the implicitTyThings MUST NOT DEPEND on any of
+the forkM stuff.
+
+
+\begin{code}
+tcIfaceDecl :: IfaceDecl -> IfL TyThing
+
+tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
+ = do { name <- lookupIfaceTop occ_name
+ ; ty <- tcIfaceType iface_type
+ ; info <- tcIdInfo name ty info
+ ; return (AnId (mkVanillaGlobal name ty info)) }
+
+tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name,
+ ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
+ ifCons = rdr_cons,
+ ifVrcs = arg_vrcs, ifRec = is_rec,
+ ifGeneric = want_generic })
+ = do { tc_name <- lookupIfaceTop occ_name
+ ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+
+ { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt)
+
+ ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $
+ tcIfaceCtxt rdr_ctxt
+ -- The reason for laziness here is to postpone
+ -- looking at the context, because the class may not
+ -- be in the type envt yet. E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- We suck in the decl for Real, and type check it, which sucks
+ -- in the data type Ratio; but we must postpone typechecking the
+ -- context
+
+ ; tycon <- fixM ( \ tycon -> do
+ { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
+ ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons
+ arg_vrcs is_rec want_generic
+ ; return tycon
+ })
+ ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+ ; return (ATyCon tycon)
+ } }
+
+tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
+ = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+ { tc_name <- lookupIfaceTop occ_name
+ ; rhs_ty <- tcIfaceType rdr_rhs_ty
+ ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
+ }
+
+tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
+ ifFDs = rdr_fds, ifSigs = rdr_sigs,
+ ifVrcs = tc_vrcs, ifRec = tc_isrec })
+ = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+ { cls_name <- lookupIfaceTop occ_name
+ ; ctxt <- tcIfaceCtxt rdr_ctxt
+ ; sigs <- mappM tc_sig rdr_sigs
+ ; fds <- mappM tc_fd rdr_fds
+ ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
+ ; return (AClass cls) }
+ where
+ tc_sig (IfaceClassOp occ dm rdr_ty)
+ = do { op_name <- lookupIfaceTop occ
+ ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
+ -- Must be done lazily for just the same reason as the
+ -- context of a data decl: the type sig might mention the
+ -- class being defined
+ ; return (op_name, dm, op_ty) }
+
+ mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
+
+ tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
+ ; tvs2' <- mappM tcIfaceTyVar tvs2
+ ; return (tvs1', tvs2') }
+
+tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+ = do { name <- lookupIfaceTop rdr_name
+ ; return (ATyCon (mkForeignTyCon name ext_name
+ liftedTypeKind 0 [])) }
+
+tcIfaceDataCons tycon tyvars ctxt Unknown
+ = returnM Unknown
+
+tcIfaceDataCons tycon tyvars ctxt (DataCons cs)
+ = mappM tc_con_decl cs `thenM` \ data_cons ->
+ returnM (DataCons data_cons)
+ where
+ tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
+ = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
+ { name <- lookupIfaceTop occ
+ ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here
+
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ;
+
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
+
+ ; buildDataCon name stricts lbl_names
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
+ }
+ mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args]
+\end{code}
+
+
+%************************************************************************
+%* *
+ Instances
+%* *
+%************************************************************************
+
+The gating story for instance declarations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking for a dict (C t1..tn), we slurp in instance decls for
+C that
+ mention at least one of the type constructors
+ at the roots of t1..tn
+
+Why "at least one" rather than "all"? Because functional dependencies
+complicate the picture. Consider
+ class C a b | a->b where ...
+ instance C Foo Baz where ...
+Here, the gates are really only C and Foo, *not* Baz.
+That is, if C and Foo are visible, even if Baz isn't, we must
+slurp the decl, even if Baz is thus far completely unknown to the
+system.
+
+Why "roots of the types"? Reason is overlap. For example, suppose there
+are interfaces in the pool for
+ (a) C Int b
+ (b) C a [b]
+ (c) C a [T]
+Then, if we are trying to resolve (C Int x), we need (a)
+if we are trying to resolve (C x [y]), we need *both* (b) and (c),
+even though T is not involved yet, so that we spot the overlap.
+
+\begin{code}
+loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
+loadImportedInsts cls tys
+ = do { -- Get interfaces for wired-in things, such as Integer
+ -- Any non-wired-in tycons will already be loaded, else
+ -- we couldn't have them in the Type
+ ; this_mod <- getModule
+ ; let { (cls_gate, tc_gates) = predInstGates cls tys
+ ; imp_wi n = isWiredInName n && this_mod /= nameModule n
+ ; wired_tcs = filter imp_wi tc_gates }
+ -- Wired-in tycons not from this module. The "this-module"
+ -- test bites only when compiling Base etc, because loadHomeInterface
+ -- barfs if it's asked to load a non-existent interface
+ ; if null wired_tcs then returnM ()
+ else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
+
+ ; eps_var <- getEpsVar
+ ; eps <- readMutVar eps_var
+
+ -- Suck in the instances
+ ; let { (inst_pool', iface_insts)
+ = selectInsts (eps_insts eps) cls_gate tc_gates }
+
+ ; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys,
+ text "new pool" <+> ppr inst_pool',
+ text "new insts" <+> ppr iface_insts])
+
+ -- Empty => finish up rapidly, without writing to eps
+ ; if null iface_insts then
+ return (eps_inst_env eps)
+ else do
+ { writeMutVar eps_var (eps {eps_insts = inst_pool'})
+
+ -- Typecheck the new instances
+ ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
+
+ -- And put them in the package instance environment
+ ; updateEps ( \ eps ->
+ let
+ inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
+ in
+ (eps { eps_inst_env = inst_env' }, inst_env')
+ )}}
+ where
+ wired_doc = ptext SLIT("Need home inteface for wired-in thing")
+
+tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst)
+
+tcIfaceInst :: IfaceInst -> IfL DFunId
+tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
+ = tcIfaceExtId (LocalTop dfun_occ)
+
+selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)])
+selectInsts pool@(Pool insts n_in n_out) cls tycons
+ = (Pool insts' n_in (n_out + length iface_insts), iface_insts)
+ where
+ (insts', iface_insts)
+ = case lookupNameEnv insts cls of {
+ Nothing -> (insts, []) ;
+ Just gated_insts ->
+
+ case foldl choose ([],[]) gated_insts of {
+ (_, []) -> (insts, []) ; -- None picked
+ (gated_insts', iface_insts') ->
+
+ (extendNameEnv insts cls gated_insts', iface_insts') }}
+
+ -- Reverses the gated decls, but that doesn't matter
+ choose (gis, decls) (gates, decl)
+ | any (`elem` tycons) gates = (gis, decl:decls)
+ | otherwise = ((gates,decl) : gis, decls)
+\end{code}
+
+%************************************************************************
+%* *
+ Rules
+%* *
+%************************************************************************
+
+We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
+are in the type environment. However, remember that typechecking a Rule may
+(as a side effect) augment the type envt, and so we may need to iterate the process.
+
+\begin{code}
+selectRules :: RulePool
+ -> [Name] -- Names of things being added
+ -> TypeEnv -- New type env, including things being added
+ -> (RulePool, [(ModuleName, IfaceRule)])
+selectRules (Pool rules n_in n_out) new_names type_env
+ = (Pool rules' n_in (n_out + length iface_rules), iface_rules)
+ where
+ (rules', iface_rules) = foldl select_one (rules, []) new_names
+
+ select_one :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Name
+ -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
+ select_one (rules, decls) name
+ = case lookupNameEnv rules name of
+ Nothing -> (rules, decls)
+ Just gated_rules -> foldl filter_rule (delFromNameEnv rules name, decls) gated_rules
+
+ filter_rule :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Gated IfaceRule
+ -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
+ filter_rule (rules, decls) (rule_fvs, rule)
+ = case [fv | fv <- rule_fvs, not (fv `elemNameEnv` type_env)] of
+ [] -> -- No remaining FVs, so slurp it
+ (rules, rule:decls)
+ fvs -> -- There leftover fvs, so toss it back in the pool
+ (addRuleToPool rules rule fvs, decls)
+
+tcIfaceRule :: IfaceRule -> IfL IdCoreRule
+tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
+ ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
+ = bindIfaceBndrs bndrs $ \ bndrs' ->
+ do { fn <- tcIfaceExtId fn_rdr
+ ; args' <- mappM tcIfaceExpr args
+ ; rhs' <- tcIfaceExpr rhs
+ ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) }
+
+tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
+ = do { fn <- tcIfaceExtId fn_rdr
+ ; returnM (fn, core_rule) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Types
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceKind :: IfaceKind -> Kind
+tcIfaceKind IfaceOpenTypeKind = openTypeKind
+tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind
+tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
+tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
+
+-----------------------------------------
+tcIfaceType :: IfaceType -> IfL Type
+tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
+tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
+tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
+tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
+tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
+tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+
+tcIfaceTypes tys = mapM tcIfaceType tys
+
+-----------------------------------------
+tcIfacePredType :: IfacePredType -> IfL PredType
+tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
+tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
+
+-----------------------------------------
+tcIfaceCtxt :: IfaceContext -> IfL ThetaType
+tcIfaceCtxt sts = mappM tcIfacePredType sts
+\end{code}
+
+
+%************************************************************************
+%* *
+ Core
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceType ty)
+ = tcIfaceType ty `thenM` \ ty' ->
+ returnM (Type ty')
+
+tcIfaceExpr (IfaceLcl name)
+ = tcIfaceLclId name `thenM` \ id ->
+ returnM (Var id)
+
+tcIfaceExpr (IfaceExt gbl)
+ = tcIfaceExtId gbl `thenM` \ id ->
+ returnM (Var id)
+
+tcIfaceExpr (IfaceLit lit)
+ = returnM (Lit lit)
+
+tcIfaceExpr (IfaceFCall cc ty)
+ = tcIfaceType ty `thenM` \ ty' ->
+ newUnique `thenM` \ u ->
+ returnM (Var (mkFCallId u cc ty'))
+
+tcIfaceExpr (IfaceTuple boxity args)
+ = mappM tcIfaceExpr args `thenM` \ args' ->
+ let
+ -- Put the missing type arguments back in
+ con_args = map (Type . exprType) args' ++ args'
+ in
+ returnM (mkApps (Var con_id) con_args)
+ where
+ arity = length args
+ con_id = dataConWorkId (tupleCon boxity arity)
+
+
+tcIfaceExpr (IfaceLam bndr body)
+ = bindIfaceBndr bndr $ \ bndr' ->
+ tcIfaceExpr body `thenM` \ body' ->
+ returnM (Lam bndr' body')
+
+tcIfaceExpr (IfaceApp fun arg)
+ = tcIfaceExpr fun `thenM` \ fun' ->
+ tcIfaceExpr arg `thenM` \ arg' ->
+ returnM (App fun' arg')
+
+tcIfaceExpr (IfaceCase scrut case_bndr alts)
+ = tcIfaceExpr scrut `thenM` \ scrut' ->
+ newIfaceName case_bndr `thenM` \ case_bndr_name ->
+ let
+ scrut_ty = exprType scrut'
+ case_bndr' = mkLocalId case_bndr_name scrut_ty
+ tc_app = splitTyConApp scrut_ty
+ -- NB: Won't always succeed (polymoprhic case)
+ -- but won't be demanded in those cases
+ -- NB: not tcSplitTyConApp; we are looking at Core here
+ -- look through non-rec newtypes to find the tycon that
+ -- corresponds to the datacon in this case alternative
+ in
+ extendIfaceIdEnv [case_bndr'] $
+ mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
+ returnM (Case scrut' case_bndr' alts')
+
+tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+ = tcIfaceExpr rhs `thenM` \ rhs' ->
+ bindIfaceId bndr $ \ bndr' ->
+ tcIfaceExpr body `thenM` \ body' ->
+ returnM (Let (NonRec bndr' rhs') body')
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+ = bindIfaceIds bndrs $ \ bndrs' ->
+ mappM tcIfaceExpr rhss `thenM` \ rhss' ->
+ tcIfaceExpr body `thenM` \ body' ->
+ returnM (Let (Rec (bndrs' `zip` rhss')) body')
+ where
+ (bndrs, rhss) = unzip pairs
+
+tcIfaceExpr (IfaceNote note expr)
+ = tcIfaceExpr expr `thenM` \ expr' ->
+ case note of
+ IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
+ returnM (Note (Coerce to_ty'
+ (exprType expr')) expr')
+ IfaceInlineCall -> returnM (Note InlineCall expr')
+ IfaceInlineMe -> returnM (Note InlineMe expr')
+ IfaceSCC cc -> returnM (Note (SCC cc) expr')
+ IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
+
+-------------------------
+tcIfaceAlt _ (IfaceDefault, names, rhs)
+ = ASSERT( null names )
+ tcIfaceExpr rhs `thenM` \ rhs' ->
+ returnM (DEFAULT, [], rhs')
+
+tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
+ = ASSERT( null names )
+ tcIfaceExpr rhs `thenM` \ rhs' ->
+ returnM (LitAlt lit, [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out. True enough, but its not that easy!
+tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
+ = let
+ tycon_mod = nameModuleName (tyConName tycon)
+ in
+ tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con ->
+ newIfaceNames arg_occs `thenM` \ arg_names ->
+ let
+ ex_tyvars = dataConExistentialTyVars con
+ main_tyvars = tyConTyVars tycon
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = dropList ex_tyvars arg_names
+ arg_ids
+#ifdef DEBUG
+ | not (equalLength id_names arg_tys)
+ = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$
+ (ppr main_tyvars <+> ppr ex_tyvars) $$
+ ppr arg_tys)
+ | otherwise
+#endif
+ = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys
+ in
+ ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars,
+ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars )
+ extendIfaceTyVarEnv ex_tyvars' $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs `thenM` \ rhs' ->
+ returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+
+tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
+ = newIfaceNames arg_occs `thenM` \ arg_names ->
+ let
+ [con] = tyConDataCons tycon
+ arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys
+ in
+ ASSERT( isTupleTyCon tycon )
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs `thenM` \ rhs' ->
+ returnM (DataAlt con, arg_ids, rhs')
+\end{code}
+
+
+\begin{code}
+tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core
+tcExtCoreBindings mod [] = return []
+tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs)
+
+do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
+do_one mod (IfaceNonRec bndr rhs) thing_inside
+ = do { rhs' <- tcIfaceExpr rhs
+ ; bndr' <- newExtCoreBndr mod bndr
+ ; extendIfaceIdEnv [bndr'] $ do
+ { core_binds <- thing_inside
+ ; return (NonRec bndr' rhs' : core_binds) }}
+
+do_one mod (IfaceRec pairs) thing_inside
+ = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs
+ ; extendIfaceIdEnv bndrs' $ do
+ { rhss' <- mappM tcIfaceExpr rhss
+ ; core_binds <- thing_inside
+ ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
+ where
+ (bndrs,rhss) = unzip pairs
+\end{code}
+
+
+%************************************************************************
+%* *
+ IdInfo
+%* *
+%************************************************************************
+
+\begin{code}
+tcIdInfo name ty NoInfo = return vanillaIdInfo
+tcIdInfo name ty DiscardedInfo = return vanillaIdInfo
+tcIdInfo name ty (HasInfo iface_info)
+ = foldlM tcPrag init_info iface_info
+ where
+ -- Set the CgInfo to something sensible but uninformative before
+ -- we start; default assumption is that it has CAFs
+ init_info = vanillaIdInfo
+
+ tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
+
+ -- The next two are lazy, so they don't transitively suck stuff in
+ tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
+ tcPrag info (HsUnfold inline_prag expr)
+ = tcPragExpr name expr `thenM` \ maybe_expr' ->
+ let
+ -- maybe_expr' doesn't get looked at if the unfolding
+ -- is never inspected; so the typecheck doesn't even happen
+ unfold_info = case maybe_expr' of
+ Nothing -> noUnfolding
+ Just expr' -> mkTopUnfolding expr'
+ in
+ returnM (info `setUnfoldingInfoLazily` unfold_info
+ `setInlinePragInfo` inline_prag)
+\end{code}
+
+\begin{code}
+tcWorkerInfo ty info wkr_name arity
+ = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId (LocalTop wkr_name))
+
+ -- We return without testing maybe_wkr_id, but as soon as info is
+ -- looked at we will test it. That's ok, because its outside the
+ -- knot; and there seems no big reason to further defer the
+ -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
+ -- over the unfolding until it's actually used does seem worth while.)
+ ; us <- newUniqueSupply
+
+ ; returnM (case mb_wkr_id of
+ Nothing -> info
+ Just wkr_id -> add_wkr_info us wkr_id info) }
+ where
+ doc = text "Worker for" <+> ppr wkr_name
+ add_wkr_info us wkr_id info
+ = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
+ `setWorkerInfo` HasWorker wkr_id arity
+
+ mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+
+ -- We are relying here on strictness info always appearing
+ -- before worker info, fingers crossed ....
+ strict_sig = case newStrictnessInfo info of
+ Just sig -> sig
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name)
+\end{code}
+
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+
+\begin{code}
+tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr name expr
+ = forkM_maybe doc $
+ tcIfaceExpr expr `thenM` \ core_expr' ->
+
+ -- Check for type consistency in the unfolding
+ ifOptM Opt_DoCoreLinting (
+ case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of
+ Nothing -> returnM ()
+ Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
+ ) `thenM_`
+
+ returnM core_expr'
+ where
+ doc = text "Unfolding of" <+> ppr name
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Bindings
+%* *
+%************************************************************************
+
+\begin{code}
+bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
+bindIfaceBndr (IfaceIdBndr bndr) thing_inside
+ = bindIfaceId bndr thing_inside
+bindIfaceBndr (IfaceTvBndr bndr) thing_inside
+ = bindIfaceTyVar bndr thing_inside
+
+bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
+bindIfaceBndrs [] thing_inside = thing_inside []
+bindIfaceBndrs (b:bs) thing_inside
+ = bindIfaceBndr b $ \ b' ->
+ bindIfaceBndrs bs $ \ bs' ->
+ thing_inside (b':bs')
+
+-----------------------
+bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
+bindIfaceId (occ, ty) thing_inside
+ = do { name <- newIfaceName occ
+ ; ty' <- tcIfaceType ty
+ ; let { id = mkLocalId name ty' }
+ ; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds bndrs thing_inside
+ = do { names <- newIfaceNames occs
+ ; tys' <- mappM tcIfaceType tys
+ ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
+ ; extendIfaceIdEnv ids (thing_inside ids) }
+ where
+ (occs,tys) = unzip bndrs
+
+
+-----------------------
+newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id
+newExtCoreBndr mod (occ, ty)
+ = do { name <- newGlobalBinder mod occ Nothing noSrcLoc
+ ; ty' <- tcIfaceType ty
+ ; return (mkLocalId name ty') }
+
+-----------------------
+bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
+bindIfaceTyVar (occ,kind) thing_inside
+ = do { name <- newIfaceName occ
+ ; let tyvar = mk_iface_tyvar name kind
+ ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
+
+bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTyVars bndrs thing_inside
+ = do { names <- newIfaceNames occs
+ ; let tyvars = zipWith mk_iface_tyvar names kinds
+ ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
+ where
+ (occs,kinds) = unzip bndrs
+
+mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+\end{code}
projects / ghc-hetmet.git / commitdiff