X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=04dd4a28cc8734d62c8a837118510c2de88eac5e;hb=0f22eb9f85ca54f2545f64c43983c7d4a105420c;hp=a11efe05919dc26dfe1f66edf931f1b703028083;hpb=8ffdb8eed6b38db00761093889f5cddbe8ca1d60;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a11efe0..04dd4a2 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -17,7 +17,7 @@ module Inst ( newDictBndr, newDictBndrs, newDictBndrsO, instCall, instStupidTheta, cloneDict, - shortCutFracLit, shortCutIntLit, newIPDict, + shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcSyntaxName, isHsVar, @@ -26,12 +26,12 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, getDictClassTys, dictPred, - lookupSimpleInst, LookupInstResult(..), lookupPred, + lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, isDict, isClassDict, isMethod, isImplicInst, isIPDict, isInheritableInst, isMethodOrLit, - isTyVarDict, isMethodFor, getDefaultableDicts, + isTyVarDict, isMethodFor, zonkInst, zonkInsts, instToId, instToVar, instName, @@ -44,6 +44,7 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcPolyExpr ) import {-# SOURCE #-} TcUnify( unifyType ) +import FastString(FastString) import HsSyn import TcHsSyn import TcRnMonad @@ -53,7 +54,6 @@ import FunDeps import TcMType import TcType import Type -import Class import Unify import Module import Coercion @@ -76,6 +76,8 @@ import DynFlags import Maybes import Util import Outputable + +import Data.List \end{code} @@ -210,26 +212,6 @@ isMethodOrLit (LitInst {}) = True isMethodOrLit other = False \end{code} -\begin{code} -getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet) --- Look for free dicts of the form (C tv), even inside implications --- *and* the set of tyvars mentioned by all *other* constaints --- This disgustingly ad-hoc function is solely to support defaulting -getDefaultableDicts insts - = (concat ps, unionVarSets tvs) - where - (ps, tvs) = mapAndUnzip get insts - get d@(Dict {tci_pred = ClassP cls [ty]}) - | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet) - | otherwise = ([], tyVarsOfType ty) - get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds}) - = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)], - ftvs `minusVarSet` tv_set) - where - tv_set = mkVarSet tvs - (ups, ftvs) = getDefaultableDicts wanteds - get inst = ([], tyVarsOfInst inst) -\end{code} %************************************************************************ %* * @@ -302,7 +284,7 @@ instCallDicts loc (pred : preds) ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) } ------------- -cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params +cloneDict :: Inst -> TcM Inst cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique ; return (dict {tci_name = setNameUnique nm uniq}) } cloneDict other = pprPanic "cloneDict" (ppr other) @@ -328,7 +310,7 @@ newIPDict orig ip_name ty \begin{code} mkPredName :: Unique -> InstLoc -> PredType -> Name mkPredName uniq loc pred_ty - = mkInternalName uniq occ (srcSpanStart (instLocSpan loc)) + = mkInternalName uniq occ (instLocSpan loc) where occ = case pred_ty of ClassP cls _ -> mkDictOcc (getOccName cls) @@ -412,7 +394,7 @@ newMethod inst_loc id tys meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = inst_loc} - loc = srcSpanStart (instLocSpan inst_loc) + loc = instLocSpan inst_loc in returnM inst \end{code} @@ -436,6 +418,12 @@ shortCutFracLit f ty where mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) +shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId) +shortCutStringLit s ty + | isStringTy ty -- Short cut for String + = Just (HsLit (HsString s)) + | otherwise = Nothing + mkIntegerLit :: Integer -> TcM (LHsExpr TcId) mkIntegerLit i = tcMetaTy integerTyConName `thenM` \ integer_ty -> @@ -448,6 +436,12 @@ mkRatLit r getSrcSpanM `thenM` \ span -> returnM (L span $ HsLit (HsRat r rat_ty)) +mkStrLit :: FastString -> TcM (LHsExpr TcId) +mkStrLit s + = --tcMetaTy stringTyConName `thenM` \ string_ty -> + getSrcSpanM `thenM` \ span -> + returnM (L span $ HsLit (HsString s)) + isHsVar :: HsExpr Name -> Name -> Bool isHsVar (HsVar f) g = f==g isHsVar other g = False @@ -610,7 +604,7 @@ addLocalInst home_ie ispec -- Check for duplicate instance decls ; let { (matches, _) = lookupInstEnv inst_envs cls tys' ; dup_ispecs = [ dup_ispec - | (_, dup_ispec) <- matches + | (dup_ispec, _) <- matches , let (_,_,_,dup_tys) = instanceHead dup_ispec , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } -- Find memebers of the match list which ispec itself matches. @@ -667,7 +661,7 @@ data LookupInstResult | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts lookupSimpleInst :: Inst -> TcM LookupInstResult --- This is "simple" in tthat it returns NoInstance for implication constraints +-- This is "simple" in that it returns NoInstance for implication constraints -- It's important that lookupInst does not put any new stuff into -- the LIE. Instead, any Insts needed by the lookup are returned in @@ -715,24 +709,25 @@ lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) rat_lit)) +lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc}) + | Just expr <- shortCutStringLit s ty + = returnM (GenInst [] (noLoc expr)) + | otherwise + = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant + tcLookupId fromStringName `thenM` \ from_string -> + tcInstClassOp loc from_string [ty] `thenM` \ method_inst -> + mkStrLit s `thenM` \ string_lit -> + returnM (GenInst [method_inst] + (mkHsApp (L (instLocSpan loc) + (HsVar (instToId method_inst))) string_lit)) + --------------------- Dictionaries ------------------------ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) = do { mb_result <- lookupPred pred ; case mb_result of { Nothing -> return NoInstance ; - Just (tenv, dfun_id) -> do - - -- tenv is a substitution that instantiates the dfun_id - -- to match the requested result type. - -- - -- We ASSUME that the dfun is quantified over the very same tyvars - -- that are bound by the tenv. - -- - -- However, the dfun - -- might have some tyvars that *only* appear in arguments - -- dfun :: forall a b. C a b, Ord b => D [a] - -- We instantiate b to a flexi type variable -- it'll presumably - -- become fixed later via functional dependencies + Just (dfun_id, mb_inst_tys) -> do + { use_stage <- getStage ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) (topIdLvl dfun_id) use_stage @@ -741,19 +736,15 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) -- the substitution, tenv. For example: -- instance C X a => D X where ... -- (presumably there's a functional dependency in class C) - -- Hence the open_tvs to instantiate any un-substituted tyvars. - ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - open_tvs = filter (`notElemTvSubst` tenv) tyvars - ; open_tvs' <- mappM tcInstTyVar open_tvs + -- Hence mb_inst_tys :: Either TyVar TcType + + ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') } + inst_tv (Right ty) = return ty + ; tys <- mappM inst_tv mb_inst_tys ; let - tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs') - -- Since the open_tvs' are freshly made, they cannot possibly be captured by - -- any nested for-alls in rho. So the in-scope set is unchanged - dfun_rho = substTy tenv' rho - (theta, _) = tcSplitPhiTy dfun_rho + (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) src_loc = instLocSpan loc dfun = HsVar dfun_id - tys = substTyVars tenv' tyvars ; if null theta then returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do @@ -763,14 +754,14 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) }}}} --------------- -lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId)) +lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType])) -- Look up a class constraint in the instance environment lookupPred pred@(ClassP clas tys) = do { eps <- getEps ; tcg_env <- getGblEnv ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env) ; case lookupInstEnv inst_envs clas tys of { - ([(tenv, ispec)], []) + ([(ispec, inst_tys)], []) -> do { let dfun_id = is_dfun ispec ; traceTc (text "lookupInst success" <+> vcat [text "dict" <+> ppr pred, @@ -778,7 +769,7 @@ lookupPred pred@(ClassP clas tys) <+> ppr (idType dfun_id) ]) -- Record that this dfun is needed ; record_dfun_usage dfun_id - ; return (Just (tenv, dfun_id)) } ; + ; return (Just (dfun_id, inst_tys)) } ; (matches, unifs) -> do { traceTc (text "lookupInst fail" <+>