summaryrefslogtreecommitdiff
path: root/compiler/typecheck/TcInstDcls.hs
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2015-12-01 17:38:23 +0100
committerBen Gamari <ben@smart-cactus.org>2015-12-01 18:45:23 +0100
commit1e041b7382b6aa329e4ad9625439f811e0f27232 (patch)
tree91f4418553a1e6df072f56f43b5697d40c985b5f /compiler/typecheck/TcInstDcls.hs
parentb432e2f39c095d8acbb0cfcc63bd08436c7a3e49 (diff)
downloadhaskell-1e041b7382b6aa329e4ad9625439f811e0f27232.tar.gz
Refactor treatment of wildcards
This patch began as a modest refactoring of HsType and friends, to clarify and tidy up exactly where quantification takes place in types. Although initially driven by making the implementation of wildcards more tidy (and fixing a number of bugs), I gradually got drawn into a pretty big process, which I've been doing on and off for quite a long time. There is one compiler performance regression as a result of all this, in perf/compiler/T3064. I still need to look into that. * The principal driving change is described in Note [HsType binders] in HsType. Well worth reading! * Those data type changes drive almost everything else. In particular we now statically know where (a) implicit quantification only (LHsSigType), e.g. in instance declaratios and SPECIALISE signatures (b) implicit quantification and wildcards (LHsSigWcType) can appear, e.g. in function type signatures * As part of this change, HsForAllTy is (a) simplified (no wildcards) and (b) split into HsForAllTy and HsQualTy. The two contructors appear when and only when the correponding user-level construct appears. Again see Note [HsType binders]. HsExplicitFlag disappears altogether. * Other simplifications - ExprWithTySig no longer needs an ExprWithTySigOut variant - TypeSig no longer needs a PostRn name [name] field for wildcards - PatSynSig records a LHsSigType rather than the decomposed pieces - The mysterious 'GenericSig' is now 'ClassOpSig' * Renamed LHsTyVarBndrs to LHsQTyVars * There are some uninteresting knock-on changes in Haddock, because of the HsSyn changes I also did a bunch of loosely-related changes: * We already had type synonyms CoercionN/CoercionR for nominal and representational coercions. I've added similar treatment for TcCoercionN/TcCoercionR mkWpCastN/mkWpCastN All just type synonyms but jolly useful. * I record-ised ForeignImport and ForeignExport * I improved the (poor) fix to Trac #10896, by making TcTyClsDecls.checkValidTyCl recover from errors, but adding a harmless, abstract TyCon to the envt if so. * I did some significant refactoring in RnEnv.lookupSubBndrOcc, for reasons that I have (embarrassingly) now totally forgotten. It had to do with something to do with import and export Updates haddock submodule.
Diffstat (limited to 'compiler/typecheck/TcInstDcls.hs')
-rw-r--r--compiler/typecheck/TcInstDcls.hs42
1 files changed, 20 insertions, 22 deletions
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index dc281d1df2..c9b1363675 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -18,7 +18,7 @@ import TcTyClsDecls
import TcClassDcl( tcClassDecl2, tcATDefault,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod )
-import TcPat ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv )
+import TcPat ( addInlinePrags, lookupPragEnv, emptyPragEnv )
import TcRnMonad
import TcValidity
import TcMType
@@ -62,6 +62,8 @@ import Control.Monad
import Maybes
import Data.List ( partition )
+
+
{-
Typechecking instance declarations is done in two passes. The first
pass, made by @tcInstDecls1@, collects information to be used in the
@@ -522,7 +524,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
- ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
+ ; (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
mb_info = Just (clas, mini_env)
@@ -546,7 +548,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
- ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
+ ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty))
-- Dfun location is that of instance *header*
; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
@@ -987,7 +989,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t
loc = getSrcSpan dfun_id
size = sizeTypes inst_tys
tc_super (sc_pred, n)
- = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ \_ ->
+ = do { (sc_implic, sc_ev_id) <- checkInstConstraints $
emitWanted (ScOrigin size) sc_pred
; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
@@ -1005,18 +1007,14 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t
; return (sc_top_id, L loc bind, sc_implic) }
-------------------
-checkInstConstraints :: (EvBindsVar -> TcM result)
- -> TcM (Implication, result)
+checkInstConstraints :: TcM result -> TcM (Implication, result)
-- See Note [Typechecking plan for instance declarations]
--- The thing_inside is also passed the EvBindsVar,
--- so that emit_sc_pred can add evidence for the superclass
--- (not used for methods)
checkInstConstraints thing_inside
- = do { ev_binds_var <- newTcEvBinds
- ; env <- getLclEnv
- ; (result, tclvl, wanted) <- pushLevelAndCaptureConstraints $
- thing_inside ev_binds_var
+ = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
+ thing_inside
+ ; ev_binds_var <- newTcEvBinds
+ ; env <- getLclEnv
; let implic = Implic { ic_tclvl = tclvl
, ic_skols = []
, ic_no_eqs = False
@@ -1374,7 +1372,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
; global_meth_id <- addInlinePrags global_meth_id prags
; spec_prags <- tcSpecPrags global_meth_id prags
; (meth_implic, (tc_bind, _))
- <- checkInstConstraints $ \ _ev_binds ->
+ <- checkInstConstraints $
tcPolyCheck NonRecursive no_prag_fn local_meth_sig
(L bind_loc lm_bind)
@@ -1418,13 +1416,13 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
; case lookupHsSig sig_fn sel_name of
Just lhs_ty -- There is a signature in the instance declaration
-- See Note [Instance method signatures]
- -> setSrcSpan (getLoc lhs_ty) $
+ -> setSrcSpan (getLoc (hsSigType lhs_ty)) $
do { inst_sigs <- xoptM Opt_InstanceSigs
; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) lhs_ty
; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
ctxt = FunSigCtxt sel_name True
- ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty Nothing [] local_meth_name
+ ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty local_meth_name
; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
tcSubType ctxt poly_sig_ty poly_meth_ty
; return (poly_meth_id, tc_sig, hs_wrap) }
@@ -1455,7 +1453,7 @@ methSigCtxt sel_name sig_ty meth_ty env0
, ptext (sLit " Class sig:") <+> ppr meth_ty ])
; return (env2, msg) }
-misplacedInstSig :: Name -> LHsType Name -> SDoc
+misplacedInstSig :: Name -> LHsSigType Name -> SDoc
misplacedInstSig name hs_ty
= vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
2 (hang (pprPrefixName name)
@@ -1727,7 +1725,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
= addErrCtxt (spec_ctxt prag) $
- do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
+ do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
@@ -1744,11 +1742,11 @@ tcSpecInst _ _ = panic "tcSpecInst"
************************************************************************
-}
-instDeclCtxt1 :: LHsType Name -> SDoc
+instDeclCtxt1 :: LHsSigType Name -> SDoc
instDeclCtxt1 hs_inst_ty
- = inst_decl_ctxt (case unLoc hs_inst_ty of
- HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
- _ -> ppr hs_inst_ty) -- Don't expect this
+ | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty
+ = inst_decl_ctxt (ppr head_ty)
+
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))