summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinIface.hs1056
-rw-r--r--compiler/iface/BuildTyCl.lhs256
-rw-r--r--compiler/iface/IfaceEnv.lhs359
-rw-r--r--compiler/iface/IfaceSyn.lhs998
-rw-r--r--compiler/iface/IfaceType.lhs390
-rw-r--r--compiler/iface/LoadIface.lhs582
-rw-r--r--compiler/iface/MkIface.lhs1066
-rw-r--r--compiler/iface/TcIface.hi-boot-55
-rw-r--r--compiler/iface/TcIface.hi-boot-67
-rw-r--r--compiler/iface/TcIface.lhs977
-rw-r--r--compiler/iface/TcIface.lhs-boot13
11 files changed, 5709 insertions, 0 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
new file mode 100644
index 0000000000..6d02fe00c7
--- /dev/null
+++ b/compiler/iface/BinIface.hs
@@ -0,0 +1,1056 @@
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Binary interface file support.
+
+module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
+
+#include "HsVersions.h"
+
+import HscTypes
+import BasicTypes
+import NewDemand
+import IfaceSyn
+import VarEnv
+import InstEnv ( OverlapFlag(..) )
+import Packages ( PackageIdH(..) )
+import Class ( DefMeth(..) )
+import CostCentre
+import StaticFlags ( opt_HiVersion, v_Build_tag )
+import Kind ( Kind(..) )
+import Panic
+import Binary
+import Util
+import Config ( cGhcUnregisterised )
+
+import DATA_IOREF
+import EXCEPTION ( throwDyn )
+import Monad ( when )
+import Outputable
+
+#include "HsVersions.h"
+
+-- ---------------------------------------------------------------------------
+writeBinIface :: FilePath -> ModIface -> IO ()
+writeBinIface hi_path mod_iface
+ = putBinFileWithDict hi_path mod_iface
+
+readBinIface :: FilePath -> IO ModIface
+readBinIface hi_path = getBinFileWithDict hi_path
+
+
+-- %*********************************************************
+-- %* *
+-- All the Binary instances
+-- %* *
+-- %*********************************************************
+
+-- BasicTypes
+{-! for IPName derive: Binary !-}
+{-! for Fixity derive: Binary !-}
+{-! for FixityDirection derive: Binary !-}
+{-! for Boxity derive: Binary !-}
+{-! for StrictnessMark derive: Binary !-}
+{-! for Activation derive: Binary !-}
+
+-- NewDemand
+{-! for Demand derive: Binary !-}
+{-! for Demands derive: Binary !-}
+{-! for DmdResult derive: Binary !-}
+{-! for StrictSig derive: Binary !-}
+
+-- Class
+{-! for DefMeth derive: Binary !-}
+
+-- HsTypes
+{-! for HsPred derive: Binary !-}
+{-! for HsType derive: Binary !-}
+{-! for TupCon derive: Binary !-}
+{-! for HsTyVarBndr derive: Binary !-}
+
+-- HsCore
+{-! for UfExpr derive: Binary !-}
+{-! for UfConAlt derive: Binary !-}
+{-! for UfBinding derive: Binary !-}
+{-! for UfBinder derive: Binary !-}
+{-! for HsIdInfo derive: Binary !-}
+{-! for UfNote derive: Binary !-}
+
+-- HsDecls
+{-! for ConDetails derive: Binary !-}
+{-! for BangType derive: Binary !-}
+
+-- CostCentre
+{-! for IsCafCC derive: Binary !-}
+{-! for IsDupdCC derive: Binary !-}
+{-! for CostCentre derive: Binary !-}
+
+
+
+-- ---------------------------------------------------------------------------
+-- Reading a binary interface into ParsedIface
+
+instance Binary ModIface where
+ put_ bh (ModIface {
+ mi_module = mod,
+ mi_boot = is_boot,
+ mi_mod_vers = mod_vers,
+ mi_package = _, -- we ignore the package on output
+ mi_orphan = orphan,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = exports,
+ mi_exp_vers = exp_vers,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+ mi_decls = decls,
+ mi_insts = insts,
+ mi_rules = rules,
+ mi_rule_vers = rule_vers }) = do
+ put_ bh (show opt_HiVersion)
+ way_descr <- getWayDescr
+ put bh way_descr
+ put_ bh mod
+ put_ bh is_boot
+ put_ bh mod_vers
+ put_ bh orphan
+ lazyPut bh deps
+ lazyPut bh usages
+ put_ bh exports
+ put_ bh exp_vers
+ put_ bh fixities
+ lazyPut bh deprecs
+ put_ bh decls
+ put_ bh insts
+ lazyPut bh rules
+ put_ bh rule_vers
+
+ get bh = do
+ check_ver <- get bh
+ let our_ver = show opt_HiVersion
+ when (check_ver /= our_ver) $
+ -- use userError because this will be caught by readIface
+ -- which will emit an error msg containing the iface module name.
+ throwDyn (ProgramError (
+ "mismatched interface file versions: expected "
+ ++ our_ver ++ ", found " ++ check_ver))
+
+ check_way <- get bh
+ ignore_way <- readIORef v_IgnoreHiWay
+ way_descr <- getWayDescr
+ when (not ignore_way && check_way /= way_descr) $
+ -- use userError because this will be caught by readIface
+ -- which will emit an error msg containing the iface module name.
+ throwDyn (ProgramError (
+ "mismatched interface file ways: expected "
+ ++ way_descr ++ ", found " ++ check_way))
+
+ mod_name <- get bh
+ is_boot <- get bh
+ mod_vers <- get bh
+ orphan <- get bh
+ deps <- lazyGet bh
+ usages <- {-# SCC "bin_usages" #-} lazyGet bh
+ exports <- {-# SCC "bin_exports" #-} get bh
+ exp_vers <- get bh
+ fixities <- {-# SCC "bin_fixities" #-} get bh
+ deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
+ decls <- {-# SCC "bin_tycldecls" #-} get bh
+ insts <- {-# SCC "bin_insts" #-} get bh
+ rules <- {-# SCC "bin_rules" #-} lazyGet bh
+ rule_vers <- get bh
+ return (ModIface {
+ mi_package = HomePackage, -- to be filled in properly later
+ mi_module = mod_name,
+ mi_boot = is_boot,
+ mi_mod_vers = mod_vers,
+ mi_orphan = orphan,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = exports,
+ mi_exp_vers = exp_vers,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+ mi_decls = decls,
+ mi_globals = Nothing,
+ mi_insts = insts,
+ mi_rules = rules,
+ mi_rule_vers = rule_vers,
+ -- And build the cached values
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_ver_fn = mkIfaceVerCache decls })
+
+GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
+
+getWayDescr :: IO String
+getWayDescr = do
+ tag <- readIORef v_Build_tag
+ if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+ -- if this is an unregisterised build, make sure our interfaces
+ -- can't be used by a registerised build.
+
+-------------------------------------------------------------------------
+-- Types from: HscTypes
+-------------------------------------------------------------------------
+
+instance Binary Dependencies where
+ put_ bh deps = do put_ bh (dep_mods deps)
+ put_ bh (dep_pkgs deps)
+ put_ bh (dep_orphs deps)
+
+ get bh = do ms <- get bh
+ ps <- get bh
+ os <- get bh
+ return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
+
+instance (Binary name) => Binary (GenAvailInfo name) where
+ put_ bh (Avail aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (AvailTC ab ac) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Avail aa)
+ _ -> do ab <- get bh
+ ac <- get bh
+ return (AvailTC ab ac)
+
+instance Binary Usage where
+ put_ bh usg = do
+ put_ bh (usg_name usg)
+ put_ bh (usg_mod usg)
+ put_ bh (usg_exports usg)
+ put_ bh (usg_entities usg)
+ put_ bh (usg_rules usg)
+
+ get bh = do
+ nm <- get bh
+ mod <- get bh
+ exps <- get bh
+ ents <- get bh
+ rules <- get bh
+ return (Usage { usg_name = nm, usg_mod = mod,
+ usg_exports = exps, usg_entities = ents,
+ usg_rules = rules })
+
+instance Binary a => Binary (Deprecs a) where
+ put_ bh NoDeprecs = putByte bh 0
+ put_ bh (DeprecAll t) = do
+ putByte bh 1
+ put_ bh t
+ put_ bh (DeprecSome ts) = do
+ putByte bh 2
+ put_ bh ts
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoDeprecs
+ 1 -> do aa <- get bh
+ return (DeprecAll aa)
+ _ -> do aa <- get bh
+ return (DeprecSome aa)
+
+-------------------------------------------------------------------------
+-- Types from: BasicTypes
+-------------------------------------------------------------------------
+
+instance Binary Activation where
+ put_ bh NeverActive = do
+ putByte bh 0
+ put_ bh AlwaysActive = do
+ putByte bh 1
+ put_ bh (ActiveBefore aa) = do
+ putByte bh 2
+ put_ bh aa
+ put_ bh (ActiveAfter ab) = do
+ putByte bh 3
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return NeverActive
+ 1 -> do return AlwaysActive
+ 2 -> do aa <- get bh
+ return (ActiveBefore aa)
+ _ -> do ab <- get bh
+ return (ActiveAfter ab)
+
+instance Binary StrictnessMark where
+ put_ bh MarkedStrict = do
+ putByte bh 0
+ put_ bh MarkedUnboxed = do
+ putByte bh 1
+ put_ bh NotMarkedStrict = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return MarkedStrict
+ 1 -> do return MarkedUnboxed
+ _ -> do return NotMarkedStrict
+
+instance Binary Boxity where
+ put_ bh Boxed = do
+ putByte bh 0
+ put_ bh Unboxed = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Boxed
+ _ -> do return Unboxed
+
+instance Binary TupCon where
+ put_ bh (TupCon ab ac) = do
+ put_ bh ab
+ put_ bh ac
+ get bh = do
+ ab <- get bh
+ ac <- get bh
+ return (TupCon ab ac)
+
+instance Binary RecFlag where
+ put_ bh Recursive = do
+ putByte bh 0
+ put_ bh NonRecursive = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Recursive
+ _ -> do return NonRecursive
+
+instance Binary DefMeth where
+ put_ bh NoDefMeth = putByte bh 0
+ put_ bh DefMeth = putByte bh 1
+ put_ bh GenDefMeth = putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoDefMeth
+ 1 -> return DefMeth
+ _ -> return GenDefMeth
+
+instance Binary FixityDirection where
+ put_ bh InfixL = do
+ putByte bh 0
+ put_ bh InfixR = do
+ putByte bh 1
+ put_ bh InfixN = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return InfixL
+ 1 -> do return InfixR
+ _ -> do return InfixN
+
+instance Binary Fixity where
+ put_ bh (Fixity aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (Fixity aa ab)
+
+instance (Binary name) => Binary (IPName name) where
+ put_ bh (Dupable aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (Linear ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Dupable aa)
+ _ -> do ab <- get bh
+ return (Linear ab)
+
+-------------------------------------------------------------------------
+-- Types from: Demand
+-------------------------------------------------------------------------
+
+instance Binary DmdType where
+ -- Ignore DmdEnv when spitting out the DmdType
+ put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
+ get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
+
+instance Binary Demand where
+ put_ bh Top = do
+ putByte bh 0
+ put_ bh Abs = do
+ putByte bh 1
+ put_ bh (Call aa) = do
+ putByte bh 2
+ put_ bh aa
+ put_ bh (Eval ab) = do
+ putByte bh 3
+ put_ bh ab
+ put_ bh (Defer ac) = do
+ putByte bh 4
+ put_ bh ac
+ put_ bh (Box ad) = do
+ putByte bh 5
+ put_ bh ad
+ put_ bh Bot = do
+ putByte bh 6
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Top
+ 1 -> do return Abs
+ 2 -> do aa <- get bh
+ return (Call aa)
+ 3 -> do ab <- get bh
+ return (Eval ab)
+ 4 -> do ac <- get bh
+ return (Defer ac)
+ 5 -> do ad <- get bh
+ return (Box ad)
+ _ -> do return Bot
+
+instance Binary Demands where
+ put_ bh (Poly aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (Prod ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Poly aa)
+ _ -> do ab <- get bh
+ return (Prod ab)
+
+instance Binary DmdResult where
+ put_ bh TopRes = do
+ putByte bh 0
+ put_ bh RetCPR = do
+ putByte bh 1
+ put_ bh BotRes = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return TopRes
+ 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
+ -- The wrapper was generated for CPR in
+ -- the imported module!
+ _ -> do return BotRes
+
+instance Binary StrictSig where
+ put_ bh (StrictSig aa) = do
+ put_ bh aa
+ get bh = do
+ aa <- get bh
+ return (StrictSig aa)
+
+
+-------------------------------------------------------------------------
+-- Types from: CostCentre
+-------------------------------------------------------------------------
+
+instance Binary IsCafCC where
+ put_ bh CafCC = do
+ putByte bh 0
+ put_ bh NotCafCC = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return CafCC
+ _ -> do return NotCafCC
+
+instance Binary IsDupdCC where
+ put_ bh OriginalCC = do
+ putByte bh 0
+ put_ bh DupdCC = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return OriginalCC
+ _ -> do return DupdCC
+
+instance Binary CostCentre where
+ put_ bh NoCostCentre = do
+ putByte bh 0
+ put_ bh (NormalCC aa ab ac ad) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh ab
+ put_ bh ac
+ put_ bh ad
+ put_ bh (AllCafsCC ae) = do
+ putByte bh 2
+ put_ bh ae
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return NoCostCentre
+ 1 -> do aa <- get bh
+ ab <- get bh
+ ac <- get bh
+ ad <- get bh
+ return (NormalCC aa ab ac ad)
+ _ -> do ae <- get bh
+ return (AllCafsCC ae)
+
+-------------------------------------------------------------------------
+-- IfaceTypes and friends
+-------------------------------------------------------------------------
+
+instance Binary IfaceExtName where
+ put_ bh (ExtPkg mod occ) = do
+ putByte bh 0
+ put_ bh mod
+ put_ bh occ
+ put_ bh (HomePkg mod occ vers) = do
+ putByte bh 1
+ put_ bh mod
+ put_ bh occ
+ put_ bh vers
+ put_ bh (LocalTop occ) = do
+ putByte bh 2
+ put_ bh occ
+ put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
+ putByte bh 2
+ put_ bh occ
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do mod <- get bh
+ occ <- get bh
+ return (ExtPkg mod occ)
+ 1 -> do mod <- get bh
+ occ <- get bh
+ vers <- get bh
+ return (HomePkg mod occ vers)
+ _ -> do occ <- get bh
+ return (LocalTop occ)
+
+instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceTvBndr ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceIdBndr aa)
+ _ -> do ab <- get bh
+ return (IfaceTvBndr ab)
+
+instance Binary Kind where
+ put_ bh LiftedTypeKind = putByte bh 0
+ put_ bh UnliftedTypeKind = putByte bh 1
+ put_ bh OpenTypeKind = putByte bh 2
+ put_ bh ArgTypeKind = putByte bh 3
+ put_ bh UbxTupleKind = putByte bh 4
+ put_ bh (FunKind k1 k2) = do
+ putByte bh 5
+ put_ bh k1
+ put_ bh k2
+ put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return LiftedTypeKind
+ 1 -> return UnliftedTypeKind
+ 2 -> return OpenTypeKind
+ 3 -> return ArgTypeKind
+ 4 -> return UbxTupleKind
+ _ -> do k1 <- get bh
+ k2 <- get bh
+ return (FunKind k1 k2)
+
+instance Binary IfaceType where
+ put_ bh (IfaceForAllTy aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceTyVar ad) = do
+ putByte bh 1
+ put_ bh ad
+ put_ bh (IfaceAppTy ae af) = do
+ putByte bh 2
+ put_ bh ae
+ put_ bh af
+ put_ bh (IfaceFunTy ag ah) = do
+ putByte bh 3
+ put_ bh ag
+ put_ bh ah
+ put_ bh (IfacePredTy aq) = do
+ putByte bh 5
+ put_ bh aq
+
+ -- Simple compression for common cases of TyConApp
+ put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
+ put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
+ put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
+ put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
+ -- Unit tuple and pairs
+ put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
+ put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
+ -- Generic cases
+ put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
+ put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceForAllTy aa ab)
+ 1 -> do ad <- get bh
+ return (IfaceTyVar ad)
+ 2 -> do ae <- get bh
+ af <- get bh
+ return (IfaceAppTy ae af)
+ 3 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceFunTy ag ah)
+ 5 -> do ap <- get bh
+ return (IfacePredTy ap)
+
+ -- Now the special cases for TyConApp
+ 6 -> return (IfaceTyConApp IfaceIntTc [])
+ 7 -> return (IfaceTyConApp IfaceCharTc [])
+ 8 -> return (IfaceTyConApp IfaceBoolTc [])
+ 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
+ 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
+ 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
+ 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
+ _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+
+instance Binary IfaceTyCon where
+ -- Int,Char,Bool can't show up here because they can't not be saturated
+
+ put_ bh IfaceIntTc = putByte bh 1
+ put_ bh IfaceBoolTc = putByte bh 2
+ put_ bh IfaceCharTc = putByte bh 3
+ put_ bh IfaceListTc = putByte bh 4
+ put_ bh IfacePArrTc = putByte bh 5
+ put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
+ put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 1 -> return IfaceIntTc
+ 2 -> return IfaceBoolTc
+ 3 -> return IfaceCharTc
+ 4 -> return IfaceListTc
+ 5 -> return IfacePArrTc
+ 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+ _ -> do { ext <- get bh; return (IfaceTc ext) }
+
+instance Binary IfacePredType where
+ put_ bh (IfaceClassP aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceIParam ac ad) = do
+ putByte bh 1
+ put_ bh ac
+ put_ bh ad
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceClassP aa ab)
+ _ -> do ac <- get bh
+ ad <- get bh
+ return (IfaceIParam ac ad)
+
+-------------------------------------------------------------------------
+-- IfaceExpr and friends
+-------------------------------------------------------------------------
+
+instance Binary IfaceExpr where
+ put_ bh (IfaceLcl aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceType ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh (IfaceTuple ac ad) = do
+ putByte bh 2
+ put_ bh ac
+ put_ bh ad
+ put_ bh (IfaceLam ae af) = do
+ putByte bh 3
+ put_ bh ae
+ put_ bh af
+ put_ bh (IfaceApp ag ah) = do
+ putByte bh 4
+ put_ bh ag
+ put_ bh ah
+-- gaw 2004
+ put_ bh (IfaceCase ai aj al ak) = do
+ putByte bh 5
+ put_ bh ai
+ put_ bh aj
+-- gaw 2004
+ put_ bh al
+ put_ bh ak
+ put_ bh (IfaceLet al am) = do
+ putByte bh 6
+ put_ bh al
+ put_ bh am
+ put_ bh (IfaceNote an ao) = do
+ putByte bh 7
+ put_ bh an
+ put_ bh ao
+ put_ bh (IfaceLit ap) = do
+ putByte bh 8
+ put_ bh ap
+ put_ bh (IfaceFCall as at) = do
+ putByte bh 9
+ put_ bh as
+ put_ bh at
+ put_ bh (IfaceExt aa) = do
+ putByte bh 10
+ put_ bh aa
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceLcl aa)
+ 1 -> do ab <- get bh
+ return (IfaceType ab)
+ 2 -> do ac <- get bh
+ ad <- get bh
+ return (IfaceTuple ac ad)
+ 3 -> do ae <- get bh
+ af <- get bh
+ return (IfaceLam ae af)
+ 4 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceApp ag ah)
+ 5 -> do ai <- get bh
+ aj <- get bh
+-- gaw 2004
+ al <- get bh
+ ak <- get bh
+-- gaw 2004
+ return (IfaceCase ai aj al ak)
+ 6 -> do al <- get bh
+ am <- get bh
+ return (IfaceLet al am)
+ 7 -> do an <- get bh
+ ao <- get bh
+ return (IfaceNote an ao)
+ 8 -> do ap <- get bh
+ return (IfaceLit ap)
+ 9 -> do as <- get bh
+ at <- get bh
+ return (IfaceFCall as at)
+ _ -> do aa <- get bh
+ return (IfaceExt aa)
+
+instance Binary IfaceConAlt where
+ put_ bh IfaceDefault = do
+ putByte bh 0
+ put_ bh (IfaceDataAlt aa) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh (IfaceTupleAlt ab) = do
+ putByte bh 2
+ put_ bh ab
+ put_ bh (IfaceLitAlt ac) = do
+ putByte bh 3
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return IfaceDefault
+ 1 -> do aa <- get bh
+ return (IfaceDataAlt aa)
+ 2 -> do ab <- get bh
+ return (IfaceTupleAlt ab)
+ _ -> do ac <- get bh
+ return (IfaceLitAlt ac)
+
+instance Binary IfaceBinding where
+ put_ bh (IfaceNonRec aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceRec ac) = do
+ putByte bh 1
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceNonRec aa ab)
+ _ -> do ac <- get bh
+ return (IfaceRec ac)
+
+instance Binary IfaceIdInfo where
+ put_ bh NoInfo = putByte bh 0
+ put_ bh (HasInfo i) = do
+ putByte bh 1
+ lazyPut bh i -- NB lazyPut
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoInfo
+ _ -> do info <- lazyGet bh -- NB lazyGet
+ return (HasInfo info)
+
+instance Binary IfaceInfoItem where
+ put_ bh (HsArity aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (HsStrictness ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh (HsUnfold ac ad) = do
+ putByte bh 2
+ put_ bh ac
+ put_ bh ad
+ put_ bh HsNoCafRefs = do
+ putByte bh 3
+ put_ bh (HsWorker ae af) = do
+ putByte bh 4
+ put_ bh ae
+ put_ bh af
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (HsArity aa)
+ 1 -> do ab <- get bh
+ return (HsStrictness ab)
+ 2 -> do ac <- get bh
+ ad <- get bh
+ return (HsUnfold ac ad)
+ 3 -> do return HsNoCafRefs
+ _ -> do ae <- get bh
+ af <- get bh
+ return (HsWorker ae af)
+
+instance Binary IfaceNote where
+ put_ bh (IfaceSCC aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceCoerce ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh IfaceInlineCall = do
+ putByte bh 2
+ put_ bh IfaceInlineMe = do
+ putByte bh 3
+ put_ bh (IfaceCoreNote s) = do
+ putByte bh 4
+ put_ bh s
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceSCC aa)
+ 1 -> do ab <- get bh
+ return (IfaceCoerce ab)
+ 2 -> do return IfaceInlineCall
+ 3 -> do return IfaceInlineMe
+ _ -> do ac <- get bh
+ return (IfaceCoreNote ac)
+
+
+-------------------------------------------------------------------------
+-- IfaceDecl and friends
+-------------------------------------------------------------------------
+
+instance Binary IfaceDecl where
+ put_ bh (IfaceId name ty idinfo) = do
+ putByte bh 0
+ put_ bh name
+ put_ bh ty
+ put_ bh idinfo
+ put_ bh (IfaceForeign ae af) =
+ error "Binary.put_(IfaceDecl): IfaceForeign"
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
+ putByte bh 2
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+
+ put_ bh (IfaceSyn aq ar as at) = do
+ putByte bh 3
+ put_ bh aq
+ put_ bh ar
+ put_ bh as
+ put_ bh at
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
+ putByte bh 4
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do name <- get bh
+ ty <- get bh
+ idinfo <- get bh
+ return (IfaceId name ty idinfo)
+ 1 -> error "Binary.get(TyClDecl): ForeignType"
+ 2 -> do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceData a1 a2 a3 a4 a5 a6 a7)
+ 3 -> do
+ aq <- get bh
+ ar <- get bh
+ as <- get bh
+ at <- get bh
+ return (IfaceSyn aq ar as at)
+ _ -> do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
+
+instance Binary IfaceInst where
+ put_ bh (IfaceInst cls tys dfun flag orph) = do
+ put_ bh cls
+ put_ bh tys
+ put_ bh dfun
+ put_ bh flag
+ put_ bh orph
+ get bh = do cls <- get bh
+ tys <- get bh
+ dfun <- get bh
+ flag <- get bh
+ orph <- get bh
+ return (IfaceInst cls tys dfun flag orph)
+
+instance Binary OverlapFlag where
+ put_ bh NoOverlap = putByte bh 0
+ put_ bh OverlapOk = putByte bh 1
+ put_ bh Incoherent = putByte bh 2
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return NoOverlap
+ 1 -> return OverlapOk
+ 2 -> return Incoherent
+
+instance Binary IfaceConDecls where
+ put_ bh IfAbstractTyCon = putByte bh 0
+ put_ bh (IfDataTyCon cs) = do { putByte bh 1
+ ; put_ bh cs }
+ put_ bh (IfNewTyCon c) = do { putByte bh 2
+ ; put_ bh c }
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfAbstractTyCon
+ 1 -> do cs <- get bh
+ return (IfDataTyCon cs)
+ _ -> do aa <- get bh
+ return (IfNewTyCon aa)
+
+instance Binary IfaceConDecl where
+ put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
+ putByte bh 0
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
+ putByte bh 1
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ return (IfVanillaCon a1 a2 a3 a4 a5)
+ _ -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfGadtCon a1 a2 a3 a4 a5 a6)
+
+instance Binary IfaceClassOp where
+ put_ bh (IfaceClassOp n def ty) = do
+ put_ bh n
+ put_ bh def
+ put_ bh ty
+ get bh = do
+ n <- get bh
+ def <- get bh
+ ty <- get bh
+ return (IfaceClassOp n def ty)
+
+instance Binary IfaceRule where
+ put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+
+
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
new file mode 100644
index 0000000000..f81f2e7d07
--- /dev/null
+++ b/compiler/iface/BuildTyCl.lhs
@@ -0,0 +1,256 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+\begin{code}
+module BuildTyCl (
+ buildSynTyCon, buildAlgTyCon, buildDataCon,
+ buildClass,
+ mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
+ ) where
+
+#include "HsVersions.h"
+
+import IfaceEnv ( newImplicitBinder )
+import TcRnMonad
+
+import DataCon ( DataCon, isNullarySrcDataCon, dataConTyVars,
+ mkDataCon, dataConFieldLabels, dataConOrigArgTys )
+import Var ( tyVarKind, TyVar, Id )
+import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet )
+import TysWiredIn ( unitTy )
+import BasicTypes ( RecFlag, 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, tyConStupidTheta,
+ tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
+ isRecursiveTyCon,
+ ArgVrcs, AlgTyConRhs(..), newTyConRhs )
+import Type ( mkArrowKinds, liftedTypeKind, typeKind,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
+ mkPredTys, mkTyVarTys, ThetaType, Type,
+ substTyWith, zipTopTvSubst, substTheta )
+import Outputable
+import List ( nub )
+
+\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 :: Name -> [TyVar]
+ -> ThetaType -- Stupid theta
+ -> AlgTyConRhs
+ -> ArgVrcs -> RecFlag
+ -> Bool -- True <=> want generics functions
+ -> TcRnIf m n TyCon
+
+buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics
+ = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta
+ rhs fields is_rec want_generics
+ ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+ ; fields = mkTyConSelIds tycon rhs
+ }
+ ; return tycon }
+
+------------------------------------------------------
+mkAbstractTyConRhs :: AlgTyConRhs
+mkAbstractTyConRhs = AbstractTyCon
+
+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
+mkDataTyConRhs cons
+ = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
+
+mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
+mkNewTyConRhs tycon con
+ = NewTyCon { data_con = con,
+ nt_rhs = rhs_ty,
+ nt_etad_rhs = eta_reduce tvs rhs_ty,
+ nt_rep = mkNewTyConRep tycon rhs_ty }
+ where
+ tvs = dataConTyVars con
+ rhs_ty = head (dataConOrigArgTys con)
+ -- Newtypes are guaranteed vanilla, so OrigArgTys will do
+
+ eta_reduce [] ty = ([], ty)
+ eta_reduce (a:as) ty | null as',
+ Just (fun, arg) <- splitAppTy_maybe ty',
+ Just tv <- getTyVar_maybe arg,
+ tv == a,
+ not (a `elemVarSet` tyVarsOfType fun)
+ = ([], fun) -- Successful eta reduction
+ | otherwise
+ = (a:as', ty')
+ where
+ (as', ty') = eta_reduce as ty
+
+mkNewTyConRep :: TyCon -- The original type constructor
+ -> Type -- The arg type of its constructor
+ -> Type -- Chosen representation type
+-- The "representation type" is guaranteed not to be another newtype
+-- at the outermost level; but it might have newtypes in type arguments
+
+-- 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 rhs_ty
+ | null (tyConDataCons tc) = unitTy
+ -- External Core programs can have newtypes with no data constructors
+ | otherwise = go [tc] rhs_ty
+ where
+ -- Invariant: tcs have been seen before
+ go tcs rep_ty
+ = case splitTyConApp_maybe rep_ty of
+ Just (tc, tys)
+ | tc `elem` tcs -> unitTy -- Recursive loop
+ | isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
+ -- Non-recursive ones have been
+ -- dealt with by splitTyConApp_maybe
+ go (tc:tcs) (substTyWith tvs tys rhs_ty)
+ where
+ (tvs, rhs_ty) = newTyConRhs tc
+
+ other -> rep_ty
+
+------------------------------------------------------
+buildDataCon :: Name -> Bool -> Bool
+ -> [StrictnessMark]
+ -> [Name] -- Field labels
+ -> [TyVar]
+ -> ThetaType -- Does not include the "stupid theta"
+ -> [Type] -> TyCon -> [Type]
+ -> 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 declared_infix vanilla arg_stricts field_lbls
+ tyvars ctxt arg_tys tycon res_tys
+ = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
+ ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
+ -- This last one takes the name of the data constructor in the source
+ -- code, which (for Haskell source anyway) will be in the DataName name
+ -- space, and puts it into the VarName name space
+
+ ; let
+ stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys
+ data_con = mkDataCon src_name declared_infix vanilla
+ arg_stricts field_lbls
+ tyvars stupid_ctxt ctxt
+ arg_tys tycon res_tys dc_ids
+ dc_ids = mkDataConIds wrap_name work_name data_con
+
+ ; returnM data_con }
+
+
+-- The stupid context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+mkDataConStupidTheta tycon arg_tys res_tys
+ | null stupid_theta = [] -- The common case
+ | otherwise = filter in_arg_tys stupid_theta
+ where
+ tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
+ stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+ -- Start by instantiating the master copy of the
+ -- stupid theta, taken from the TyCon
+
+ arg_tyvars = tyVarsOfTypes arg_tys
+ in_arg_tys pred = not $ isEmptyVarSet $
+ tyVarsOfPred pred `intersectVarSet` arg_tyvars
+
+------------------------------------------------------
+mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
+mkTyConSelIds tycon rhs
+ = [ mkRecordSelId tycon fld
+ | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
+ -- We'll check later that fields with the same name
+ -- from different constructors have the same type.
+\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
+ False -- Not declared infix
+ True -- Is vanilla; tyvars same as tycon
+ (map (const NotMarkedStrict) dict_component_tys)
+ [{- No labelled fields -}]
+ tvs [{-No context-}] dict_component_tys
+ (classTyCon clas) (mkTyVarTys tvs)
+
+ ; let { clas = mkClass class_name tvs fds
+ sc_theta sc_sel_ids op_items
+ tycon
+
+ ; tycon = mkClassTyCon tycon_name clas_kind tvs
+ tc_vrcs rhs clas 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
+
+ ; rhs = case dict_component_tys of
+ [rep_ty] -> mkNewTyConRhs tycon dict_con
+ other -> mkDataTyConRhs [dict_con]
+ }
+ ; return clas
+ })}
+\end{code}
+
+
diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
new file mode 100644
index 0000000000..40b7d31f13
--- /dev/null
+++ b/compiler/iface/IfaceEnv.lhs
@@ -0,0 +1,359 @@
+(c) The University of Glasgow 2002
+
+\begin{code}
+module IfaceEnv (
+ newGlobalBinder, newIPName, newImplicitBinder,
+ lookupIfaceTop, lookupIfaceExt,
+ lookupOrig, lookupIfaceTc,
+ newIfaceName, newIfaceNames,
+ extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
+ tcIfaceLclId, tcIfaceTyVar,
+
+ lookupAvail, ifaceExportNames,
+
+ -- Name-cache stuff
+ allocateGlobalBinder, initNameCache,
+ ) where
+
+#include "HsVersions.h"
+
+import TcRnMonad
+import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
+import TysWiredIn ( tupleTyCon, tupleCon )
+import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..),
+ IfaceExport, OrigNameCache )
+import Type ( mkOpenTvSubst, substTy )
+import TyCon ( TyCon, tyConName )
+import Unify ( TypeRefinement )
+import DataCon ( dataConWorkId, dataConName )
+import Var ( TyVar, Id, varName, setIdType, idType )
+import Name ( Name, nameUnique, nameModule,
+ nameOccName, nameSrcLoc,
+ getOccName, nameParent_maybe,
+ isWiredInName, mkIPName,
+ mkExternalName, mkInternalName )
+import NameSet ( NameSet, emptyNameSet, addListToNameSet )
+import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv,
+ lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
+import PrelNames ( gHC_PRIM, pREL_TUP )
+import Module ( Module, emptyModuleEnv,
+ lookupModuleEnv, 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
+ -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
+ ; 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) 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 parent and SrcLoc
+ -- of the Name, so we set these fields in the Name we return.
+ --
+ -- 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
+
+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
+ifaceExportNames exports
+ = foldlM do_one emptyNameSet exports
+ where
+ do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
+ do_avail mod acc avail = do { ns <- lookupAvail mod avail
+ ; return (addListToNameSet acc ns) }
+
+lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
+-- Find all the names arising from an import
+-- Make sure the parent info is correct, even though we may not
+-- yet have read the interface for this module
+lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n;
+ ; return [n'] }
+lookupAvail mod (AvailTC p_occ occs)
+ = do { p_name <- lookupOrig mod p_occ
+ ; let lookup_sub occ | occ == p_occ = return p_name
+ | otherwise = lookup_orig mod occ (Just p_name)
+ ; mappM lookup_sub occs }
+ -- Remember that 'occs' is all the exported things, including
+ -- the parent. It's possible to export just class ops without
+ -- the class, via C( op ). If the class was exported too we'd
+ -- have C( C, op )
+
+ -- The use of lookupOrigSub here (rather than lookupOrig)
+ -- ensures that the subordinate names record their parent;
+ -- and that in turn ensures that the GlobalRdrEnv
+ -- has the correct parent for all the names in its range.
+ -- For imported things, we may only suck in the interface later, if ever.
+ -- Reason for all this:
+ -- Suppose module M exports type A.T, and constructor A.MkT
+ -- Then, we know that A.MkT is a subordinate 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.
+
+
+lookupOrig :: Module -> OccName -> TcRnIf a b Name
+-- Even if we get a miss in the original-name cache, we
+-- make a new External Name.
+-- We fake up
+-- SrcLoc to noSrcLoc
+-- Parent no Nothing
+-- They'll be overwritten, in due course, by LoadIface.loadDecl.
+lookupOrig mod occ = lookup_orig mod occ Nothing
+
+lookup_orig :: Module -> OccName -> Maybe Name -> TcRnIf a b Name
+-- Used when we know the parent of the thing we are looking up
+lookup_orig mod occ mb_parent
+ = do { -- First ensure that mod 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 occ of {
+ Just name -> returnM name ;
+ Nothing -> do
+
+ { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ ; uniq = uniqFromSupply us1
+ ; name = mkExternalName uniq mod occ mb_parent noSrcLoc
+ ; new_cache = extend_name_cache (nsNames name_supply) mod occ name
+ ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+ }
+ ; 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 -> Module -> OccName -> Maybe Name
+lookupOrigNameCache nc mod occ
+ | mod == pREL_TUP || mod == gHC_PRIM, -- 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 occ -- The normal case
+ = case lookupModuleEnv nc mod 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}
+
+
+
+%************************************************************************
+%* *
+ Type variables and local Ids
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceLclId :: OccName -> IfL Id
+tcIfaceLclId occ
+ = do { lcl <- getLclEnv
+ ; return (lookupOccEnv (if_id_env lcl) occ
+ `orElse`
+ pprPanic "tcIfaceLclId" (ppr occ)) }
+
+refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
+refineIfaceIdEnv (tv_subst, _) thing_inside
+ = do { env <- getLclEnv
+ ; let { id_env' = mapOccEnv refine_id (if_id_env env)
+ ; refine_id id = setIdType id (substTy subst (idType id))
+ ; subst = mkOpenTvSubst tv_subst }
+ ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+
+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 }
+
+
+tcIfaceTyVar :: OccName -> IfL TyVar
+tcIfaceTyVar occ
+ = do { lcl <- getLclEnv
+ ; return (lookupOccEnv (if_tv_env lcl) occ
+ `orElse`
+ pprPanic "tcIfaceTyVar" (ppr occ)) }
+
+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
+%* *
+%************************************************************************
+
+\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}
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
new file mode 100644
index 0000000000..99501a5b68
--- /dev/null
+++ b/compiler/iface/IfaceSyn.lhs
@@ -0,0 +1,998 @@
+%
+% (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(..), IfaceConDecls(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..),
+ IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+
+ -- Misc
+ visibleIfConDecls,
+
+ -- Converting things to IfaceSyn
+ tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule,
+
+ -- Equality
+ IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
+ eqIfDecl, eqIfInst, eqIfRule,
+
+ -- Pretty printing
+ pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
+ ) where
+
+#include "HsVersions.h"
+
+import CoreSyn
+import IfaceType
+
+import FunDeps ( pprFundeps )
+import NewDemand ( StrictSig, pprIfaceStrictSig )
+import TcType ( deNoteType )
+import Type ( TyThing(..), splitForAllTys, funResultTy )
+import InstEnv ( Instance(..), OverlapFlag )
+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 ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
+ isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
+ isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
+ tyConHasGenerics, tyConArgVrcs, synTyConRhs,
+ tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
+import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
+ dataConTyCon, dataConIsInfix, isVanillaDataCon )
+import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
+import OccName ( OccName, OccEnv, emptyOccEnv,
+ lookupOccEnv, extendOccEnv, parenSymOcc,
+ OccSet, unionOccSets, unitOccSet )
+import Name ( Name, NamedThing(..), nameOccName, isExternalName )
+import CostCentre ( CostCentre, pprCostCentreCore )
+import Literal ( Literal )
+import ForeignCall ( ForeignCall )
+import TysPrim ( alphaTyVars )
+import BasicTypes ( Arity, Activation(..), StrictnessMark,
+ 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 { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifCtxt :: IfaceContext, -- The "stupid theta"
+ ifCons :: IfaceConDecls, -- Includes new/data info
+ 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 IfaceConDecls
+ = IfAbstractTyCon -- No info
+ | IfDataTyCon [IfaceConDecl] -- data type decls
+ | IfNewTyCon IfaceConDecl -- newtype decls
+
+visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
+visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls (IfDataTyCon cs) = cs
+visibleIfConDecls (IfNewTyCon c) = [c]
+
+data IfaceConDecl
+ = IfVanillaCon {
+ ifConOcc :: OccName, -- Constructor name
+ ifConInfix :: Bool, -- True <=> declared infix
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types
+ ifConFields :: [OccName] } -- ...ditto... (field labels)
+ | IfGadtCon {
+ ifConOcc :: OccName, -- Constructor name
+ ifConTyVars :: [IfaceTvBndr], -- All tyvars
+ ifConCtxt :: IfaceContext, -- Non-stupid context
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConResTys :: [IfaceType], -- Result type args
+ ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
+
+data IfaceInst
+ = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
+ ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
+ ifDFun :: OccName, -- The dfun
+ ifOFlag :: OverlapFlag, -- Overlap flag
+ ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance
+ -- 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,
+ ifRuleOrph :: Maybe OccName -- Just like IfaceInst
+ }
+
+data IfaceIdInfo
+ = NoInfo -- When writing interface file without -O
+ | HasInfo [IfaceInfoItem] -- Has info, and here it is
+
+-- Here's a tricky case:
+-- * Compile with -O module A, and B which imports A.f
+-- * Change function f in A, and recompile without -O
+-- * When we read in old A.hi we read in its IdInfo (as a thunk)
+-- (In earlier GHCs we used to drop IdInfo immediately on reading,
+-- but we do not do that now. Instead it's discarded when the
+-- ModIface is read into the various decl pools.)
+-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
+-- and so gives a new version.
+
+data IfaceInfoItem
+ = HsArity Arity
+ | HsStrictness StrictSig
+ | HsUnfold Activation IfaceExpr
+ | HsNoCafRefs
+ | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
+ -- for why we want arity here.
+ -- NB: we need IfaceExtName (not just OccName) because the worker
+ -- can simplify to a function in another module.
+-- 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 IfaceType [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") <+> pprIfaceDeclHead [] tycon tyvars)
+ 4 (vcat [equals <+> ppr mono_ty,
+ pprVrcs vrcs])
+
+pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
+ ifTyVars = tyvars, ifCons = condecls,
+ ifRec = isrec, ifVrcs = vrcs})
+ = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
+ 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
+ where
+ pp_nd = case condecls of
+ IfAbstractTyCon -> ptext SLIT("data")
+ IfDataTyCon _ -> ptext SLIT("data")
+ IfNewTyCon _ -> ptext SLIT("newtype")
+
+pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
+ ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
+ = hang (ptext SLIT("class") <+> pprIfaceDeclHead 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
+pprGen True = ptext SLIT("Generics: yes")
+pprGen False = ptext SLIT("Generics: no")
+
+instance Outputable IfaceClassOp where
+ ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
+
+pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context thing tyvars
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
+
+pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
+ (map (pprIfaceConDecl tc) cs))
+
+pprIfaceConDecl tc (IfVanillaCon {
+ ifConOcc = name, ifConInfix = is_infix,
+ ifConArgTys = arg_tys,
+ ifConStricts = strs, ifConFields = fields })
+ = sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
+ if is_infix then ptext SLIT("Infix") else empty,
+ 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))]
+
+pprIfaceConDecl tc (IfGadtCon {
+ ifConOcc = name,
+ ifConTyVars = tvs, ifConCtxt = ctxt,
+ ifConArgTys = arg_tys, ifConResTys = res_tys,
+ ifConStricts = strs })
+ = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau),
+ if null strs then empty
+ else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))]
+ where
+ con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
+ tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys
+ -- Gruesome, but jsut for debug print
+
+instance Outputable IfaceRule where
+ ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = 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])
+ ]
+
+instance Outputable IfaceInst where
+ ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
+ ifInstCls = cls, ifInstTys = mb_tcs})
+ = hang (ptext SLIT("instance") <+> ppr flag
+ <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
+ 2 (equals <+> ppr dfun_id)
+ where
+ ppr_mb Nothing = dot
+ ppr_mb (Just tc) = ppr tc
+\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)
+
+-- gaw 2004
+pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
+-- gaw 2004
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
+ pprIfaceExpr noParens rhs <+> char '}'])
+
+-- gaw 2004
+pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
+-- gaw 2004
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> 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
+ ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
+ -- IfaceTupleAlt is handled by the case-alternative printer
+
+------------------
+instance Outputable IfaceIdInfo where
+ ppr NoInfo = empty
+ 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 :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+-- Assumption: the thing is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- Reason: Iface stuff uses OccNames, and the conversion here does
+-- not do tidying on the way
+tyThingToIfaceDecl ext (AnId id)
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType ext (idType id),
+ ifIdInfo = info }
+ where
+ info = case toIfaceIdInfo ext (idInfo id) of
+ [] -> NoInfo
+ items -> HasInfo items
+
+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 { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifCtxt = toIfaceContext ext (tyConStupidTheta tycon),
+ ifCons = ifaceConDecls (algTyConRhs 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 { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
+ ifCtxt = [],
+ ifCons = IfAbstractTyCon,
+ ifGeneric = False,
+ ifRec = NonRecursive,
+ ifVrcs = tyConArgVrcs tycon }
+
+ | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
+ where
+ tyvars = tyConTyVars tycon
+ syn_ty = synTyConRhs tycon
+
+ ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ -- The last case happens when a TyCon has been trimmed during tidying
+ -- Furthermore, tyThingToIfaceDecl is also used
+ -- in TcRnDriver for GHCi, when browsing a module, in which case the
+ -- AbstractTyCon case is perfectly sensible.
+
+ ifaceConDecl data_con
+ | isVanillaDataCon data_con
+ = IfVanillaCon {ifConOcc = getOccName (dataConName data_con),
+ ifConInfix = dataConIsInfix data_con,
+ ifConArgTys = map (toIfaceType ext) arg_tys,
+ ifConStricts = strict_marks,
+ ifConFields = map getOccName field_labels }
+ | otherwise
+ = IfGadtCon { ifConOcc = getOccName (dataConName data_con),
+ ifConTyVars = toIfaceTvBndrs tyvars,
+ ifConCtxt = toIfaceContext ext theta,
+ ifConArgTys = map (toIfaceType ext) arg_tys,
+ ifConResTys = map (toIfaceType ext) res_tys,
+ ifConStricts = strict_marks }
+ where
+ (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con
+ field_labels = dataConFieldLabels data_con
+ strict_marks = dataConStrictMarks data_con
+
+tyThingToIfaceDecl ext (ADataCon dc)
+ = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+
+
+--------------------------
+instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst
+instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
+ is_cls = cls, is_tcs = mb_tcs,
+ is_orph = orph })
+ = IfaceInst { ifDFun = getOccName dfun_id,
+ ifOFlag = oflag,
+ ifInstCls = ext_lhs cls,
+ ifInstTys = map do_rough mb_tcs,
+ ifInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n)
+
+--------------------------
+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 (ext (idName 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 :: (Name -> IfaceExtName) -- For the LHS names
+ -> (Name -> IfaceExtName) -- For the RHS names
+ -> CoreRule -> IfaceRule
+coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn})
+ = pprTrace "toHsRule: builtin" (ppr fn) $
+ bogusIfaceRule (mkIfaceExtName fn)
+
+coreRuleToIfaceRule ext_lhs ext_rhs
+ (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs, ru_orph = orph })
+ = IfaceRule { ifRuleName = name, ifActivation = act,
+ ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
+ ifRuleHead = ext_lhs fn,
+ ifRuleArgs = map do_arg args,
+ ifRuleRhs = toIfaceExpr ext_rhs rhs,
+ ifRuleOrph = orph }
+ where
+ -- For type args we must remove synonyms from the outermost
+ -- level. Reason: so that when we read it back in we'll
+ -- construct the same ru_rough field as we have right now;
+ -- see tcIfaceRule
+ do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty))
+ do_arg arg = toIfaceExpr ext_lhs arg
+
+bogusIfaceRule :: IfaceExtName -> IfaceRule
+bogusIfaceRule id_name
+ = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
+ ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+
+---------------------
+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]
+-- gaw 2004
+toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (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
+\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 &&
+ 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)
+ )
+ -- The type variables of the data type do not scope
+ -- over the constructors (any more), but they do scope
+ -- over the stupid context in the IfaceConDecls
+
+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)
+-- All other changes are handled via the version info on the dfun
+
+eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
+ (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
+ = bool (n1==n2 && a1==a2 && o1 == o2) &&&
+ 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)
+
+eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
+ = eqListBy (eq_ConDecl env) c1 c2
+
+eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
+eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
+eq_hsCD env d1 d2 = NotEqual
+
+eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {})
+ = bool (ifConOcc c1 == ifConOcc c2 &&
+ ifConInfix c1 == ifConInfix c2 &&
+ ifConStricts c1 == ifConStricts c2 &&
+ ifConFields c1 == ifConFields c2) &&&
+ eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)
+
+eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {})
+ = bool (ifConOcc c1 == ifConOcc c2 &&
+ ifConStricts c1 == ifConStricts c2) &&&
+ eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env ->
+ eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
+ eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&&
+ eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2))
+
+eq_ConDecl env c1 c2 = NotEqual
+
+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 (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 wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
+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 ty1 as1) (IfaceCase s2 b2 ty2 as2)
+ = eq_ifaceExpr env s1 s2 &&&
+ eq_ifType env ty1 ty2 &&&
+ 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}
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
new file mode 100644
index 0000000000..76438ddb23
--- /dev/null
+++ b/compiler/iface/IfaceType.lhs
@@ -0,0 +1,390 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+
+ This module defines interface types and binders
+
+\begin{code}
+module IfaceType (
+ IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+ IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
+
+ IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
+ ifaceTyConName, interactiveExtNameFun,
+
+ -- Conversion from Type -> IfaceType
+ toIfaceType, toIfacePred, toIfaceContext,
+ toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
+ toIfaceTyCon, toIfaceTyCon_name,
+
+ -- Printing
+ pprIfaceType, pprParendIfaceType, pprIfaceContext,
+ pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
+ tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
+
+ ) where
+
+#include "HsVersions.h"
+
+import Kind ( Kind(..) )
+import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType )
+import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
+import Var ( isId, tyVarKind, idType )
+import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
+import OccName ( OccName, parenSymOcc )
+import Name ( Name, getName, getOccName, nameModule, nameOccName,
+ wiredInNameTyThing_maybe )
+import Module ( Module )
+import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
+import Outputable
+import FastString
+\end{code}
+
+
+%************************************************************************
+%* *
+ IfaceExtName
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceExtName
+ = ExtPkg Module OccName -- From an external package; no version #
+ -- Also used for wired-in things regardless
+ -- of whether they are home-pkg or not
+
+ | HomePkg Module OccName Version -- From another module in home package;
+ -- has version #; in all other respects,
+ -- HomePkg and ExtPkg are the same
+
+ | 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
+
+isLocalIfaceExtName :: IfaceExtName -> Bool
+isLocalIfaceExtName (LocalTop _) = True
+isLocalIfaceExtName (LocalTopSub _ _) = True
+isLocalIfaceExtName other = False
+
+mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
+ -- Local helper for wired-in names
+
+ifaceExtOcc :: IfaceExtName -> OccName
+ifaceExtOcc (ExtPkg _ occ) = occ
+ifaceExtOcc (HomePkg _ occ _) = occ
+ifaceExtOcc (LocalTop occ) = occ
+ifaceExtOcc (LocalTopSub occ _) = occ
+
+interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
+interactiveExtNameFun print_unqual name
+ | print_unqual mod occ = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
+\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)
+
+-------------------------------
+type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it
+
+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}
+-- These instances are used only when printing for the user, either when
+-- debugging, or in GHCi when printing the results of a :info command
+instance Outputable IfaceExtName where
+ ppr (ExtPkg mod occ) = pprExt mod occ
+ ppr (HomePkg mod occ vers) = pprExt mod occ <> braces (ppr vers)
+ ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these
+ ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
+
+pprExt :: Module -> OccName -> SDoc
+-- No need to worry about printing unqualified becuase that was handled
+-- in the transiation to IfaceSyn
+pprExt mod occ = ppr mod <> dot <> ppr occ
+
+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, LiftedTypeKind) = 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 IfaceType where
+ ppr ty = pprIfaceTypeForUser ty
+
+pprIfaceTypeForUser ::IfaceType -> SDoc
+-- Drop top-level for-alls; if that's not what you want, use pprIfaceType dire
+pprIfaceTypeForUser ty
+ = pprIfaceForAllPart [] theta (pprIfaceType tau)
+ where
+ (_tvs, theta, tau) = splitIfaceSigmaTy ty
+
+pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
+pprIfaceType = ppr_ty tOP_PREC
+pprParendIfaceType = ppr_ty tYCON_PREC
+
+
+ppr_ty :: Int -> IfaceType -> SDoc
+ppr_ty ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
+ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (IfacePredTy st) = ppr st
+
+ -- Function types
+ppr_ty 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 (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
+ where
+ ppr_fun_tail (IfaceFunTy ty1 ty2)
+ = (arrow <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty
+ = [arrow <+> pprIfaceType other_ty]
+
+ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
+ = maybeParen ctxt_prec tYCON_PREC $
+ ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2
+
+ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
+ = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType 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 tc
+ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (pprIfaceType ty)
+ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
+ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
+ | arity == length tys
+ = tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
+ppr_tc_app ctxt_prec tc tys
+ = maybeParen ctxt_prec tYCON_PREC
+ (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
+
+ppr_tc :: IfaceTyCon -> SDoc
+-- Wrap infix type constructors in parens
+ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (ifaceExtOcc ext_nm) (ppr tc)
+ppr_tc tc = ppr tc
+
+-------------------
+instance Outputable IfacePredType where
+ -- Print without parens
+ ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty]
+ ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (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 = ppr_preds theta <+> ptext SLIT("=>")
+
+ppr_preds [pred] = ppr pred -- No parens
+ppr_preds preds = parens (sep (punctuate comma (map ppr preds)))
+
+-------------------
+pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+\end{code}
+
+%************************************************************************
+%* *
+ Conversion from Type to IfaceType
+%* *
+%************************************************************************
+
+\begin{code}
+----------------
+toIfaceTvBndr tyvar = (getOccName tyvar, 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)
+
+---------------------
+toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
+-- Synonyms are retained in the interface type
+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 (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon 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 other_note ty) = toIfaceType ext ty
+
+----------------
+-- A little bit of (perhaps optional) trickiness here. When
+-- compiling Data.Tuple, the tycons are not TupleTyCons, although
+-- they have a wired-in name. But we'd like to dump them into the Iface
+-- as a tuple tycon, to save lookups when reading the interface
+-- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then
+-- toIfaceTyCon_name will still catch it.
+
+toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
+toIfaceTyCon ext tc
+ | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | otherwise = toIfaceTyCon_name ext (tyConName tc)
+
+toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon
+toIfaceTyCon_name ext nm
+ | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm
+ = toIfaceWiredInTyCon ext tc nm
+ | otherwise
+ = IfaceTc (ext nm)
+
+toIfaceWiredInTyCon :: (Name -> IfaceExtName) -> TyCon -> Name -> IfaceTyCon
+toIfaceWiredInTyCon ext tc nm
+ | 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)
+
+----------------
+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}
+
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
new file mode 100644
index 0000000000..8c496f76ef
--- /dev/null
+++ b/compiler/iface/LoadIface.lhs
@@ -0,0 +1,582 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{Dealing with interface files}
+
+\begin{code}
+module LoadIface (
+ loadInterface, loadHomeInterface, loadWiredInHomeIface,
+ loadSrcInterface, loadSysInterface, loadOrphanModules,
+ findAndReadIface, readIface, -- Used when reading the module's old interface
+ loadDecls, ifaceStats, discardDeclPrags,
+ initExternalPackageState
+ ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst )
+
+import Packages ( PackageState(..), PackageIdH(..), isHomePackage )
+import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ),
+ isOneShot )
+import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
+ IfaceConDecls(..), IfaceIdInfo(..) )
+import IfaceEnv ( newGlobalBinder )
+import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..),
+ addEpsInStats, ExternalPackageState(..),
+ PackageTypeEnv, emptyTypeEnv, HscEnv(..),
+ lookupIfaceByModule, emptyPackageIfaceTable,
+ IsBootInterface, mkIfaceFixCache,
+ implicitTyThings
+ )
+
+import BasicTypes ( Version, Fixity(..), FixityDirection(..),
+ isMarkedStrict )
+import TcRnMonad
+
+import PrelNames ( gHC_PRIM )
+import PrelInfo ( ghcPrimExports )
+import PrelRules ( builtinRules )
+import Rules ( extendRuleBaseList, mkRuleBase )
+import InstEnv ( emptyInstEnv, extendInstEnvList )
+import Name ( Name {-instance NamedThing-}, getOccName,
+ nameModule, nameIsLocalOrFrom, isWiredInName )
+import NameEnv
+import MkId ( seqId )
+import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv,
+ addBootSuffix_maybe,
+ extendModuleEnv, lookupModuleEnv, moduleString
+ )
+import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
+import SrcLoc ( importedSrcLoc )
+import Maybes ( MaybeErr(..) )
+import FastString ( mkFastString )
+import ErrUtils ( Message )
+import Finder ( findModule, findPackageModule, FindResult(..), cantFindError )
+import Outputable
+import BinIface ( readBinIface )
+import Panic ( ghcError, tryMost, showException, GhcException(..) )
+import List ( nub )
+\end{code}
+
+
+%************************************************************************
+%* *
+ loadSrcInterface, loadOrphanModules, loadHomeInterface
+
+ These three are called from TcM-land
+%* *
+%************************************************************************
+
+\begin{code}
+loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface
+-- This is called for each 'import' declaration in the source code
+-- On a failure, fail in the monad with an error message
+
+loadSrcInterface doc mod want_boot
+ = do { mb_iface <- initIfaceTcRn $
+ loadInterface doc mod (ImportByUser want_boot)
+ ; case mb_iface of
+ Failed err -> failWithTc (elaborate err)
+ Succeeded iface -> return iface
+ }
+ where
+ elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
+ quotes (ppr mod) <> colon) 4 err
+
+---------------
+loadOrphanModules :: [Module] -> 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")
+
+---------------
+loadHomeInterface :: SDoc -> Name -> TcRn ModIface
+loadHomeInterface doc name
+ = do {
+#ifdef DEBUG
+ -- Should not be called with a name from the module being compiled
+ this_mod <- getModule
+ ; ASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc )
+#endif
+ initIfaceTcRn $ loadSysInterface doc (nameModule name)
+ }
+
+---------------
+loadWiredInHomeIface :: Name -> IfM lcl ()
+-- A IfM function to load the home interface for a wired-in thing,
+-- so that we're sure that we see its instance declarations and rules
+loadWiredInHomeIface name
+ = ASSERT( isWiredInName name )
+ do { loadSysInterface doc (nameModule name); return () }
+ where
+ doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name
+
+---------------
+loadSysInterface :: SDoc -> Module -> 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
+ Failed err -> ghcError (ProgramError (showSDoc err))
+ Succeeded 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 -> Module -> WhereFrom
+ -> IfM lcl (MaybeErr 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
+
+loadInterface doc_str mod from
+ = do { -- Read the state
+ (eps,hpt) <- getEpsAndHpt
+
+ ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
+
+ -- Check whether we have the interface already
+ ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
+ Just iface
+ -> returnM (Succeeded 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
+
+ { let { hi_boot_file = case from of
+ ImportByUser usr_boot -> usr_boot
+ ImportBySystem -> sys_boot
+
+ ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod
+ ; 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
+ ; let explicit | ImportByUser _ <- from = True
+ | otherwise = False
+ ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file
+ ; dflags <- getDOpts
+ ; case read_result of {
+ Failed err -> do
+ { let fake_iface = emptyModIface HomePackage mod
+
+ ; updateEps_ $ \eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+ -- Not found, so add an empty iface to
+ -- the EPS map so that we don't look again
+
+ ; returnM (Failed err) } ;
+
+ -- Found and parsed!
+ Succeeded (iface, file_path) -- Sanity check:
+ | ImportBySystem <- from, -- system-importing...
+ isHomePackage (mi_package iface), -- ...a home-package module
+ Nothing <- mb_dep -- ...that we know nothing about
+ -> returnM (Failed (badDepMsg mod))
+
+ | otherwise ->
+
+ let
+ loc_doc = text file_path
+ in
+ initIfaceLcl mod loc_doc $ 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)
+
+ ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
+ ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
+ ; new_eps_rules <- if ignore_prags
+ then return []
+ else mapM tcIfaceRule (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" } }
+
+ ; updateEps_ $ \ eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
+ eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules,
+ eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts,
+ eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
+ (length new_eps_insts) (length new_eps_rules) }
+
+ ; return (Succeeded final_iface)
+ }}}}
+
+badDepMsg mod
+ = hang (ptext SLIT("Interface file inconsistency:"))
+ 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"),
+ ptext SLIT("but does not appear in the dependencies of the interface")])
+
+-----------------------------------------------------
+-- 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
+-----------------------------------------------------
+
+addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
+addDeclsToPTE pte things = extendNameEnvList pte things
+
+loadDecls :: Bool
+ -> [(Version, IfaceDecl)]
+ -> IfL [(Name,TyThing)]
+loadDecls ignore_prags ver_decls
+ = do { mod <- getIfModule
+ ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
+ ; return (concat thingss)
+ }
+
+loadDecl :: Bool -- Don't load pragmas into the decl pool
+ -> Module
+ -> (Version, IfaceDecl)
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
+loadDecl ignore_prags mod (_version, decl)
+ = do { -- Populate the name cache with final versions of all
+ -- the names associated with the decl
+ main_name <- mk_new_bndr mod Nothing (ifName decl)
+ ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
+
+ -- Typecheck the thing, lazily
+ -- NB. firstly, the laziness is there in case we never need the
+ -- declaration (in one-shot mode), and secondly it is there so that
+ -- we don't look up the occurrence of a name before calling mk_new_bndr
+ -- on the binder. This is important because we must get the right name
+ -- which includes its nameParent.
+ ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
+ ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+ lookup n = case lookupOccEnv mini_env (getOccName n) of
+ Just thing -> thing
+ Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n)
+
+ ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
+ -- We build a list from the *known* names, with (lookup n) thunks
+ -- as the TyThings. That way we can extend the PTE without poking the
+ -- thunks
+ where
+ stripped_decl | ignore_prags = discardDeclPrags decl
+ | otherwise = decl
+
+ -- mk_new_bndr allocates in the name cache the final canonical
+ -- name for the thing, with the correct
+ -- * parent
+ -- * location
+ -- imported name, to fix the module correctly in the cache
+ mk_new_bndr mod mb_parent occ
+ = newGlobalBinder mod occ mb_parent
+ (importedSrcLoc (moduleString mod))
+
+ doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
+
+discardDeclPrags :: IfaceDecl -> IfaceDecl
+discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
+discardDeclPrags decl = decl
+
+bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
+bumpDeclStats name
+ = do { traceIf (text "Loading decl for" <+> ppr name)
+ ; updateEps_ (\eps -> let stats = eps_stats eps
+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+ }
+
+-----------------
+ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- Deeply revolting, because it has to predict what gets bound,
+-- especially the question of whether there's a wrapper for a datacon
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
+ = [tc_occ, dc_occ, dcww_occ] ++
+ [op | IfaceClassOp op _ _ <- sigs] ++
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
+ where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
+ tc_occ = mkClassTyConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
+ dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
+ | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
+ = []
+-- Newtype
+ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ,
+ ifConFields = fields})})
+ = fields ++ [con_occ, mkDataConWrapperOcc con_occ]
+ -- Wrapper, no worker; see MkId.mkDataConIds
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ = nub (concatMap fld_occs cons) -- Eliminate duplicate fields
+ ++ concatMap dc_occs cons
+ where
+ fld_occs (IfVanillaCon { ifConFields = fields }) = fields
+ fld_occs (IfGadtCon {}) = []
+ dc_occs con_decl
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl
+ strs = ifConStricts con_decl
+ wrap_occ = mkDataConWrapperOcc con_occ
+ work_occ = mkDataConWorkerOcc con_occ
+ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ -- ToDo: may miss strictness in existential dicts
+
+ifaceDeclSubBndrs _other = []
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Reading an interface file}
+%* *
+%*********************************************************
+
+\begin{code}
+findAndReadIface :: Bool -- True <=> explicit user import
+ -> SDoc -> Module
+ -> IsBootInterface -- True <=> Look for a .hi-boot file
+ -- False <=> Look for .hi file
+ -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
+ -- 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 explicit 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
+ ; dflags <- getDOpts
+ ; let base_pkg = basePackageId (pkgState dflags)
+ ; if mod_name == gHC_PRIM
+ then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg },
+ "<built in interface for GHC.Prim>"))
+ else do
+
+ -- Look for the file
+ ; hsc_env <- getTopEnv
+ ; mb_found <- ioToIOEnv (findHiFile hsc_env explicit mod_name hi_boot_file)
+ ; case mb_found of {
+ Failed err -> do
+ { traceIf (ptext SLIT("...not found"))
+ ; dflags <- getDOpts
+ ; returnM (Failed (cantFindError dflags mod_name err)) } ;
+
+ Succeeded (file_path, pkg) -> 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
+ Failed err -> returnM (Failed (badIfaceFile file_path err))
+ Succeeded iface
+ | mi_module iface /= mod_name ->
+ return (Failed (wrongIfaceModErr iface mod_name file_path))
+ | otherwise ->
+ returnM (Succeeded (iface{mi_package=pkg}, file_path))
+ -- Don't forget to fill in the package name...
+ }}}
+
+findHiFile :: HscEnv -> Bool -> Module -> IsBootInterface
+ -> IO (MaybeErr FindResult (FilePath, PackageIdH))
+findHiFile hsc_env explicit 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.
+ let { home_allowed = isOneShot (ghcMode (hsc_dflags hsc_env)) } ;
+ maybe_found <- if home_allowed
+ then findModule hsc_env mod_name explicit
+ else findPackageModule hsc_env mod_name explicit;
+
+ case maybe_found of
+ Found loc pkg -> return (Succeeded (path, pkg))
+ where
+ path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc)
+
+ err -> return (Failed err)
+ }
+\end{code}
+
+@readIface@ tries just the one file.
+
+\begin{code}
+readIface :: Module -> String -> IsBootInterface
+ -> TcRnIf gbl lcl (MaybeErr Message ModIface)
+ -- Failed err <=> file not found, or unreadable, or illegible
+ -- Succeeded iface <=> successfully found and parsed
+
+readIface wanted_mod file_path is_hi_boot_file
+ = do { dflags <- getDOpts
+ ; ioToIOEnv $ do
+ { res <- tryMost (readBinIface file_path)
+ ; case res of
+ Right iface
+ | wanted_mod == actual_mod -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
+ where
+ actual_mod = mi_module iface
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
+
+ Left exn -> return (Failed (text (showException exn)))
+ }}
+\end{code}
+
+
+%*********************************************************
+%* *
+ Wired-in interface for GHC.Prim
+%* *
+%*********************************************************
+
+\begin{code}
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+ = EPS {
+ eps_is_boot = emptyModuleEnv,
+ eps_PIT = emptyPackageIfaceTable,
+ eps_PTE = emptyTypeEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_rule_base = mkRuleBase builtinRules,
+ -- Initialise the EPS rule pool with the built-in rules
+ eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
+ , n_insts_in = 0, n_insts_out = 0
+ , n_rules_in = length builtinRules, n_rules_out = 0 }
+ }
+\end{code}
+
+
+%*********************************************************
+%* *
+ Wired-in interface for GHC.Prim
+%* *
+%*********************************************************
+
+\begin{code}
+ghcPrimIface :: ModIface
+ghcPrimIface
+ = (emptyModIface HomePackage gHC_PRIM) {
+ mi_exports = [(gHC_PRIM, 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: ", msg]
+ where
+ stats = eps_stats eps
+ msg = vcat
+ [int (n_ifaces_in stats) <+> text "interfaces read",
+ hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+ int (n_decls_in stats), text "read"],
+ hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+ int (n_insts_in stats), text "read"],
+ hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+ int (n_rules_in stats), text "read"]
+ ]
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Errors}
+%* *
+%*********************************************************
+
+\begin{code}
+badIfaceFile file err
+ = vcat [ptext SLIT("Bad interface file:") <+> text file,
+ nest 4 err]
+
+hiModuleNameMismatchWarn :: Module -> Module -> 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
+ ]
+
+wrongIfaceModErr iface mod_name file_path
+ = sep [ptext SLIT("Interface file") <+> iface_file,
+ ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma,
+ ptext SLIT("but we were expecting module") <+> quotes (ppr mod_name),
+ sep [ptext SLIT("Probable cause: the source code which generated"),
+ nest 2 iface_file,
+ ptext SLIT("has an incompatible module name")
+ ]
+ ]
+ where iface_file = doubleQuotes (text file_path)
+\end{code}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
new file mode 100644
index 0000000000..cafb6b6692
--- /dev/null
+++ b/compiler/iface/MkIface.lhs
@@ -0,0 +1,1066 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+
+\begin{code}
+module MkIface (
+ pprModIface, 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
+
+ writeIfaceFile, -- Write the interface file
+
+ 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 Packages ( isHomeModule, PackageIdH(..) )
+import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
+ IfaceRule(..), IfaceInst(..), IfaceExtName(..),
+ eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
+ eqMaybeBy, eqListBy, visibleIfConDecls,
+ tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule )
+import LoadIface ( readIface, loadInterface )
+import BasicTypes ( Version, initialVersion, bumpVersion )
+import TcRnMonad
+import HscTypes ( ModIface(..), ModDetails(..),
+ ModGuts(..), IfaceExport,
+ HscEnv(..), hscEPS, Dependencies(..), FixItem(..),
+ ModSummary(..), msHiFilePath,
+ mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
+ typeEnvElts,
+ GenAvailInfo(..), availName,
+ ExternalPackageState(..),
+ Usage(..), IsBootInterface,
+ Deprecs(..), IfaceDeprecs, Deprecations,
+ lookupIfaceByModule
+ )
+
+
+import Packages ( HomeModules )
+import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt )
+import StaticFlags ( opt_HiVersion )
+import Name ( Name, nameModule, nameOccName, nameParent,
+ isExternalName, isInternalName, nameParent_maybe, isWiredInName,
+ isImplicitName, NamedThing(..) )
+import NameEnv
+import NameSet
+import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv,
+ extendOccEnv_C,
+ OccSet, emptyOccSet, elemOccSet, occSetElts,
+ extendOccSet, extendOccSetList,
+ isEmptyOccSet, intersectOccSet, intersectsOccSet,
+ occNameFS, isTcOcc )
+import Module ( Module, moduleFS,
+ ModLocation(..), mkModuleFS, moduleString,
+ ModuleEnv, emptyModuleEnv, lookupModuleEnv,
+ extendModuleEnv_C
+ )
+import Outputable
+import Util ( createDirectoryHierarchy, directoryOf )
+import Util ( sortLe, seqList )
+import Binary ( getBinFileWithDict )
+import BinIface ( writeBinIface, v_IgnoreHiWay )
+import Unique ( Unique, Uniquable(..) )
+import ErrUtils ( dumpIfSet_dyn, showPass )
+import Digraph ( stronglyConnComp, SCC(..) )
+import SrcLoc ( SrcSpan )
+import FiniteMap
+import FastString
+
+import DATA_IOREF ( writeIORef )
+import Monad ( when )
+import List ( insert )
+import Maybes ( orElse, mapCatMaybes, isNothing, isJust,
+ expectJust, MaybeErr(..) )
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Completing an interface}
+%* *
+%************************************************************************
+
+\begin{code}
+mkIface :: HscEnv
+ -> Maybe ModIface -- The old interface, if we have it
+ -> ModGuts -- Usages, deprecations, etc
+ -> ModDetails -- The trimmed, tidied interface
+ -> IO (ModIface, -- The new one, complete with decls and versions
+ Bool) -- True <=> there was an old Iface, and the new one
+ -- is identical, so no need to write it
+
+mkIface hsc_env maybe_old_iface
+ (ModGuts{ mg_module = this_mod,
+ mg_boot = is_boot,
+ mg_usages = usages,
+ mg_deps = deps,
+ mg_home_mods = home_mods,
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = src_deprecs })
+ (ModDetails{ md_insts = insts,
+ md_rules = rules,
+ md_types = type_env,
+ md_exports = exports })
+
+-- NB: notice that mkIface does not look at the bindings
+-- only at the TypeEnv. The previous Tidy phase has
+-- put exactly the info into the TypeEnv that we want
+-- to expose in the interface
+
+ = do { eps <- hscEPS hsc_env
+ ; let { ext_nm_rhs = mkExtNameFn hsc_env home_mods eps this_mod
+ ; ext_nm_lhs = mkLhsNameFn this_mod
+
+ ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing
+ | thing <- typeEnvElts type_env,
+ not (isImplicitName (getName thing)) ]
+ -- Don't put implicit Ids and class tycons in the interface file
+
+ ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
+ ; deprecs = mkIfaceDeprec src_deprecs
+ ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
+ ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+
+ ; intermediate_iface = ModIface {
+ mi_module = this_mod,
+ mi_package = HomePackage,
+ mi_boot = is_boot,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = mkIfaceExports exports,
+ mi_insts = sortLe le_inst iface_insts,
+ mi_rules = sortLe le_rule iface_rules,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+ mi_globals = Just rdr_env,
+
+ -- 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, pp_orphs)
+ = _scc_ "versioninfo"
+ addVersionInfo maybe_old_iface intermediate_iface decls
+ }
+
+ -- Debug printing
+ ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags)
+ (printDump (expectJust "mkIface" pp_orphs))
+ ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
+ ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+ (pprModIface new_iface)
+
+ ; return (new_iface, no_change_at_all) }
+ where
+ r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
+ i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
+
+ dflags = hsc_dflags hsc_env
+ deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
+
+-----------------------------
+writeIfaceFile :: ModLocation -> ModIface -> IO ()
+writeIfaceFile location new_iface
+ = do createDirectoryHierarchy (directoryOf hi_file_path)
+ writeBinIface hi_file_path new_iface
+ where hi_file_path = ml_hi_file location
+
+
+-----------------------------
+mkExtNameFn :: HscEnv -> HomeModules -> ExternalPackageState -> Module -> Name -> IfaceExtName
+mkExtNameFn hsc_env hmods eps this_mod
+ = ext_nm
+ where
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+
+ ext_nm name
+ | mod == this_mod = case nameParent_maybe name of
+ Nothing -> LocalTop occ
+ Just par -> LocalTopSub occ (nameOccName par)
+ | isWiredInName name = ExtPkg mod occ
+ | isHomeModule hmods mod = HomePkg mod occ vers
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
+ par_occ = nameOccName (nameParent name)
+ -- The version of the *parent* is the one want
+ vers = lookupVersion mod par_occ
+
+ lookupVersion :: Module -> 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 = lookupIfaceByModule hpt pit mod `orElse`
+ pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+
+
+---------------------
+-- mkLhsNameFn ignores versioning info altogether
+-- It is used for the LHS of instance decls and rules, where we
+-- there's no point in recording version info
+mkLhsNameFn :: Module -> Name -> IfaceExtName
+mkLhsNameFn this_mod name
+ | isInternalName name = pprTrace "mkLhsNameFn: unexpected internal" (ppr name) $
+ LocalTop occ -- Should not happen
+ | mod == this_mod = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
+
+
+-----------------------------
+-- 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
+ Maybe SDoc) -- Warnings about orphans
+
+addVersionInfo Nothing new_iface new_decls
+-- No old interface, so definitely write a new one!
+ = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface)
+ || anyNothing ifRuleOrph (mi_rules new_iface),
+ mi_decls = [(initialVersion, decl) | decl <- new_decls],
+ mi_ver_fn = \n -> Just initialVersion },
+ False,
+ ptext SLIT("No old interface file"),
+ pprOrphans orph_insts orph_rules)
+ where
+ orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
+ orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface)
+
+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, ptext SLIT("Interface file unchanged"), pp_orphs)
+ | otherwise = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
+ nest 2 pp_diffs], pp_orphs)
+ 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]
+
+ -------------------
+ (old_non_orph_insts, old_orph_insts) = mkOrphMap ifInstOrph (mi_insts old_iface)
+ (new_non_orph_insts, new_orph_insts) = mkOrphMap ifInstOrph (mi_insts new_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) = mkOrphMap ifRuleOrph (mi_rules old_iface)
+ (new_non_orph_rules, new_orph_rules) = mkOrphMap ifRuleOrph (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
+ no_other_changes = mi_usages new_iface == mi_usages old_iface &&
+ mi_deps new_iface == mi_deps old_iface
+ no_change_at_all = no_output_change && no_other_changes
+
+ pp_diffs = vcat [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_decl_diffs]
+ 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 (map ifConOcc (visibleIfConDecls 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)
+
+ pp_orphs = pprOrphans new_orph_insts new_orph_rules
+
+pprOrphans insts rules
+ | null insts && null rules = Nothing
+ | otherwise
+ = Just $ vcat [
+ if null insts then empty else
+ hang (ptext SLIT("Warning: orphan instances:"))
+ 2 (vcat (map ppr insts)),
+ if null rules then empty else
+ hang (ptext SLIT("Warning: orphan rules:"))
+ 2 (vcat (map ppr rules))
+ ]
+
+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
+
+----------------------
+-- mkOrphMap 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
+mkOrphMap :: (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
+mkOrphMap 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)
+
+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 (sortLe (<=) (nameEnvElts env))
+
+----------------------
+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
+ -> HomeModules
+ -> ModuleEnv (Module, Bool, SrcSpan)
+ -> [(Module, IsBootInterface)]
+ -> NameSet -> IO [Usage]
+mkUsageInfo hsc_env hmods dir_imp_mods dep_mods used_names
+ = do { eps <- hscEPS hsc_env
+ ; let usages = mk_usage_info (eps_PIT eps) hsc_env hmods
+ dir_imp_mods dep_mods used_names
+ ; usages `seqList` return usages }
+ -- 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.
+
+mk_usage_info pit hsc_env hmods dir_imp_mods dep_mods proto_used_names
+ = mapCatMaybes mkUsage dep_mods
+ -- ToDo: do we need to sort into canonical order?
+ where
+ hpt = hsc_HPT hsc_env
+
+ 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
+
+ depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of
+ Just (_,no_imp,_) -> not no_imp
+ Nothing -> True
+
+ -- 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 :: (Module, Bool) -> Maybe Usage
+ mkUsage (mod_name, _)
+ | isNothing maybe_iface -- We can't depend on it if we didn't
+ || not (isHomeModule hmods mod) -- even open the interface!
+ || (null used_occs
+ && isNothing export_vers
+ && not orphan_mod)
+ = Nothing -- Record no usage info
+
+ | otherwise
+ = Just (Usage { usg_name = mod,
+ usg_mod = mod_vers,
+ usg_exports = export_vers,
+ usg_entities = ent_vers,
+ usg_rules = rules_vers })
+ where
+ maybe_iface = lookupIfaceByModule 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
+ export_vers | depend_on_exports mod = 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 <- sortLe (<=) used_occs]
+\end{code}
+
+\begin{code}
+mkIfaceExports :: NameSet -> [(Module, [GenAvailInfo OccName])]
+ -- Group by module and sort by occurrence
+ -- This keeps the list in canonical order
+mkIfaceExports exports
+ = [ (mkModuleFS fs, eltsFM avails)
+ | (fs, avails) <- fmToList groupFM
+ ]
+ where
+ groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName))
+ -- Deliberately use the FastString so we
+ -- get a canonical ordering
+ groupFM = foldl add emptyFM (nameSetToList exports)
+
+ add env name = addToFM_C add_avail env mod_fs
+ (unitFM avail_fs avail)
+ where
+ occ = nameOccName name
+ mod_fs = moduleFS (nameModule name)
+ avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
+ | isTcOcc occ = AvailTC occ [occ]
+ | otherwise = Avail occ
+ avail_fs = occNameFS (availName avail)
+ add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail
+
+ add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs)
+ add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name)
+\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
+ -> ModSummary
+ -> Bool -- Source unchanged
+ -> Maybe ModIface -- Old interface from compilation manager, if any
+ -> IO (RecompileRequired, Maybe ModIface)
+
+checkOldIface hsc_env mod_summary source_unchanged maybe_iface
+ = do { showPass (hsc_dflags hsc_env)
+ ("Checking old interface for " ++ moduleString (ms_mod mod_summary)) ;
+
+ ; initIfaceCheck hsc_env $
+ check_old_iface mod_summary source_unchanged maybe_iface
+ }
+
+check_old_iface mod_summary 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.
+ getGhcMode `thenM` \ ghc_mode ->
+ if (ghc_mode == Interactive || ghc_mode == JustTypecheck)
+ && 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
+ let
+ iface_path = msHiFilePath mod_summary
+ in
+ readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result ->
+ case read_result of {
+ Failed err -> -- Old interface file not found, or garbled; give up
+ traceIf (text "FYI: cannot read old interface file:"
+ $$ nest 4 err) `thenM_`
+ returnM (outOfDate, Nothing)
+
+ ; Succeeded 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
+ = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon)
+
+ -- Source code unchanged and no errors yet... carry on
+
+ -- First put the dependent-module info, read from the old interface, into the envt,
+ -- 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).
+ --
+ -- We do this regardless of compilation mode
+ ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
+
+ ; checkList [checkModUsage u | u <- mi_usages iface]
+ }
+ where
+ -- This is a bit of a hack really
+ mod_deps :: ModuleEnv (Module, 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 {
+ Failed 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
+
+ Succeeded 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"))
+ (expectJust "checkModUsage" 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 ()
+-- Read 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_IgnoreHiWay 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")
+ <+> ppr_package (mi_package iface)
+ <+> ppr (mi_module iface) <+> pp_boot
+ <+> ppr (mi_mod_vers iface) <+> pp_sub_vers
+ <+> (if mi_orphan iface then ptext SLIT("[orphan module]") 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
+ pp_boot | mi_boot iface = ptext SLIT("[boot]")
+ | otherwise = empty
+ ppr_package HomePackage = empty
+ ppr_package (ExtPackage id) = doubleQuotes (ppr id)
+
+ 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}
diff --git a/compiler/iface/TcIface.hi-boot-5 b/compiler/iface/TcIface.hi-boot-5
new file mode 100644
index 0000000000..3647edfa22
--- /dev/null
+++ b/compiler/iface/TcIface.hi-boot-5
@@ -0,0 +1,5 @@
+__interface TcIface 1 0 where
+__export TcIface tcImportDecl ;
+1 tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing ;
+
+
diff --git a/compiler/iface/TcIface.hi-boot-6 b/compiler/iface/TcIface.hi-boot-6
new file mode 100644
index 0000000000..b03830c03d
--- /dev/null
+++ b/compiler/iface/TcIface.hi-boot-6
@@ -0,0 +1,7 @@
+module TcIface where
+
+tcIfaceDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing
+tcIfaceInst :: IfaceSyn.IfaceInst -> TcRnTypes.IfL InstEnv.Instance
+tcIfaceRule :: IfaceSyn.IfaceRule -> TcRnTypes.IfL CoreSyn.CoreRule
+
+
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
new file mode 100644
index 0000000000..b902c8c5fe
--- /dev/null
+++ b/compiler/iface/TcIface.lhs
@@ -0,0 +1,977 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[TcIfaceSig]{Type checking of type signatures in interface files}
+
+\begin{code}
+module TcIface (
+ tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
+ tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal,
+ tcExtCoreBindings
+ ) where
+
+#include "HsVersions.h"
+
+import IfaceSyn
+import LoadIface ( loadInterface, loadWiredInHomeIface,
+ loadDecls, findAndReadIface )
+import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
+ extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
+ tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv,
+ newIfaceName, newIfaceNames, ifaceExportNames )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
+ mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import TcRnMonad
+import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
+ mkTyVarTys, ThetaType )
+import TypeRep ( Type(..), PredType(..) )
+import TyCon ( TyCon, tyConName )
+import HscTypes ( ExternalPackageState(..),
+ TyThing(..), tyThingClass, tyThingTyCon,
+ ModIface(..), ModDetails(..), HomeModInfo(..),
+ emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+import InstEnv ( Instance(..), mkImportedInstance )
+import Unify ( coreRefineTys )
+import CoreSyn
+import CoreUtils ( exprType )
+import CoreUnfold
+import CoreLint ( lintUnfolding )
+import WorkWrap ( mkWrapper )
+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 ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
+import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
+import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
+import Var ( TyVar, mkTyVar, tyVarKind )
+import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
+ wiredInNameTyThing_maybe, nameParent )
+import NameEnv
+import OccName ( OccName )
+import Module ( Module, lookupModuleEnv )
+import UniqSupply ( initUs_ )
+import Outputable
+import ErrUtils ( Message )
+import Maybes ( MaybeErr(..) )
+import SrcLoc ( noSrcLoc )
+import Util ( zipWithEqual, dropList, equalLength )
+import DynFlags ( DynFlag(..), isOneShot )
+\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 -> TcM TyThing
+-- Entry point for *source-code* uses of importDecl
+tcImportDecl name
+ | Just thing <- wiredInNameTyThing_maybe name
+ = do { initIfaceTcRn (loadWiredInHomeIface name)
+ ; return thing }
+ | otherwise
+ = do { traceIf (text "tcImportDecl" <+> ppr name)
+ ; mb_thing <- initIfaceTcRn (importDecl name)
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed err -> failWithTc err }
+
+checkWiredInTyCon :: TyCon -> TcM ()
+-- Ensure that the home module of the TyCon (and hence its instances)
+-- are loaded. It might not be a wired-in tycon (see the calls in TcUnify),
+-- in which case this is a no-op.
+checkWiredInTyCon tc
+ | not (isWiredInName tc_name)
+ = return ()
+ | otherwise
+ = do { mod <- getModule
+ ; if nameIsLocalOrFrom mod tc_name then
+ -- Don't look for (non-existent) Float.hi when
+ -- compiling Float.lhs, which mentions Float of course
+ return ()
+ else -- A bit yukky to call initIfaceTcRn here
+ initIfaceTcRn (loadWiredInHomeIface tc_name)
+ }
+ where
+ tc_name = tyConName tc
+
+importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
+-- Get the TyThing for this Name from an interface file
+-- It's not a wired-in thing -- the caller caught that
+importDecl name
+ = ASSERT( not (isWiredInName name) )
+ do { traceIf nd_doc
+
+ -- Load the interface, which should populate the PTE
+ ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+ ; case mb_iface of {
+ Failed err_msg -> return (Failed err_msg) ;
+ Succeeded iface -> do
+
+ -- Now look it up again; this time we should find it
+ { eps <- getEps
+ ; case lookupTypeEnv (eps_PTE eps) name of
+ Just thing -> return (Succeeded thing)
+ Nothing -> return (Failed not_found_msg)
+ }}}
+ where
+ nd_doc = ptext SLIT("Need decl for") <+> ppr name
+ not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
+\end{code}
+
+%************************************************************************
+%* *
+ Type-checking a complete interface
+%* *
+%************************************************************************
+
+Suppose we discover we don't need to recompile. Then we must type
+check the old interface file. This is a bit different to the
+incremental type checking we do as we suck in interface files. Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot. Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
+\begin{code}
+typecheckIface :: ModIface -- Get the decls from here
+ -> TcRnIf gbl lcl ModDetails
+typecheckIface iface
+ = initIfaceTc iface $ \ tc_env_var -> do
+ -- The tc_env_var is freshly allocated, private to
+ -- type-checking this particular interface
+ { -- Get the right set of decls and rules. If we are compiling without -O
+ -- we discard pragmas before typechecking, so that we don't "see"
+ -- information that we shouldn't. From a versioning point of view
+ -- It's not actually *wrong* to do so, but in fact GHCi is unable
+ -- to handle unboxed tuples, so it must not see unfoldings.
+ ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+
+ -- Load & typecheck the decls
+ ; decl_things <- loadDecls ignore_prags (mi_decls iface)
+
+ ; let type_env = mkNameEnv decl_things
+ ; writeMutVar tc_env_var type_env
+
+ -- Now do those rules and instances
+ ; let { rules | ignore_prags = []
+ | otherwise = mi_rules iface
+ ; dfuns = mi_insts iface
+ }
+ ; dfuns <- mapM tcIfaceInst dfuns
+ ; rules <- mapM tcIfaceRule rules
+
+ -- Exports
+ ; exports <- ifaceExportNames (mi_exports iface)
+
+ -- Finished
+ ; return (ModDetails { md_types = type_env,
+ md_insts = dfuns,
+ md_rules = rules,
+ md_exports = exports })
+ }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type and class declarations
+%* *
+%************************************************************************
+
+\begin{code}
+tcHiBootIface :: Module -> TcRn ModDetails
+-- Load the hi-boot iface for the module being compiled,
+-- if it indeed exists in the transitive closure of imports
+-- Return the ModDetails, empty if no hi-boot iface
+tcHiBootIface mod
+ = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
+
+ ; mode <- getGhcMode
+ ; if not (isOneShot mode)
+ -- In --make and interactive mode, if this module has an hs-boot file
+ -- we'll have compiled it already, and it'll be in the HPT
+ --
+ -- We check wheher the interface is a *boot* interface.
+ -- It can happen (when using GHC from Visual Studio) that we
+ -- compile a module in TypecheckOnly mode, with a stable,
+ -- fully-populated HPT. In that case the boot interface isn't there
+ -- (it's been replaced by the mother module) so we can't check it.
+ -- And that's fine, because if M's ModInfo is in the HPT, then
+ -- it's been compiled once, and we don't need to check the boot iface
+ then do { hpt <- getHpt
+ ; case lookupModuleEnv hpt mod of
+ Just info | mi_boot (hm_iface info)
+ -> return (hm_details info)
+ other -> return emptyModDetails }
+ else do
+
+ -- OK, so we're in one-shot mode.
+ -- In that case, we're read all the direct imports by now,
+ -- so eps_is_boot will record if any of our imports mention us by
+ -- way of hi-boot file
+ { eps <- getEps
+ ; case lookupModuleEnv (eps_is_boot eps) mod of {
+ Nothing -> return emptyModDetails ; -- The typical case
+
+ Just (_, False) -> failWithTc moduleLoop ;
+ -- Someone below us imported us!
+ -- This is a loop with no hi-boot in the way
+
+ Just (mod, True) -> -- There's a hi-boot interface below us
+
+ do { read_result <- findAndReadIface
+ True -- Explicit import?
+ need mod
+ True -- Hi-boot file
+
+ ; case read_result of
+ Failed err -> failWithTc (elaborate err)
+ Succeeded (iface, _path) -> typecheckIface iface
+ }}}}
+ where
+ need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
+ <+> ptext SLIT("to compare against the Real Thing")
+
+ moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
+ <+> ptext SLIT("depends on itself")
+
+ elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+>
+ quotes (ppr mod) <> colon) 4 err
+\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 {ifName = occ_name,
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt,
+ ifCons = rdr_cons,
+ ifVrcs = arg_vrcs, ifRec = is_rec,
+ ifGeneric = want_generic })
+ = do { tc_name <- lookupIfaceTop occ_name
+ ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+
+ { tycon <- fixM ( \ tycon -> do
+ { stupid_theta <- tcIfaceCtxt ctxt
+ ; cons <- tcIfaceDataCons tycon tyvars rdr_cons
+ ; buildAlgTyCon tc_name tyvars stupid_theta
+ cons arg_vrcs is_rec want_generic
+ })
+ ; 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 tc_tyvars if_cons
+ = case if_cons of
+ IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; return (mkNewTyConRhs tycon data_con) }
+ where
+ tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
+ ifConStricts = stricts, ifConFields = field_lbls})
+ = do { name <- lookupIfaceTop occ
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; buildDataCon name is_infix True {- Vanilla -}
+ stricts lbl_names
+ tc_tyvars [] arg_tys tycon
+ (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
+ }
+
+ tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt,
+ ifConArgTys = args, ifConResTys = ress,
+ ifConStricts = stricts})
+ = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
+ { name <- lookupIfaceTop occ
+ ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
+ -- At one stage I thought that this context checking *had*
+ -- to be lazy, because of possible mutual recursion between the
+ -- type and the classe:
+ -- E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- But now I think that the laziness in checking class ops breaks
+ -- the loop, so no laziness needed
+
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
+
+ ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
+ stricts [{- No fields -}]
+ con_tyvars theta
+ arg_tys tycon res_tys
+ }
+ mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
+\end{code}
+
+
+%************************************************************************
+%* *
+ Instances
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceInst :: IfaceInst -> IfL Instance
+tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
+ ifInstCls = cls, ifInstTys = mb_tcs,
+ ifInstOrph = orph })
+ = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
+ tcIfaceExtId (LocalTop dfun_occ)
+ ; cls' <- lookupIfaceExt cls
+ ; mb_tcs' <- mapM do_tc mb_tcs
+ ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) }
+ where
+ do_tc Nothing = return Nothing
+ do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
+\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}
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+ ifRuleOrph = orph })
+ = do { fn' <- lookupIfaceExt fn
+ ; ~(bndrs', args', rhs') <-
+ -- Typecheck the payload lazily, in the hope it'll never be looked at
+ forkM (ptext SLIT("Rule") <+> ftext name) $
+ bindIfaceBndrs bndrs $ \ bndrs' ->
+ do { args' <- mappM tcIfaceExpr args
+ ; rhs' <- tcIfaceExpr rhs
+ ; return (bndrs', args', rhs') }
+ ; mb_tcs <- mapM ifTopFreeName args
+ ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act,
+ ru_bndrs = bndrs', ru_args = args',
+ ru_rhs = rhs', ru_orph = orph,
+ ru_rough = mb_tcs,
+ ru_local = isLocalIfaceExtName fn }) }
+ where
+ -- This function *must* mirror exactly what Rules.topFreeName does
+ -- We could have stored the ru_rough field in the iface file
+ -- but that would be redundant, I think.
+ -- The only wrinkle is that we must not be deceived by
+ -- type syononyms at the top of a type arg. Since
+ -- we can't tell at this point, we are careful not
+ -- to write them out in coreRuleToIfaceRule
+ ifTopFreeName :: IfaceExpr -> IfL (Maybe Name)
+ ifTopFreeName (IfaceType (IfaceTyConApp tc _ ))
+ = do { n <- lookupIfaceTc tc
+ ; return (Just n) }
+ ifTopFreeName (IfaceApp f a) = ifTopFreeName f
+ ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext
+ ; return (Just n) }
+ ifTopFreeName other = return Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ Types
+%* *
+%************************************************************************
+
+\begin{code}
+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 (mkTyConApp 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 ty 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' ->
+ tcIfaceType ty `thenM` \ ty' ->
+ returnM (Case scrut' case_bndr' ty' 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)
+ = do { let tycon_mod = nameModule (tyConName tycon)
+ ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
+ ; ASSERT2( con `elem` tyConDataCons tycon,
+ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
+
+ if isVanillaDataCon con then
+ tcVanillaAlt con inst_tys arg_occs rhs
+ else
+ do { -- General case
+ arg_names <- newIfaceNames arg_occs
+ ; let tyvars = [ mkTyVar name (tyVarKind tv)
+ | (name,tv) <- arg_names `zip` dataConTyVars con]
+ arg_tys = dataConInstArgTys con (mkTyVarTys tyvars)
+ id_names = dropList tyvars arg_names
+ arg_ids = ASSERT2( equalLength id_names arg_tys,
+ ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
+ zipWith mkLocalId id_names arg_tys
+
+ Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys)
+
+ ; rhs' <- extendIfaceTyVarEnv tyvars $
+ extendIfaceIdEnv arg_ids $
+ refineIfaceIdEnv refine $
+ -- You might think that we don't need to refine the envt here,
+ -- but we do: \(x::a) -> case y of
+ -- MkT -> case x of { True -> ... }
+ -- In the "case x" we need to know x's type, because we use that
+ -- to find which module to look for "True" in. Sigh.
+ tcIfaceExpr rhs
+ ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
+
+tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
+ = ASSERT( isTupleTyCon tycon )
+ do { let [data_con] = tyConDataCons tycon
+ ; tcVanillaAlt data_con inst_tys arg_occs rhs }
+
+tcVanillaAlt data_con inst_tys arg_occs rhs
+ = do { arg_names <- newIfaceNames arg_occs
+ ; let arg_tys = dataConInstArgTys data_con inst_tys
+ ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
+ ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
+ zipWith mkLocalId arg_names arg_tys
+ ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
+ ; returnM (DataAlt data_con, arg_ids, rhs') }
+\end{code}
+
+
+\begin{code}
+tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
+tcExtCoreBindings [] = return []
+tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
+
+do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
+do_one (IfaceNonRec bndr rhs) thing_inside
+ = do { rhs' <- tcIfaceExpr rhs
+ ; bndr' <- newExtCoreBndr bndr
+ ; extendIfaceIdEnv [bndr'] $ do
+ { core_binds <- thing_inside
+ ; return (NonRec bndr' rhs' : core_binds) }}
+
+do_one (IfaceRec pairs) thing_inside
+ = do { bndrs' <- mappM newExtCoreBndr 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 -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo name ty NoInfo = return vanillaIdInfo
+tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info 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 arity
+ = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+
+ -- 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
+ 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)
+\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 (
+ get_in_scope_ids `thenM` \ in_scope ->
+ 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
+ get_in_scope_ids -- Urgh; but just for linting
+ = setLclEnv () $
+ do { env <- getGblEnv
+ ; case if_rec_types env of {
+ Nothing -> return [] ;
+ Just (_, get_env) -> do
+ { type_env <- get_env
+ ; return (typeEnvIds type_env) }}}
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Getting from Names to TyThings
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceGlobal :: Name -> IfL TyThing
+tcIfaceGlobal name
+ | Just thing <- wiredInNameTyThing_maybe name
+ -- Wired-in things include TyCons, DataCons, and Ids
+ = do { loadWiredInHomeIface name; return thing }
+ -- Even though we are in an interface file, we want to make
+ -- sure its instances are loaded (imagine f :: Double -> Double)
+ -- and its RULES are loaded too
+ | otherwise
+ = do { (eps,hpt) <- getEpsAndHpt
+ ; case lookupType hpt (eps_PTE eps) name of {
+ Just thing -> return thing ;
+ Nothing -> 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 <- setLclEnv () get_type_env -- yuk
+ ; case lookupNameEnv type_env name of
+ Just thing -> return thing
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ (ppr name $$ ppr type_env) }
+
+ ; other -> do
+
+ { mb_thing <- importDecl name -- It's imported; go get it
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
+ }}}}}
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
+tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon
+tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon
+tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
+tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
+tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
+ ; thing <- tcIfaceGlobal name
+ ; return (check_tc (tyThingTyCon thing)) }
+ where
+#ifdef DEBUG
+ check_tc tc = case toIfaceTyCon (error "urk") tc of
+ IfaceTc _ -> tc
+ other -> pprTrace "check_tc" (ppr tc) tc
+#else
+ check_tc tc = tc
+#endif
+
+-- Even though we are in an interface file, we want to make
+-- sure the instances and RULES of this tycon are loaded
+-- Imagine: f :: Double -> Double
+tcWiredInTyCon :: TyCon -> IfL TyCon
+tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc)
+ ; return tc }
+
+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) }
+\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 :: (OccName, IfaceType) -> IfL Id
+newExtCoreBndr (occ, ty)
+ = do { mod <- getIfModule
+ ; 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 kind
+\end{code}
+
diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
new file mode 100644
index 0000000000..25191fcaae
--- /dev/null
+++ b/compiler/iface/TcIface.lhs-boot
@@ -0,0 +1,13 @@
+\begin{code}
+module TcIface where
+import IfaceSyn ( IfaceDecl, IfaceInst, IfaceRule )
+import TypeRep ( TyThing )
+import TcRnTypes ( IfL )
+import InstEnv ( Instance )
+import CoreSyn ( CoreRule )
+
+tcIfaceDecl :: IfaceDecl -> IfL TyThing
+tcIfaceInst :: IfaceInst -> IfL Instance
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+\end{code}
+
View Lorry Controller Status