diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 50b36419585b8c29fdc4b25347b3ec24472c9ed5..605513e654cb08c4c7c970f1f0aa1c8414e67c06 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -248,8 +248,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
-- | Create a local 'Id' that is marked as exported.
-- This prevents things attached to it from being removed as dead code.
-mkExportedLocalId :: Name -> Type -> Id
-mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
+-- See Note [Exported LocalIds]
+mkExportedLocalId :: IdDetails -> Name -> Type -> Id
+mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
-- Note [Free type variables]
@@ -297,6 +298,40 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
\end{code}
+Note [Exported LocalIds]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We use mkExportedLocalId for things like
+ - Dictionary functions (DFunId)
+ - Wrapper and matcher Ids for pattern synonyms
+ - Default methods for classes
+ - etc
+
+They marked as "exported" in the sense that they should be kept alive
+even if apparently unused in other bindings, and not dropped as dead
+code by the occurrence analyser. (But "exported" here does not mean
+"brought into lexical scope by an import declaration". Indeed these
+things are always internal Ids that the user never sees.)
+
+It's very important that they are *LocalIds*, not GlobalIs, for lots
+of reasons:
+
+ * We want to treat them as free variables for the purpose of
+ dependency analysis (e.g. CoreFVs.exprFreeVars).
+
+ * Look them up in the current substitution when we come across
+ occurrences of them (in Subst.lookupIdSubst)
+
+ * Ensure that for dfuns that the specialiser does not float dict uses
+ above their defns, which would prevent good simplifications happening.
+
+ * The strictness analyser treats a occurrence of a GlobalId as
+ imported and assumes it contains strictness in its IdInfo, which
+ isn't true if the thing is bound in the same module as the
+ occurrence.
+
+In CoreTidy we must make all these LocalIds into GlobalIds, so that in
+importing modules (in --make mode) we treat them as properly global.
+That is what is happening in, say tidy_insts in TidyPgm.
%************************************************************************
%* *
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 38922fcd00703164c5ddd6ee1bebeb255a6169f4..457e33d5adc887d8beb07b6eb6c3c6e3ed5038a4 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -66,7 +66,6 @@ import PrimOp
import ForeignCall
import DataCon
import Id
-import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
@@ -956,29 +955,13 @@ mkFCallId dflags uniq fcall ty
%* *
%************************************************************************
-Important notes about dict funs and default methods
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Dict funs and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dict funs and default methods are *not* ImplicitIds. Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).
-We build them as LocalIds, but with External Names. This ensures that
-they are taken to account by free-variable finding and dependency
-analysis (e.g. CoreFVs.exprFreeVars).
-
-Why shouldn't they be bound as GlobalIds? Because, in particular, if
-they are globals, the specialiser floats dict uses above their defns,
-which prevents good simplifications happening. Also the strictness
-analyser treats a occurrence of a GlobalId as imported and assumes it
-contains strictness in its IdInfo, which isn't true if the thing is
-bound in the same module as the occurrence.
-
-It's OK for dfuns to be LocalIds, because we form the instance-env to
-pass on to the next module (md_insts) in CoreTidy, afer tidying
-and globalising the top-level Ids.
-
-BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
-that they aren't discarded by the occurrence analyser.
+NB: See also Note [Exported LocalIds] in Id
\begin{code}
mkDictFunId :: Name -- Name to use for the dict fun;
@@ -988,12 +971,12 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> [Type]
-> Id
-- Implements the DFun Superclass Invariant (see TcInstDcls)
+-- See Note [Dict funs and default methods]
mkDictFunId dfun_name tvs theta clas tys
- = mkExportedLocalVar (DFunId n_silent is_nt)
- dfun_name
- dfun_ty
- vanillaIdInfo
+ = mkExportedLocalId (DFunId n_silent is_nt)
+ dfun_name
+ dfun_ty
where
is_nt = isNewTyCon (classTyCon clas)
(n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index b3c85016ec515dcf8443cbb72f96bdee61e6d58f..32908f6c6d35a8434a8a93c1b0d77f9b5287238a 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -11,16 +11,18 @@ module PatSyn (
PatSyn, mkPatSyn,
-- ** Type deconstruction
- patSynId, patSynType, patSynArity, patSynIsInfix,
- patSynArgs, patSynTyDetails,
+ patSynName, patSynArity, patSynIsInfix,
+ patSynArgs, patSynTyDetails, patSynType,
patSynWrapper, patSynMatcher,
- patSynExTyVars, patSynSig,
- patSynInstArgTys, patSynInstResTy
+ patSynExTyVars, patSynSig,
+ patSynInstArgTys, patSynInstResTy,
+ tidyPatSynIds, patSynIds
) where
#include "HsVersions.h"
import Type
+import TcType( mkSigmaTy )
import Name
import Outputable
import Unique
@@ -28,8 +30,6 @@ import Util
import BasicTypes
import FastString
import Var
-import Id
-import TcType
import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
@@ -114,7 +114,7 @@ expression when available.
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
- psId :: Id,
+ psName :: Name,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
@@ -167,7 +167,7 @@ instance Uniquable PatSyn where
getUnique = psUnique
instance NamedThing PatSyn where
- getName = getName . psId
+ getName = patSynName
instance Outputable PatSyn where
ppr = ppr . getName
@@ -208,7 +208,7 @@ mkPatSyn name declared_infix orig_args
prov_theta req_theta
orig_res_ty
matcher wrapper
- = MkPatSyn {psId = id, psUnique = getUnique name,
+ = MkPatSyn {psName = name, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psProvTheta = prov_theta, psReqTheta = req_theta,
psInfix = declared_infix,
@@ -217,20 +217,21 @@ mkPatSyn name declared_infix orig_args
psOrigResTy = orig_res_ty,
psMatcher = matcher,
psWrapper = wrapper }
- where
- pat_ty = mkSigmaTy univ_tvs req_theta $
- mkSigmaTy ex_tvs prov_theta $
- mkFunTys orig_args orig_res_ty
- id = mkLocalId name pat_ty
\end{code}
\begin{code}
-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
-patSynId :: PatSyn -> Id
-patSynId = psId
+patSynName :: PatSyn -> Name
+patSynName = psName
patSynType :: PatSyn -> Type
-patSynType = psOrigResTy
+-- The full pattern type, used only in error messages
+patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
+ , psExTyVars = ex_tvs, psProvTheta = prov_theta
+ , psArgs = orig_args, psOrigResTy = orig_res_ty })
+ = mkSigmaTy univ_tvs req_theta $
+ mkSigmaTy ex_tvs prov_theta $
+ mkFunTys orig_args orig_res_ty
-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
@@ -244,17 +245,20 @@ patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs
patSynTyDetails :: PatSyn -> HsPatSynDetails Type
-patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
- (True, [left, right]) -> InfixPatSyn left right
- (_, tys) -> PrefixPatSyn tys
+patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
+ | is_infix, [left,right] <- arg_tys
+ = InfixPatSyn left right
+ | otherwise
+ = PrefixPatSyn arg_tys
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
-patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
+patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
- , psProvTheta = prov, psReqTheta = req })
- = (univ_tvs, ex_tvs, prov, req)
+ , psProvTheta = prov, psReqTheta = req
+ , psArgs = arg_tys, psOrigResTy = res_ty })
+ = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = psWrapper
@@ -262,6 +266,16 @@ patSynWrapper = psWrapper
patSynMatcher :: PatSyn -> Id
patSynMatcher = psMatcher
+patSynIds :: PatSyn -> [Id]
+patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
+ = case mb_wrap_id of
+ Nothing -> [match_id]
+ Just wrap_id -> [match_id, wrap_id]
+
+tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
+tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
+ = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
+
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
-- Return the types of the argument patterns
-- e.g. data D a = forall b. MkD a b (b->a)
@@ -270,12 +284,13 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
-- NB: the inst_tys should be both universal and existential
-patSynInstArgTys ps inst_tys
+patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
+ , psExTyVars = ex_tvs, psArgs = arg_tys })
+ inst_tys
= ASSERT2( length tyvars == length inst_tys
- , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
- map (substTyWith tyvars inst_tys) (psArgs ps)
+ , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
+ map (substTyWith tyvars inst_tys) arg_tys
where
- (univ_tvs, ex_tvs, _, _) = patSynSig ps
tyvars = univ_tvs ++ ex_tvs
patSynInstResTy :: PatSyn -> [Type] -> Type
@@ -284,10 +299,10 @@ patSynInstResTy :: PatSyn -> [Type] -> Type
-- P :: a -> b -> Just (a,a,b)
-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
-patSynInstResTy ps inst_tys
+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
+ , psOrigResTy = res_ty })
+ inst_tys
= ASSERT2( length univ_tvs == length inst_tys
- , ptext (sLit "patSynInstResTy") <+> ppr ps $$ ppr univ_tvs $$ ppr inst_tys )
- substTyWith univ_tvs inst_tys (psOrigResTy ps)
- where
- (univ_tvs, _, _, _) = patSynSig ps
+ , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
+ substTyWith univ_tvs inst_tys res_ty
\end{code}
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e13767ff59eb4bfc1942c8b0aa0a273fe9214e95..7afd601a3d7b8f9464cbea985b9803749b182e58 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -46,8 +46,6 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
-import Data.Maybe ( mapMaybe )
-import UniqFM
\end{code}
%************************************************************************
@@ -119,27 +117,20 @@ deSugar hsc_env
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
- ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
- , ds_fords `appendStubC` hpc_init
- , patsyn_defs) }
+ , ds_fords `appendStubC` hpc_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
- = partition isLocalRule all_rules
- final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
- exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
- exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
- keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
- final_prs = addExportFlagsAndRules target
- export_set keep_alive' rules_for_locals (fromOL all_prs)
+ ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+ final_prs = addExportFlagsAndRules target export_set keep_alive
+ rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -183,7 +174,7 @@ deSugar hsc_env
mg_fam_insts = fam_insts,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
- mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns,
+ mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
mg_rules = ds_rules_for_imps,
mg_binds = ds_binds,
mg_foreign = ds_fords,
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index fb024565ff2057db0175ddb4b988488730532c92..2ad9e975ec775ab23da4b154a72778f2e10422d5 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -157,7 +157,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
ex_tvs = case con1 of
RealDataCon dcon1 -> dataConExTyVars dcon1
- PatSynCon psyn1 -> patSynExTyVars psyn1
+ PatSynCon psyn1 -> patSynExTyVars psyn1
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index d40e9c88a16eb8ee4d6b18288169331af4b8c930..98f49c979a6a9a8f0a8e68c45a57bbecafd66c3b 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -1160,7 +1160,7 @@ Consider this TH term construction:
; x3 <- TH.newName "x"
; let x = mkName "x" -- mkName :: String -> TH.Name
- -- Builds a NameL
+ -- Builds a NameS
; return (LamE (..pattern [x1,x2]..) $
LamE (VarPat x3) $
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index c3f9b497f2ecebb53e1537836207c651e26ce612..32b43875b32e2fc61b4df4f96c994f32326e17e7 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1499,9 +1499,7 @@ patSynToIfaceDecl ps
, ifPatTy = tidyToIfaceType env2 rhs_ty
}
where
- (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig ps
- args = patSynArgs ps
- rhs_ty = patSynType ps
+ (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 58d0c584eb24b589b988c80337e700a83426a58d..dd122d057dd55911668edcc7877b8f3cf73a8a1c 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -71,7 +71,7 @@ module HscTypes (
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
typeEnvFromEntities, mkTypeEnvWithImplicits,
extendTypeEnv, extendTypeEnvList,
- extendTypeEnvWithIds, extendTypeEnvWithPatSyns,
+ extendTypeEnvWithIds,
lookupTypeEnv,
typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
@@ -951,7 +951,8 @@ data ModDetails
-- The next two fields are created by the typechecker
md_exports :: [AvailInfo],
md_types :: !TypeEnv, -- ^ Local type environment for this particular module
- md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module
+ -- Includes Ids, TyCons, PatSyns
+ md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules
md_anns :: ![Annotation], -- ^ Annotations present in this module: currently
@@ -1563,8 +1564,8 @@ implicitCoTyCon tc
-- other declaration.
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing (AConLike cl) = case cl of
- RealDataCon{} -> True
- PatSynCon ps -> isImplicitId (patSynId ps)
+ RealDataCon {} -> True
+ PatSynCon {} -> False
isImplicitTyThing (AnId id) = isImplicitId id
isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
@@ -1680,17 +1681,6 @@ extendTypeEnvList env things = foldl extendTypeEnv env things
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
= extendNameEnvList env [(getName id, AnId id) | id <- ids]
-
-extendTypeEnvWithPatSyns :: TypeEnv -> [PatSyn] -> TypeEnv
-extendTypeEnvWithPatSyns env patsyns
- = extendNameEnvList env $ concatMap pat_syn_things patsyns
- where
- pat_syn_things :: PatSyn -> [(Name, TyThing)]
- pat_syn_things ps = (getName ps, AConLike (PatSynCon ps)):
- case patSynWrapper ps of
- Just wrap_id -> [(getName wrap_id, AnId wrap_id)]
- Nothing -> []
-
\end{code}
\begin{code}
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 858281a20b1471c459d89f88b0838ed76bc60169..ef7661a01618b69941e3024731fe9faf178e6458 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -21,6 +21,8 @@ import CorePrep
import CoreUtils
import Literal
import Rules
+import PatSyn
+import ConLike
import CoreArity ( exprArity, exprBotStrictness_maybe )
import VarEnv
import VarSet
@@ -129,18 +131,20 @@ mkBootModDetailsTc hsc_env
TcGblEnv{ tcg_exports = exports,
tcg_type_env = type_env, -- just for the Ids
tcg_tcs = tcs,
+ tcg_patsyns = pat_syns,
tcg_insts = insts,
tcg_fam_insts = fam_insts
}
= do { let dflags = hsc_dflags hsc_env
; showPass dflags CoreTidy
- ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
- ; dfun_ids = map instanceDFunId insts'
+ ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
+ ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns
+ ; dfun_ids = map instanceDFunId insts'
+ ; pat_syn_ids = concatMap patSynIds pat_syns'
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
- (typeEnvIds type_env) tcs fam_insts
- ; type_env2 = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
- ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids
+ (typeEnvIds type_env) tcs fam_insts
+ ; type_env' = extendTypeEnvWithIds type_env1 (pat_syn_ids ++ dfun_ids)
}
; return (ModDetails { md_types = type_env'
, md_insts = insts'
@@ -333,19 +337,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; let { final_ids = [ id | id <- bindersOfBinds tidy_binds,
isExternalName (idName id)]
- ; final_patsyns = filter (isExternalName . getName) patsyns
+ ; type_env1 = extendTypeEnvWithIds type_env final_ids
- ; type_env' = extendTypeEnvWithIds type_env final_ids
- ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns
-
- ; tidy_type_env = tidyTypeEnv omit_prags type_env''
-
- ; tidy_insts = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts
- -- A DFunId will have a binding in tidy_binds, and so
- -- will now be in final_env, replete with IdInfo
- -- Its name will be unchanged since it was born, but
- -- we want Global, IdInfo-rich (or not) DFunId in the
- -- tidy_insts
+ ; tidy_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) insts
+ -- A DFunId will have a binding in tidy_binds, and so will now be in
+ -- tidy_type_env, replete with IdInfo. Its name will be unchanged since
+ -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
+ -- tidy_insts. Similarly the Ids inside a PatSyn.
; tidy_rules = tidyRules tidy_env ext_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
@@ -354,6 +352,16 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; tidy_vect_info = tidyVectInfo tidy_env vect_info
+ -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
+ -- and then override the PatSyns in the type_env with the new tidy ones
+ -- This is really the only reason we keep mg_patsyns at all; otherwise
+ -- they could just stay in type_env
+ ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns
+ ; type_env2 = extendTypeEnvList type_env1
+ [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
+
+ ; tidy_type_env = tidyTypeEnv omit_prags type_env2
+
-- See Note [Injecting implicit bindings]
; all_tidy_binds = implicit_binds ++ tidy_binds
@@ -405,11 +413,11 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
})
}
-lookup_dfun :: TypeEnv -> Var -> Id
-lookup_dfun type_env dfun_id
- = case lookupTypeEnv type_env (idName dfun_id) of
- Just (AnId dfun_id') -> dfun_id'
- _other -> pprPanic "lookup_dfun" (ppr dfun_id)
+lookup_aux_id :: TypeEnv -> Var -> Id
+lookup_aux_id type_env id
+ = case lookupTypeEnv type_env (idName id) of
+ Just (AnId id') -> id'
+ _other -> pprPanic "lookup_axu_id" (ppr id)
--------------------------
tidyTypeEnv :: Bool -- Compiling without -O, so omit prags
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index f3d754640fa1101d98a7a9fb0a02fe4780bd130f..a077f5d1d748d0451e16568dd0e07580f878c3d7 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -66,6 +66,7 @@ import TcIface
import PrelNames
import TysWiredIn
import Id
+import IdInfo( IdDetails(VanillaId) )
import Var
import VarSet
import RdrName
@@ -801,7 +802,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do
name <- mkWrapperName "stable" str
let occ = mkVarOccFS name :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
- id = mkExportedLocalId gnm sig_ty :: Id
+ id = mkExportedLocalId VanillaId gnm sig_ty :: Id
return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 927062e418872225d446dde59ea3df145d7db24b..b41867030d31f1d47f87b7afa691abb7ae1ce0bd 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -790,9 +790,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
-> HsConPatDetails Name -> TcM a
-> TcM (Pat TcId, a)
tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
- = do { let (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig pat_syn
- arg_tys = patSynArgs pat_syn
- ty = patSynType pat_syn
+ = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn
; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index e8ba56398a48d0a1ad076157413953ddbb4cdb87..ced34929e6d432b3fdaaacd9c3a04c393ccfbdc0 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -22,6 +22,7 @@ import Outputable
import FastString
import Var
import Id
+import IdInfo( IdDetails( VanillaId ) )
import TcBinds
import BasicTypes
import TcSimplify
@@ -128,7 +129,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
- matcher_id = mkVanillaGlobal matcher_name matcher_sigma
+ matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
; let matcher_lid = L loc matcher_id
@@ -222,7 +223,7 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
; let wrapper_lname = L loc wrapper_name
- wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
+ wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma
; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 12eb96f19d7c77c3583ab088d65c0bf64b5807e2..e6428a678fbb525d29d0b2d5c4b313c80d949283 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -62,6 +62,7 @@ import PprCore
import CoreSyn
import ErrUtils
import Id
+import IdInfo( IdDetails( VanillaId ) )
import VarEnv
import Module
import UniqFM
@@ -735,7 +736,7 @@ checkHiBootIface
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
- local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
+ local_boot_dfun = Id.mkExportedLocalId VanillaId (idName boot_dfun) boot_inst_ty
-- This has to compare the TyThing from the .hi-boot file to the TyThing
@@ -1361,7 +1362,7 @@ check_main dflags tcg_env
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS (fsLit "main"))
(getSrcSpan main_name)
- ; root_main_id = Id.mkExportedLocalId root_main_name
+ ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name
(mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 5feaa7c7fa6cd2f8c2fd20cfea02ef0a38966354..70d155bf94c55d99147bcc3e4a624608af869ddf 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -92,7 +92,7 @@ import Class ( Class )
import TyCon ( TyCon )
import ConLike ( ConLike(..) )
import DataCon ( DataCon, dataConUserType, dataConOrigArgTys )
-import PatSyn ( PatSyn, patSynId )
+import PatSyn ( PatSyn, patSynType )
import TcType
import Annotations
import InstEnv
@@ -1748,7 +1748,7 @@ pprSkolInfo (PatSkol cl mc) = case cl of
, ptext (sLit "in") <+> pprMatchContext mc ]
PatSynCon ps -> sep [ ptext (sLit "a pattern with pattern synonym")
, nest 2 $ ppr ps <+> dcolon
- <+> pprType (varType (patSynId ps)) <> comma
+ <+> pprType (patSynType ps) <> comma
, ptext (sLit "in") <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
, vcat [ ppr name <+> dcolon <+> ppr ty
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 62e17d4b7a0539cec129e0d96f73b60e86bedd57..56968c4ce751851da844a2b8dbfdd4601734cf96 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -70,7 +70,7 @@ import Class
import Inst
import TyCon
import CoAxiom
-import PatSyn ( patSynId )
+import PatSyn ( patSynName )
import ConLike
import DataCon
import TcEvidence( TcEvBinds(..) )
@@ -1175,7 +1175,7 @@ reifyThing (AGlobal (AConLike (RealDataCon dc)))
(reifyName (dataConOrigTyCon dc)) fix)
}
reifyThing (AGlobal (AConLike (PatSynCon ps)))
- = noTH (sLit "pattern synonyms") (ppr $ patSynId ps)
+ = noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
reifyThing (ATcId {tct_id = id})
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 51e646462eaf09a29e9593bd60a9ebcd2d499f39..1345696ba802c9d75de725fd6d79a9c1ad960b4f 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -644,7 +644,7 @@ tcTyClDecl1 _parent rec_info
; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
; return (clas, tvs', gen_dm_env) }
- ; let { gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+ ; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty)
| (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
, let gen_dm_tau = expectJust "tcTyClDecl1" $
lookupNameEnv gen_dm_env (idName sel_id)
@@ -1796,7 +1796,7 @@ checkValidRoles tc
mkDefaultMethodIds :: [TyThing] -> [Id]
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds things
- = [ mkExportedLocalId dm_name (idType sel_id)
+ = [ mkExportedLocalId VanillaId dm_name (idType sel_id)
| ATyCon tc <- things
, Just cls <- [tyConClass_maybe tc]
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
@@ -1836,8 +1836,7 @@ mkRecSelBind (tycon, sel_name)
= (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
loc = getSrcSpan sel_name
- sel_id = Var.mkExportedLocalVar rec_details sel_name
- sel_ty vanillaIdInfo
+ sel_id = mkExportedLocalId rec_details sel_name sel_ty
rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
-- Find a representative constructor, con1
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
index def1ffa58c67a091d138ca4bfdf1dd22210d4b73..b53324012ff6306c4199d42709c8294410a15ac1 100644
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ b/compiler/vectorise/Vectorise/Monad/Naming.hs
@@ -24,6 +24,7 @@ import Name
import SrcLoc
import MkId
import Id
+import IdInfo( IdDetails(VanillaId) )
import FastString
import Control.Monad
@@ -67,7 +68,7 @@ mkVectId :: Id -> Type -> VM Id
mkVectId id ty
= do { name <- mkLocalisedName mkVectOcc (getName id)
; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys
- | isExportedId id = Id.mkExportedLocalId name ty
+ | isExportedId id = Id.mkExportedLocalId VanillaId name ty
| otherwise = Id.mkLocalId name ty
; return id'
}
@@ -91,8 +92,8 @@ newExportedVar occ_name ty
u <- liftDs newUnique
let name = mkExternalName u mod occ_name noSrcSpan
-
- return $ Id.mkExportedLocalId name ty
+
+ return $ Id.mkExportedLocalId VanillaId name ty
-- |Make a fresh local variable with the given type.
-- The variable's name is formed using the given string as the prefix.