Commit 7ac600d5 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds

This was a serious bug, exposed by Trac #9175.  The matcher and wrapper
must be LocalIds, like record selectors and dictionary functions, for
the reasons now documented in Note [Exported LocalIds] in Id.lhs

In fixing this I found
 - PatSyn should have an Id inside it (apart from the wrapper and matcher)
   It should be a Name.  Hence psId --> psName, with knock-on consequences

 - Tidying of PatSyns in TidyPgm was wrong

 - The keep-alive set in Desugar.deSugar (now) doesn't need pattern synonyms
   in it

I also cleaned up the interface to PatSyn a little, so there's a tiny knock-on
effect in Haddock; hence the haddock submodule update.

It's very hard to make a test for this bug, so I haven't.
parent 6e50553c
......@@ -254,8 +254,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]
......@@ -307,6 +308,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.
%************************************************************************
%* *
......
......@@ -67,7 +67,6 @@ import PrimOp
import ForeignCall
import DataCon
import Id
import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
......@@ -955,29 +954,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;
......@@ -987,12 +970,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
......
......@@ -12,16 +12,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
......@@ -29,8 +31,6 @@ import Util
import BasicTypes
import FastString
import Var
import Id
import TcType
import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
......@@ -115,7 +115,7 @@ expression when available.
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
psId :: Id,
psName :: Name,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
......@@ -168,7 +168,7 @@ instance Uniquable PatSyn where
getUnique = psUnique
instance NamedThing PatSyn where
getName = getName . psId
getName = patSynName
instance Outputable PatSyn where
ppr = ppr . getName
......@@ -209,7 +209,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,
......@@ -218,20 +218,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
......@@ -245,17 +246,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
......@@ -263,6 +267,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)
......@@ -271,12 +285,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
......@@ -285,10 +300,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}
......@@ -52,8 +52,6 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
import Data.Maybe ( mapMaybe )
import UniqFM
\end{code}
%************************************************************************
......@@ -125,27 +123,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
......@@ -189,7 +180,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,
......
......@@ -158,7 +158,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
......
......@@ -1158,7 +1158,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) $
......
......@@ -1510,9 +1510,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
......
......@@ -72,7 +72,7 @@ module HscTypes (
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
typeEnvFromEntities, mkTypeEnvWithImplicits,
extendTypeEnv, extendTypeEnvList,
extendTypeEnvWithIds, extendTypeEnvWithPatSyns,
extendTypeEnvWithIds,
lookupTypeEnv,
typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
......@@ -952,7 +952,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
......@@ -1564,8 +1565,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
......@@ -1681,17 +1682,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}
......
......@@ -23,6 +23,8 @@ import CorePrep
import CoreUtils
import Literal
import Rules
import PatSyn
import ConLike
import CoreArity ( exprArity, exprBotStrictness_maybe )
import VarEnv
import VarSet
......@@ -132,18 +134,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'
......@@ -336,19 +340,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
......@@ -357,6 +355,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
......@@ -408,11 +416,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
......
......@@ -68,6 +68,7 @@ import TcIface
import PrelNames
import TysWiredIn
import Id
import IdInfo( IdDetails(VanillaId) )
import Var
import VarSet
import RdrName
......@@ -803,7 +804,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
......
......@@ -791,9 +791,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
......
......@@ -24,6 +24,7 @@ import Outputable
import FastString
import Var
import Id
import IdInfo( IdDetails( VanillaId ) )
import TcBinds
import BasicTypes
import TcSimplify
......@@ -130,7 +131,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
......@@ -224,7 +225,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
......
......@@ -61,6 +61,7 @@ import RnEnv
import RnSource
import ErrUtils
import Id
import IdInfo( IdDetails( VanillaId ) )
import VarEnv
import Module
import UniqFM
......@@ -632,7 +633,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
......@@ -1045,7 +1046,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
......
......@@ -94,7 +94,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
......@@ -1752,7 +1752,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
......
......@@ -71,7 +71,7 @@ import Class
import Inst
import TyCon
import CoAxiom
import PatSyn ( patSynId )
import PatSyn ( patSynName )
import ConLike
import DataCon
import TcEvidence( TcEvBinds(..) )
......@@ -1184,7 +1184,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
......
......@@ -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)
......@@ -1797,7 +1797,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 ]
......@@ -1837,8 +1837,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
......
......@@ -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.
......
Subproject commit c4f6201356b29023ecbd2f7bf1c91e5318586765
Subproject commit 276f201de589999690e49491089c7e7ec9cfbf3f
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment