X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=a6d92a9c1bbc46a93f3f630a324d1c72a22e080c;hb=2c8701fbebc0a6a49248392b53d977f0afdea4ec;hp=c34bf6d2409d8d21dc6ad99fe438b482b72b4dc5;hpb=ea2d0a53ff4ca7e6331d09225ad84ec9c9efe6d8;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index c34bf6d..a6d92a9 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,7 +26,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, getDictClassTys, dictPred, - lookupSimpleInst, LookupInstResult(..), lookupPred, + lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, isDict, isClassDict, isMethod, isImplicInst, @@ -44,6 +44,7 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcPolyExpr ) import {-# SOURCE #-} TcUnify( unifyType ) +import FastString(FastString) import HsSyn import TcHsSyn import TcRnMonad @@ -83,7 +84,7 @@ Selection ~~~~~~~~~ \begin{code} instName :: Inst -> Name -instName inst = idName (instToId inst) +instName inst = Var.varName (instToVar inst) instToId :: Inst -> TcId instToId inst = ASSERT2( isId id, ppr inst ) id @@ -161,12 +162,14 @@ ipNamesOfInst other = [] tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred -tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id +tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds}) - = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs - + = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) + `minusVarSet` mkVarSet tvs + `unionVarSet` unionVarSets (map varTypeTyVars tvs) + -- Remember the free tyvars of a coercion tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) @@ -329,9 +332,15 @@ mkPredName uniq loc pred_ty = mkInternalName uniq occ (srcSpanStart (instLocSpan loc)) where occ = case pred_ty of - ClassP cls tys -> mkDictOcc (getOccName cls) - IParam ip ty -> getOccName (ipNameName ip) - EqPred _ _ -> pprPanic "mkPredName" (ppr pred_ty) + ClassP cls _ -> mkDictOcc (getOccName cls) + IParam ip _ -> getOccName (ipNameName ip) + EqPred ty _ -> mkEqPredCoOcc baseOcc + where + -- we use the outermost tycon of the lhs, if there is one, to + -- improve readability of Core code + baseOcc = case splitTyConApp_maybe ty of + Nothing -> mkOccName tcName "$" + Just (tc, _) -> getOccName tc \end{code} %************************************************************************ @@ -428,6 +437,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 -> @@ -440,6 +455,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 @@ -602,7 +623,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. @@ -707,24 +728,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 @@ -733,19 +755,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 = map (substTyVar tenv') tyvars ; if null theta then returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do @@ -755,14 +773,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, @@ -770,7 +788,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" <+>