diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-01 17:38:23 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-01 18:45:23 +0100 |
commit | 1e041b7382b6aa329e4ad9625439f811e0f27232 (patch) | |
tree | 91f4418553a1e6df072f56f43b5697d40c985b5f /compiler/typecheck/TcInstDcls.hs | |
parent | b432e2f39c095d8acbb0cfcc63bd08436c7a3e49 (diff) | |
download | haskell-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.hs | 42 |
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)) |