X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=f27a78255542fb0f2b6d03b7cb0d885f2d053a5c;hb=5f553f0c0508cb09b75f78e6c2ac1baa4c01b6aa;hp=11d41a41a0ccea93a3c2926d8d1e23784fe5996d;hpb=34c2b0252cd496d5db5113bbe1b4ca0b18dec946;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 11d41a4..f27a782 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -5,8 +5,6 @@ \begin{code} module Inst ( - LIE, emptyLIE, unitLIE, plusLIE, consLIE, - plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, showLIE, Inst, @@ -40,10 +38,11 @@ module Inst ( #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcCheckSigma ) +import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh) -import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) -import TcHsSyn ( TcExpr, TcId, TcIdSet, - mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, +import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp ) +import TcHsSyn ( TcId, TcIdSet, + mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, mkCoercion, ExprCoFn ) import TcRnMonad @@ -54,7 +53,7 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - PredType(..), TyVarDetails(VanillaTv), + PredType(..), TyVarDetails(VanillaTv), typeKind, tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, @@ -63,8 +62,10 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, isClassPred, isTyVarClassPred, isLinearPred, getClassPredTys, getClassPredTys_maybe, mkPredName, isInheritablePred, isIPPred, matchTys, - tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy + tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, + pprPred, pprParendType, pprThetaArrow, pprClassPred ) +import Kind ( isSubKind ) import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon,dataConSig ) @@ -72,17 +73,17 @@ 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 PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred ) import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) import Literal ( inIntRange ) -import Var ( TyVar ) +import Var ( TyVar, tyVarKind ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) -import CmdLineOpts( DynFlags ) +import SrcLoc ( mkSrcSpan, noLoc, Located(..) ) +import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) import Maybes ( isJust ) import Outputable \end{code} @@ -245,11 +246,12 @@ newDictsAtLoc inst_loc theta newIPDict :: InstOrigin -> IPName Name -> Type -> TcM (IPName Id, Inst) newIPDict orig ip_name ty - = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) -> + = getInstLoc orig `thenM` \ inst_loc -> newUnique `thenM` \ uniq -> let pred = IParam ip_name ty - id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred) + name = mkPredName uniq (instLocSrcLoc inst_loc) pred + id = mkLocalId name (mkPredTy pred) in returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc) \end{code} @@ -270,7 +272,7 @@ tcInstCall orig fun_ty -- fun_ty is usually a sigma-type newDicts orig theta `thenM` \ dicts -> extendLIEs dicts `thenM_` let - inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts) + inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts) in returnM (mkCoercion inst_fn, tau) @@ -329,6 +331,11 @@ newMethodWithGivenTy orig id tys theta tau -- This is important because they are used by TcSimplify -- to simplify Insts +-- NB: the kind of the type variable to be instantiated +-- might be a sub-kind of the type to which it is applied, +-- notably when the latter is a type variable of kind ?? +-- Hence the call to checkKind +-- A worry: is this needed anywhere else? tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst tcInstClassOp inst_loc sel_id tys = let @@ -337,8 +344,21 @@ tcInstClassOp inst_loc sel_id tys substTyWith tyvars tys rho (preds,tau) = tcSplitPhiTy rho_ty in + zipWithM_ checkKind tyvars tys `thenM_` newMethod inst_loc sel_id tys preds tau +checkKind :: TyVar -> TcType -> TcM () +-- Ensure that the type has a sub-kind of the tyvar +checkKind tv ty + = do { ty1 <- zonkTcType ty + ; if typeKind ty1 `isSubKind` tyVarKind tv + then return () + else do + { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty) + ; tv1 <- tcInstTyVar VanillaTv tv + ; unifyTauTy (mkTyVarTy tv1) ty1 }} + + --------------------------- newMethod inst_loc id tys theta tau = newUnique `thenM` \ new_uniq -> @@ -359,14 +379,15 @@ cases (the rest are caught in lookupInst). newOverloadedLit :: InstOrigin -> HsOverLit -> TcType - -> TcM TcExpr + -> TcM (LHsExpr TcId) newOverloadedLit orig lit@(HsIntegral i fi) expected_ty - | fi /= fromIntegerName -- Do not generate a LitInst for rebindable - -- syntax. Reason: tcSyntaxName does unification + | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax. + -- Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify - = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> - mkIntegerLit i `thenM` \ integer_lit -> - returnM (HsApp expr integer_lit) + -- ToDo: noLoc sadness + = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) -> + mkIntegerLit i `thenM` \ integer_lit -> + returnM (mkHsApp expr integer_lit) | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -376,9 +397,9 @@ 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, HsVar fr) `thenM` \ (_,expr) -> - mkRatLit r `thenM` \ rat_lit -> - returnM (HsApp expr rat_lit) + = tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) -> + mkRatLit r `thenM` \ rat_lit -> + returnM (mkHsApp expr rat_lit) | Just expr <- shortCutFracLit r expected_ty = returnM expr @@ -386,6 +407,7 @@ newOverloadedLit orig lit@(HsFractional r fr) expected_ty | otherwise = newLitInst orig lit expected_ty +newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId) newLitInst orig lit expected_ty = getInstLoc orig `thenM` \ loc -> newUnique `thenM` \ new_uniq -> @@ -394,17 +416,17 @@ newLitInst orig lit expected_ty lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty in extendLIE lit_inst `thenM_` - returnM (HsVar (instToId lit_inst)) + returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst))) -shortCutIntLit :: Integer -> TcType -> Maybe TcExpr +shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-) shortCutIntLit i ty | isIntTy ty && inIntRange i -- Short cut for Int - = Just (HsLit (HsInt i)) + = Just (noLoc (HsLit (HsInt i))) | isIntegerTy ty -- Short cut for Integer - = Just (HsLit (HsInteger i ty)) + = Just (noLoc (HsLit (HsInteger i ty))) | otherwise = Nothing -shortCutFracLit :: Rational -> TcType -> Maybe TcExpr +shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-) shortCutFracLit f ty | isFloatTy ty = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)]) @@ -412,15 +434,17 @@ shortCutFracLit f ty = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) | otherwise = Nothing -mkIntegerLit :: Integer -> TcM TcExpr +mkIntegerLit :: Integer -> TcM (LHsExpr TcId) mkIntegerLit i = tcMetaTy integerTyConName `thenM` \ integer_ty -> - returnM (HsLit (HsInteger i integer_ty)) + getSrcSpanM `thenM` \ span -> + returnM (L span $ HsLit (HsInteger i integer_ty)) -mkRatLit :: Rational -> TcM TcExpr +mkRatLit :: Rational -> TcM (LHsExpr TcId) mkRatLit r = tcMetaTy rationalTyConName `thenM` \ rat_ty -> - returnM (HsLit (HsRat r rat_ty)) + getSrcSpanM `thenM` \ span -> + returnM (L span $ HsLit (HsRat r rat_ty)) \end{code} @@ -540,40 +564,40 @@ tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns - ; eps <- getEps ; env <- getGblEnv ; dflags <- getDOpts - ; inst_env' <- foldlM (extend dflags (eps_inst_env eps)) - (tcg_inst_env env) - dfuns + ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } - where - extend dflags pkg_ie home_ie dfun - = do { checkNewInst dflags (home_ie, pkg_ie) dfun - ; return (extendInstEnv home_ie dfun) } -checkNewInst :: DynFlags -> (InstEnv, InstEnv) -> DFunId -> TcM () --- Check that the proposed new instance is OK -checkNewInst dflags ies dfun - = do { -- Check functional dependencies - case checkFunDeps ies dfun of +addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +addInst dflags home_ie dfun + = do { -- Load imported instances, so that we report + -- duplicates correctly + pkg_ie <- loadImportedInsts cls tys + + -- Check functional dependencies + ; case checkFunDeps (pkg_ie, home_ie) dfun of Just dfuns -> funDepErr dfun dfuns Nothing -> return () -- Check for duplicate instance decls + ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys + ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches, + isJust (matchTys (mkVarSet tvs) tys dup_tys)] } + -- Find memebers of the match list which + -- dfun itself matches. If the match is 2-way, it's a duplicate ; case dup_dfuns of dup_dfun : _ -> dupInstErr dfun dup_dfun [] -> return () - } + + -- OK, now extend the envt + ; return (extendInstEnv home_ie dfun) } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) - (matches, _) = lookupInstEnv dflags ies cls tys - dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches, - isJust (matchTys (mkVarSet tvs) tys dup_tys)] - -- Find memebers of the match list which - -- dfun itself matches. If the match is 2-way, it's a duplicate traceDFuns dfuns = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) @@ -581,13 +605,18 @@ traceDFuns dfuns pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) funDepErr dfun dfuns - = addSrcLoc (getSrcLoc dfun) $ + = addDictLoc dfun $ addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) 2 (pprDFuns (dfun:dfuns))) dupInstErr dfun dup_dfun - = addSrcLoc (getSrcLoc dfun) $ + = addDictLoc dfun $ addErr (hang (ptext SLIT("Duplicate instance declarations:")) 2 (pprDFuns [dfun, dup_dfun])) + +addDictLoc dfun thing_inside + = addSrcSpan (mkSrcSpan loc loc) thing_inside + where + loc = getSrcLoc dfun \end{code} %************************************************************************ @@ -599,8 +628,8 @@ dupInstErr dfun dup_dfun \begin{code} data LookupInstResult s = NoInstance - | SimpleInst TcExpr -- Just a variable, type application, or literal - | GenInst [Inst] TcExpr -- The expression and its needed insts + | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal + | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts lookupInst :: Inst -> TcM (LookupInstResult s) -- It's important that lookupInst does not put any new stuff into @@ -612,7 +641,9 @@ lookupInst :: Inst -> TcM (LookupInstResult s) lookupInst inst@(Method _ id tys theta _ loc) = newDictsAtLoc loc theta `thenM` \ dicts -> - returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts))) + returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts))) + where + span = instLocSrcSpan loc -- Literals @@ -633,7 +664,8 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (HsApp (HsVar (instToId method_inst)) integer_lit)) + (mkHsApp (L (instLocSrcSpan loc) + (HsVar (instToId method_inst))) integer_lit)) lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | Just expr <- shortCutFracLit f ty @@ -644,25 +676,32 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) tcLookupId fromRationalName `thenM` \ from_rational -> tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> - returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) + returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) + (HsVar (instToId method_inst))) rat_lit)) -- Dictionaries lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - | all tcIsTyVarTy tys -- Common special case; no lookup - -- NB: tcIsTyVarTy... don't look through newtypes! - = returnM NoInstance - - | otherwise - = do { pkg_ie <- loadImportedInsts clas tys + = 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 -- 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 } } } + ; 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. @@ -695,7 +734,7 @@ instantiate_dfun tenv dfun_id pred loc let dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho (theta, _) = tcSplitPhiTy dfun_rho - ty_app = mkHsTyApp (HsVar dfun_id) ty_args + ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args in if null theta then returnM (SimpleInst ty_app) @@ -756,15 +795,15 @@ just use the expression inline. \begin{code} tcSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at - -> (Name, HsExpr Name) -- (Standard name, user name) - -> TcM (Name, TcExpr) -- (Standard name, suitable expression) + -> (Name, LHsExpr Name) -- (Standard name, user name) + -> TcM (Name, LHsExpr 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, HsVar user_nm) +tcSyntaxName orig ty (std_nm, L span (HsVar user_nm)) | std_nm == user_nm - = tcStdSyntaxName orig ty std_nm + = addSrcSpan span (tcStdSyntaxName orig ty std_nm) tcSyntaxName orig ty (std_nm, user_nm_expr) = tcLookupId std_nm `thenM` \ std_id -> @@ -779,17 +818,18 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) -- Check that the user-supplied thing has the -- same type as the standard one - tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> + tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> returnM (std_nm, expr) tcStdSyntaxName :: InstOrigin - -> TcType -- Type to instantiate it at - -> Name -- Standard name - -> TcM (Name, TcExpr) -- (Standard name, suitable expression) + -> TcType -- Type to instantiate it at + -> Name -- Standard name + -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) tcStdSyntaxName orig ty std_nm = newMethodFromName orig ty std_nm `thenM` \ id -> - returnM (std_nm, HsVar id) + getSrcSpanM `thenM` \ span -> + returnM (std_nm, L span (HsVar id)) syntaxNameCtxt name orig ty tidy_env = getInstLoc orig `thenM` \ inst_loc ->