Commit 20e39e0e authored by simonpj's avatar simonpj

[project @ 2004-12-22 16:58:34 by simonpj]

----------------------------------------
	     Add more scoped type variables
	----------------------------------------

Now the top-level forall'd variables of a type signature scope
over the right hand side of that function.

	f :: a -> a
	f x = ....

The type variable 'a' is in scope in the RHS, and in f's patterns.

It's implied by -fglasgow-exts, but can also be switched off independently
using -fscoped-type-variables (and the -fno variant)
parent d7c402a3
......@@ -29,7 +29,7 @@ import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
ModIface(..), ModDetails(..), ModGuts,
mkTypeEnv, extendTypeEnv,
lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( extendInstEnv )
import InstEnv ( extendInstEnvList )
import CoreSyn
import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
......@@ -436,7 +436,7 @@ loadImportedInsts cls tys
-- And put them in the package instance environment
; updateEps ( \ eps ->
let
inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
in
(eps { eps_inst_env = inst_env' }, inst_env')
)}}
......
......@@ -275,6 +275,7 @@ data DynFlag
| Opt_ImplicitParams
| Opt_Generics
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
-- optimisation opts
| Opt_Strictness
......
......@@ -467,6 +467,7 @@ fFlags = [
( "parr", Opt_PArr ),
( "th", Opt_TH ),
( "implicit-prelude", Opt_ImplicitPrelude ),
( "scoped-type-variables", Opt_ScopedTypeVariables ),
( "monomorphism-restriction", Opt_MonomorphismRestriction ),
( "implicit-params", Opt_ImplicitParams ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
......@@ -485,7 +486,7 @@ fFlags = [
( "unbox-strict-fields", Opt_UnboxStrictFields )
]
glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ]
glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ]
isFFlag f = f `elem` (map fst fFlags)
getFFlag f = fromJust (lookup f fFlags)
......
......@@ -92,7 +92,6 @@ import Maybes ( orElse )
import Outputable
import SrcLoc ( SrcSpan )
import UniqSupply ( UniqSupply )
import Maybe ( fromJust )
import FastString ( FastString )
import DATA_IOREF ( IORef, readIORef )
......
......@@ -27,7 +27,7 @@ import RnExpr ( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn,
lookupLocatedInstDeclBndr,
lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
bindLocalFixities,
bindLocalFixities, bindSigTyVarsFV,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
......@@ -298,7 +298,9 @@ mkBindVertex sigs (L loc (PatBind pat grhss ty))
names_bound_here = mkNameSet (collectPatBinders pat')
in
sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) ->
bindSigTyVarsFV sigs_for_me (
rnGRHSs PatBindRhs grhss
) `thenM` \ (grhss', fvs) ->
returnM
(names_bound_here, fvs `plusFV` pat_fvs,
L loc (PatBind pat' grhss' ty), sigs_for_me
......@@ -312,7 +314,9 @@ mkBindVertex sigs (L loc (FunBind name inf matches))
names_bound_here = unitNameSet plain_name
in
sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
rnMatchGroup (FunRhs plain_name) matches `thenM` \ (new_matches, fvs) ->
bindSigTyVarsFV sigs_for_me (
rnMatchGroup (FunRhs plain_name) matches
) `thenM` \ (new_matches, fvs) ->
checkPrecMatch inf plain_name new_matches `thenM_`
returnM
(unitNameSet plain_name, fvs,
......
......@@ -18,7 +18,7 @@ module RnEnv (
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
bindLocatedLocalsFV, bindLocatedLocalsRn,
bindPatSigTyVars, bindPatSigTyVarsFV,
bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalFixities,
......@@ -45,7 +45,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
import HsTypes ( replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
import Name ( Name, nameIsLocalOrFrom, mkInternalName,
nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
import NameSet
import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
......@@ -557,15 +557,16 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
(enclosed_scope names)
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= getLocalRdrEnv `thenM` \ name_env ->
setLocalRdrEnv (extendLocalRdrEnv name_env names)
enclosed_scope
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
= bindLocalNames names $
enclosed_scope `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
= do { (result, fvs) <- bindLocalNames names enclosed_scope
; returnM (result, delListFromNameSet fvs names) }
-------------------------------------
......@@ -579,15 +580,10 @@ bindLocatedLocalsFV doc rdr_names enclosed_scope
returnM (thing, delListFromNameSet fvs names)
-------------------------------------
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-- This tiresome function is used only in rnSourceDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
= bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs tyvars)
bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM a)
-> RnM a
-- Haskell-98 binding of type variables; e.g. within a data type decl
bindTyVarsRn doc_str tyvar_names enclosed_scope
= let
located_tyvars = hsLTyVarLocNames tyvar_names
......@@ -601,19 +597,22 @@ bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
bindPatSigTyVars tys thing_inside
= getLocalRdrEnv `thenM` \ name_env ->
let
located_tyvars = nubBy eqLocated [ tv | ty <- tys,
tv <- extractHsTyRdrTyVars ty,
not (unLoc tv `elemLocalRdrEnv` name_env)
]
= do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
; if not scoped_tyvars then
thing_inside []
else
do { name_env <- getLocalRdrEnv
; let locd_tvs = [ tv | ty <- tys
, tv <- extractHsTyRdrTyVars ty
, not (unLoc tv `elemLocalRdrEnv` name_env) ]
nubbed_tvs = nubBy eqLocated locd_tvs
-- The 'nub' is important. For example:
-- f (x :: t) (y :: t) = ....
-- We don't want to complain about binding t twice!
doc_sig = text "In a pattern type-signature"
in
bindLocatedLocalsRn doc_sig located_tyvars thing_inside
; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }}
where
doc_sig = text "In a pattern type-signature"
bindPatSigTyVarsFV :: [LHsType RdrName]
-> RnM (a, FreeVars)
......@@ -623,6 +622,35 @@ bindPatSigTyVarsFV tys thing_inside
thing_inside `thenM` \ (result,fvs) ->
returnM (result, fvs `delListFromNameSet` tvs)
bindSigTyVarsFV :: [LSig Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
-- Bind the top-level forall'd type variables in the sigs.
-- E.g f :: a -> a
-- f = rhs
-- The 'a' scopes over the rhs
--
-- NB: there'll usually be just one (for a function binding)
-- but if there are many, one may shadow the rest; too bad!
-- e.g x :: [a] -> [a]
-- y :: [(a,a)] -> a
-- (x,y) = e
-- In e, 'a' will be in scope, and it'll be the one from 'y'!
bindSigTyVarsFV sigs thing_inside
= do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
; if not scoped_tyvars then
thing_inside
else
bindLocalNamesFV tvs thing_inside }
where
tvs = [ hsLTyVarName ltv
| L _ (Sig _ (L _ (HsForAllTy _ ltvs _ _))) <- sigs, ltv <- ltvs ]
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-- This function is used only in rnSourceDecl on InstDecl
extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
-------------------------------------
checkDupNames :: SDoc
-> [Located RdrName]
......
......@@ -54,9 +54,9 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
PredType(..), typeKind,
PredType(..), typeKind, mkSigmaTy,
tcSplitForAllTys, tcSplitForAllTys,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
......@@ -79,7 +79,7 @@ import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique, mkSystemNameEncoded )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind )
import Var ( TyVar, tyVarKind, setIdType )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
......@@ -566,10 +566,15 @@ addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
addInst dflags home_ie dfun
= do { -- Load imported instances, so that we report
= do { -- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
(tvs', theta', tau') <- tcInstType (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
-- Load imported instances, so that we report
-- duplicates correctly
let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
; pkg_ie <- loadImportedInsts cls tys
; pkg_ie <- loadImportedInsts cls tys'
-- Check functional dependencies
; case checkFunDeps (pkg_ie, home_ie) dfun of
......@@ -577,13 +582,9 @@ addInst dflags home_ie dfun
Nothing -> return ()
-- Check for duplicate instance decls
-- We instantiate the dfun type because the instance lookup
-- requires nice fresh types in the thing to be looked up
; (tvs', _, tenv) <- tcInstTyVars tvs
; let { tys' = substTys tenv tys
; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
isJust (tcMatchTys (mkVarSet tvs) tys' dup_tys)] }
isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-- Find memebers of the match list which
-- dfun itself matches. If the match is 2-way, it's a duplicate
; case dup_dfuns of
......@@ -591,7 +592,7 @@ addInst dflags home_ie dfun
[] -> return ()
-- OK, now extend the envt
; return (extendInstEnv home_ie dfun) }
; return (extendInstEnv home_ie dfun') }
traceDFuns dfuns
......
......@@ -19,7 +19,7 @@ import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType,
SkolemInfo(..) )
import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVar, zonkTcType )
import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
......@@ -244,7 +244,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; span <- getSrcSpanM
; w_tv <- tcSkolTyVar (ArrowSkol span) alphaTyVar
; [w_tv] <- tcSkolTyVars (ArrowSkol span) [alphaTyVar]
; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t
......
......@@ -21,16 +21,16 @@ import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
import TcRnMonad
import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv, newLocalName, tcLookupLocalIds )
import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
TcSigInfo(..), TcSigFun, mkTcSig, lookupSig
TcSigInfo(..), TcSigFun, lookupSig
)
import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes )
import TcMType ( newTyFlexiVarTy, tcSkolSigType, zonkQuantifiedTyVar, zonkTcTypes )
import TcType ( TcTyVar, SkolemInfo(SigSkol),
TcTauType, TcSigmaType,
TvSubstEnv, mkTvSubst, substTheta, substTy,
......@@ -38,14 +38,13 @@ import TcType ( TcTyVar, SkolemInfo(SigSkol),
mkForAllTy, isUnLiftedType, tcGetTyVar_maybe,
mkTyVarTys )
import Unify ( tcMatchPreds )
import Kind ( argTypeKind, isUnliftedTypeKind )
import Kind ( argTypeKind )
import VarEnv ( lookupVarEnv )
import TysPrim ( alphaTyVar )
import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
import Var ( idType, idName )
import Name ( Name )
import NameSet
import Var ( tyVarKind )
import VarSet
import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import Bag
......@@ -435,22 +434,24 @@ tcMonoBinds :: LHsBinds Name
-> TcSigFun -> RecFlag
-> TcM (LHsBinds TcId, [MonoBindInfo])
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
-- Type signature (if any), and
-- the monomorphic bound things
bndrNames :: [MonoBindInfo] -> [Name]
bndrNames mbi = [n | (n,_,_) <- mbi]
getMonoType :: MonoBindInfo -> TcTauType
getMonoType (_,_,mono_id) = idType mono_id
tcMonoBinds binds lookup_sig is_rec
= do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
; let mono_info = getMonoBindInfo tc_binds
; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
-- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
-- For (a) it's ok to bring them all into scope at once, even
-- though each type sig should scope only over its own RHS,
-- because the renamer has sorted all that out.
; let mono_info = getMonoBindInfo tc_binds
rhs_tvs = [ tv | (_, Just sig, _) <- mono_info, tv <- sig_tvs sig ]
rhs_id_env = map mk mono_info -- A binding for each term variable
; binds' <- tcExtendTyVarEnv rhs_tvs $
tcExtendIdEnv2 rhs_id_env $
mapBagM (wrapLocM tcRhs) tc_binds
; return (binds', mono_info) }
where
mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one
mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version
------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
......@@ -472,6 +473,16 @@ data TcMonoBind -- Half completed; LHS done, RHS not done
= TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
| TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
-- Type signature (if any), and
-- the monomorphic bound things
bndrNames :: [MonoBindInfo] -> [Name]
bndrNames mbi = [n | (n,_,_) <- mbi]
getMonoType :: MonoBindInfo -> TcTauType
getMonoType (_,_,mono_id) = idType mono_id
tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
= do { let mb_sig = lookup_sig name
......@@ -505,7 +516,7 @@ tcLhs lookup_sig bind@(PatBind pat grhss _)
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
= do { matches' <- tcMatchesFun (idName mono_id) matches
(Check (idType mono_id))
; return (FunBind fun' inf matches') }
......@@ -523,15 +534,6 @@ getMonoBindInfo tc_binds
where
get_info (TcFunBind info _ _ _) rest = info : rest
get_info (TcPatBind infos _ _ _) rest = infos ++ rest
---------------------
rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
-- Environment for RHS of definitions: use type sig if there is one
rhsEnvExtension mono_info
= map mk mono_info
where
mk (name, Just sig, _) = (name, sig_id sig)
mk (name, Nothing, mono_id) = (name, mono_id)
\end{code}
......@@ -548,42 +550,47 @@ tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
-- all the right hand sides agree a common vocabulary for their type
-- constraints
tcTySigs [] = return []
tcTySigs (L span (Sig (L _ name) ty) : sigs)
= do { -- Typecheck the first signature
; sigma1 <- setSrcSpan span $
tcHsSigType (FunSigCtxt name) ty
; let id1 = mkLocalId name sigma1
; tc_sig1 <- mkTcSig id1
; tc_sigs <- mapM (tcTySig tc_sig1) sigs
; return (tc_sig1 : tc_sigs) }
tcTySigs sigs
= do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
; tc_sigs' <- mapM (checkSigCtxt tc_sig1) tc_sigs
; return (tc_sig1 : tc_sigs') }
tcTySig sig1 (L span (Sig (L _ name) ty))
tcTySig :: LSig Name -> TcM TcSigInfo
tcTySig (L span (Sig (L _ name) ty))
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
; let poly_id = mkLocalId name sigma_ty
bale_out = failWithTc $
sigContextsErr (sig_id sig1) name sigma_ty
; let rigid_info = SigSkol name
poly_id = mkLocalId name sigma_ty
; (tvs, theta, tau) <- tcSkolSigType rigid_info sigma_ty
; loc <- getInstLoc (SigOrigin rigid_info)
; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau,
sig_loc = loc }) }
-- Try to match the context of this signature with
checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo
checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = tau })
= -- Try to match the context of this signature with
-- that of the first signature
; case tcMatchPreds tvs theta (sig_theta sig1) of {
Nothing -> bale_out
; Just tenv -> do
; case check_tvs tenv tvs of
Nothing -> bale_out
Just tvs' -> do {
let subst = mkTvSubst tenv
theta' = substTheta subst theta
tau' = substTy subst tau
; loc <- getInstLoc (SigOrigin rigid_info)
; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs',
sig_theta = theta', sig_tau = tau',
sig_loc = loc }) }}}
case tcMatchPreds (sig_tvs sig) (sig_theta sig) (sig_theta sig1) of {
Nothing -> bale_out ;
Just tenv ->
case check_tvs tenv tvs of {
Nothing -> bale_out ;
Just tvs' ->
let
subst = mkTvSubst tenv
in
return (sig { sig_tvs = tvs',
sig_theta = substTheta subst theta,
sig_tau = substTy subst tau }) }}
where
rigid_info = SigSkol name
bale_out = setSrcSpan (instLocSrcSpan (sig_loc sig)) $
failWithTc $
sigContextsErr (sig_id sig1) (sig_id sig)
-- Rather tedious check that the type variables
-- have been matched only with another type variable,
......@@ -832,10 +839,10 @@ valSpecSigCtxt v ty
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
sigContextsErr id1 name ty
sigContextsErr id1 id2
= vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
ppr name <+> dcolon <+> ppr ty]),
ppr id2 <+> dcolon <+> ppr (idType id2)]),
ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
......
......@@ -20,7 +20,7 @@ import RnEnv ( lookupTopBndrRn, lookupImportedName )
import Inst ( Inst, InstOrigin(..), instToId, newDicts, newDictsAtLoc, newMethod )
import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2,
tcExtendTyVarEnv2,
tcExtendTyVarEnv,
InstInfo(..), pprInstInfoDetails,
simpleInstInfoTyCon, simpleInstInfoTy,
InstBindings(..), newDFunName
......@@ -29,7 +29,7 @@ import TcBinds ( tcMonoBinds, tcSpecSigs )
import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( checkSigTyVars, sigCtxt )
import TcMType ( tcSkolTyVars, UserTypeCtxt( GenPatCtxt ) )
import TcMType ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ) )
import TcType ( Type, SkolemInfo(ClsSkol, InstSkol),
TcType, TcThetaType, TcTyVar, mkTyVarTys,
mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
......@@ -51,7 +51,6 @@ import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
import OccName ( reportIfUnused, mkDefaultMethodOcc )
import RdrName ( RdrName, mkDerivedRdrName )
import Outputable
import Var ( TyVar )
import PrelNames ( genericTyConNames )
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
......@@ -263,19 +262,17 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcDefMeth clas tyvars binds_in prags sel_id
= do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
; let rigid_info = ClsSkol clas
; clas_tyvars <- tcSkolTyVars rigid_info tyvars
; let
; let rigid_info = ClsSkol clas
clas_tyvars = tcSkolSigTyVars rigid_info tyvars
inst_tys = mkTyVarTys clas_tyvars
dm_ty = idType sel_id -- Same as dict selector!
theta = [mkClassPred clas inst_tys]
local_dm_id = mkDefaultMethodId dm_name dm_ty
xtve = tyvars `zip` clas_tyvars
origin = SigOrigin rigid_info
; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
; [this_dict] <- newDicts origin theta
; (defm_bind, insts_needed) <- getLIE (tcMethodBind xtve clas_tyvars theta
; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta
[this_dict] prags meth_info)
; addErrCtxt (defltMethCtxt clas) $ do
......@@ -322,11 +319,11 @@ type MethodSpec = (Id, -- Global selector Id
LHsBind Name) -- Binding for the method
tcMethodBind
:: [(TyVar,TcTyVar)] -- Bindings for type environment
-> [TcTyVar] -- Instantiated type variables for the
:: [TcTyVar] -- Skolemised type variables for the
-- enclosing class/instance decl.
-- They'll be signature tyvars, and we
-- want to check that they don't get bound
-- Also they are scoped, so we bring them into scope
-- Always equal the range of the type envt
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
......@@ -335,7 +332,7 @@ tcMethodBind
-> MethodSpec -- Details of this method
-> TcM (LHsBinds Id)
tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
tcMethodBind inst_tyvars inst_theta avail_insts prags
(sel_id, meth_id, meth_bind)
= recoverM (returnM emptyLHsBinds) $
-- If anything fails, recover returning no bindings.
......@@ -349,7 +346,7 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
let lookup_sig name = ASSERT( name == idName meth_id )
Just meth_sig
in
tcExtendTyVarEnv2 xtve (
tcExtendTyVarEnv inst_tyvars (
addErrCtxt (methodCtxt sel_id) $
getLIE $
tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive
......
......@@ -20,7 +20,7 @@ import TcEnv ( newDFunName, pprInstInfoDetails,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( simpleDFunClassTyCon, extendInstEnv )
import InstEnv ( simpleDFunClassTyCon, extendInstEnvList )
import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
......@@ -723,7 +723,7 @@ extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
-- for functional dependency errors -- that'll happen in TcInstDcls
extendLocalInstEnv dfuns thing_inside
= do { env <- getGblEnv
; let inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns
; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
env' = env { tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
\end{code}
......
......@@ -17,7 +17,7 @@ module TcEnv(
-- Local environment
tcExtendKindEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendTyVarEnv3,
tcExtendTyVarEnv, tcExtendTyVarEnv3,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
......@@ -250,10 +250,6 @@ tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tc_extend_tv_env [ATyVar tv (mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 tv_pairs thing_inside
= tc_extend_tv_env [ATyVar tv1 (mkTyVarTy tv2) | (tv1,tv2) <- tv_pairs] thing_inside
tcExtendTyVarEnv3 :: [(TyVar,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv3 ty_pairs thing_inside
= tc_extend_tv_env [ATyVar tv1 ty2 | (tv1,ty2) <- ty_pairs] thing_inside
......@@ -559,8 +555,8 @@ as well as explicit user written ones.
\begin{code}
data InstInfo
= InstInfo {
iDFunId :: DFunId, -- The dfun id
iBinds :: InstBindings
iDFunId :: DFunId, -- The dfun id. Its forall'd type variables
iBinds :: InstBindings -- scope over the stuff in InstBindings!
}
data InstBindings
......
......@@ -41,8 +41,7 @@ import TcUnify ( unifyFunKind, checkExpectedKind )
import TcType ( Type, PredType(..), ThetaType,
SkolemInfo(SigSkol), MetaDetails(Flexi),
TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
mkTyVarTy, mkFunTy,
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkForAllTys, mkFunTys, tcEqType, isPredTy, mkFunTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
tcSplitFunTy_maybe, tcSplitForAllTys )
import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
......
......@@ -13,14 +13,14 @@ import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
import TcMType ( tcSkolType, checkValidTheta, checkValidInstHead, instTypeErr,
import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr,
checkAmbiguity, SourceTyCtxt(..) )
import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
import TcType ( mkClassPred, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitDFunHead, mkTyVarTys,
SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )