X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=c8a50d0be11814b905e4f57a305a015bda5f728c;hb=2c68b1afb33bd4f7a2d83f428de236e7ace2723f;hp=f27a78255542fb0f2b6d03b7cb0d885f2d053a5c;hpb=5f553f0c0508cb09b75f78e6c2ac1baa4c01b6aa;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f27a782..c8a50d0 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -5,10 +5,11 @@ \begin{code} module Inst ( - showLIE, - Inst, - pprInst, pprInsts, pprInstsInFull, pprDFuns, + + pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages + showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages + tidyInsts, tidyMoreInsts, newDictsFromOld, newDicts, cloneDict, @@ -63,7 +64,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, getClassPredTys, getClassPredTys_maybe, mkPredName, isInheritablePred, isIPPred, matchTys, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, - pprPred, pprParendType, pprThetaArrow, pprClassPred + pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred ) import Kind ( isSubKind ) import HscTypes ( ExternalPackageState(..) ) @@ -73,7 +74,7 @@ import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique import PrelInfo ( isStandardClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName ) import NameSet ( addOneToNameSet ) -import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) +import Subst ( substTy, substTyWith, substTheta, mkTopTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar, tyVarKind ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) @@ -82,7 +83,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) -import SrcLoc ( mkSrcSpan, noLoc, Located(..) ) +import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) import Maybes ( isJust ) import Outputable @@ -276,27 +277,34 @@ tcInstCall orig fun_ty -- fun_ty is usually a sigma-type in returnM (mkCoercion inst_fn, tau) -tcInstDataCon :: InstOrigin -> DataCon +tcInstDataCon :: InstOrigin + -> TyVarDetails -- Use this for the existential tyvars + -- ExistTv when pattern-matching, + -- VanillaTv at a call of the constructor + -> DataCon -> TcM ([TcType], -- Types to instantiate at [Inst], -- Existential dictionaries to apply to [TcType], -- Argument types of constructor TcType, -- Result type [TyVar]) -- Existential tyvars -tcInstDataCon orig data_con +tcInstDataCon orig ex_tv_details data_con = let (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con -- We generate constraints for the stupid theta even when -- pattern matching (as the Report requires) in - tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) -> + mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' -> + mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' -> let + tv_tys' = mkTyVarTys tvs' + ex_tv_tys' = mkTyVarTys ex_tvs' + all_tys' = tv_tys' ++ ex_tv_tys' + + tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys' stupid_theta' = substTheta tenv stupid_theta ex_theta' = substTheta tenv ex_theta arg_tys' = map (substTy tenv) arg_tys - - n_normal_tvs = length tvs - ex_tvs' = drop n_normal_tvs all_tvs' - result_ty = mkTyConApp tycon (take n_normal_tvs ty_args') + result_ty' = mkTyConApp tycon tv_tys' in newDicts orig stupid_theta' `thenM` \ stupid_dicts -> newDicts orig ex_theta' `thenM` \ ex_dicts -> @@ -305,7 +313,7 @@ tcInstDataCon orig data_con -- we don't otherwise use it at all extendLIEs stupid_dicts `thenM_` - returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs') + returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs') newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId newMethodFromName origin ty name @@ -385,10 +393,10 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty -- Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify -- ToDo: noLoc sadness - = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) -> - mkIntegerLit i `thenM` \ integer_lit -> - returnM (mkHsApp expr integer_lit) - + = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> + mkIntegerLit i `thenM` \ integer_lit -> + returnM (mkHsApp (noLoc expr) integer_lit) + -- The mkHsApp will get the loc from the literal | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -397,9 +405,10 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty newOverloadedLit orig lit@(HsFractional r fr) expected_ty | fr /= fromRationalName -- c.f. HsIntegral case - = tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) -> - mkRatLit r `thenM` \ rat_lit -> - returnM (mkHsApp expr rat_lit) + = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) -> + mkRatLit r `thenM` \ rat_lit -> + returnM (mkHsApp (noLoc expr) rat_lit) + -- The mkHsApp will get the loc from the literal | Just expr <- shortCutFracLit r expected_ty = returnM expr @@ -496,27 +505,33 @@ relevant in error messages. instance Outputable Inst where ppr inst = pprInst inst -pprInsts :: [Inst] -> SDoc -pprInsts insts = parens (sep (punctuate comma (map pprInst insts))) +pprDictsTheta :: [Inst] -> SDoc +-- Print in type-like fashion (Eq a, Show b) +pprDictsTheta dicts = pprTheta (map dictPred dicts) -pprInstsInFull insts - = vcat (map go insts) +pprDictsInFull :: [Inst] -> SDoc +-- Print in type-like fashion, but with source location +pprDictsInFull dicts + = vcat (map go dicts) where - go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))] + go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))] -pprInst (LitInst u lit ty loc) - = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u] +pprInsts :: [Inst] -> SDoc +-- Debugging: print the evidence :: type +pprInsts insts = brackets (interpp'SP insts) -pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u +pprInst, pprInstInFull :: Inst -> SDoc +-- Debugging: print the evidence :: type +pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty +pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred -pprInst m@(Method u id tys theta tau loc) - = hsep [ppr id, ptext SLIT("at"), - brackets (sep (map pprParendType tys)) {- , - ptext SLIT("theta"), ppr theta, - ptext SLIT("tau"), ppr tau - show_uniq u, - ppr (instToId m) -}] +pprInst m@(Method inst_id id tys theta tau loc) + = ppr inst_id <+> dcolon <+> + braces (sep [ppr id <+> ptext SLIT("at"), + brackets (sep (map pprParendType tys))]) +pprInstInFull inst + = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))] pprDFuns :: [DFunId] -> SDoc -- Prints the dfun as an instance declaration @@ -549,7 +564,7 @@ showLIE :: SDoc -> TcM () -- Debugging showLIE str = do { lie_var <- getLIEVar ; lie <- readMutVar lie_var ; - traceTc (str <+> pprInstsInFull (lieToList lie)) } + traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) } \end{code} @@ -681,27 +696,17 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) -- Dictionaries lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - = do { dflags <- getDOpts - ; if all tcIsTyVarTy tys && - not (dopt Opt_AllowUndecidableInstances dflags) - -- Common special case; no lookup - -- NB: tcIsTyVarTy... don't look through newtypes! - -- Don't take this short cut if we allow undecidable instances - -- because we might have "instance T a where ...". - -- [That means we need -fallow-undecidable-instances in the - -- client module, as well as the module with the instance decl.] - then return NoInstance - - else do - { pkg_ie <- loadImportedInsts clas tys + = do { pkg_ie <- loadImportedInsts clas tys -- Suck in any instance decls that may be relevant ; tcg_env <- getGblEnv + ; dflags <- getDOpts ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; (matches, unifs) -> do - { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches, - text "unifs" <+> ppr unifs]) - ; return NoInstance } } } } + { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches, + text "unifs" <+> ppr unifs]) + ; return NoInstance } } } -- In the case of overlap (multiple matches) we report -- NoInstance here. That has the effect of making the -- context-simplifier return the dict as an irreducible one. @@ -712,7 +717,10 @@ lookupInst (Dict _ _ _) = returnM NoInstance ----------------- instantiate_dfun tenv dfun_id pred loc - = -- Record that this dfun is needed + = traceTc (text "lookupInst success" <+> + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_` + -- Record that this dfun is needed record_dfun_usage dfun_id `thenM_` -- It's possible that not all the tyvars are in @@ -732,7 +740,10 @@ instantiate_dfun tenv dfun_id pred loc in mappM mk_ty_arg tyvars `thenM` \ ty_args -> let - dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho + dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho + -- Since the tyvars are freshly made, + -- they cannot possibly be captured by + -- any existing for-alls. Hence mkTopTyVarSubst (theta, _) = tcSplitPhiTy dfun_rho ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args in @@ -755,10 +766,10 @@ record_dfun_usage dfun_id dfun_name = idName dfun_id tcGetInstEnvs :: TcM (InstEnv, InstEnv) --- Gets both the home-pkg inst env (includes module being compiled) --- and the external-package inst-env +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; - return (tcg_inst_env env, eps_inst_env eps) } + return (eps_inst_env eps, tcg_inst_env env) } \end{code} @@ -795,41 +806,42 @@ just use the expression inline. \begin{code} tcSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at - -> (Name, LHsExpr Name) -- (Standard name, user name) - -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) + -> (Name, HsExpr Name) -- (Standard name, user name) + -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) -- NB: tcSyntaxName calls tcExpr, and hence can do unification. -- So we do not call it from lookupInst, which is called from tcSimplify -tcSyntaxName orig ty (std_nm, L span (HsVar user_nm)) +tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm - = addSrcSpan span (tcStdSyntaxName orig ty std_nm) + = tcStdSyntaxName orig ty std_nm tcSyntaxName orig ty (std_nm, user_nm_expr) = tcLookupId std_nm `thenM` \ std_id -> let -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - tau1 = substTyWith [tv] [ty] tau + sigma1 = substTyWith [tv] [ty] tau -- Actually, the "tau-type" might be a sigma-type in the -- case of locally-polymorphic methods. in - addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $ + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ -- Check that the user-supplied thing has the - -- same type as the standard one - tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> - returnM (std_nm, expr) + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + getSrcSpanM `thenM` \ span -> + tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr -> + returnM (std_nm, unLoc expr) tcStdSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at -> Name -- Standard name - -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) + -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) tcStdSyntaxName orig ty std_nm = newMethodFromName orig ty std_nm `thenM` \ id -> - getSrcSpanM `thenM` \ span -> - returnM (std_nm, L span (HsVar id)) + returnM (std_nm, HsVar id) syntaxNameCtxt name orig ty tidy_env = getInstLoc orig `thenM` \ inst_loc ->