summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
authorSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
committerSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
commit0065d5ab628975892cea1ec7303f968c3338cbe1 (patch)
tree8e2afe0ab48ee33cf95009809d67c9649573ef92 /compiler/iface
parent28a464a75e14cece5db40f2765a29348273ff2d2 (diff)
downloadhaskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to Cabal, and with the move to darcs we can now flatten the source tree without losing history, so here goes. The main change is that the ghc/ subdir is gone, and most of what it contained is now at the top level. The build system now makes no pretense at being multi-project, it is just the GHC build system. No doubt this will break many things, and there will be a period of instability while we fix the dependencies. A straightforward build should work, but I haven't yet fixed binary/source distributions. Changes to the Building Guide will follow, too.
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