From: simonpj Date: Mon, 29 Jul 2002 12:22:38 +0000 (+0000) Subject: [project @ 2002-07-29 12:22:37 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1793 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2ddea0a849e8873f7943d9b32e501f6324e2e18b;p=ghc-hetmet.git [project @ 2002-07-29 12:22:37 by simonpj] *** MERGE TO STABLE BRANCH *** Surprisingly large delta to make rebindable names work properly. I was sloppily not checking the type of the user-supplied name, and Ashley Yakeley's first experiment showed up the problem! Solution: typechecker has to check both the 'standard' name and the 'user' name and check the latter has a type compatible with the former. The main comment is with Inst.tcSyntaxName (a new function). --- diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index b371077..1dbf7aa 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -216,6 +216,9 @@ knownKeyNames andName, orName ] + +monadNames :: [Name] -- The monad ops need by a HsDo +monadNames = [returnMName, failMName, bindMName, thenMName] \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 59c1b51..3e8dd5b 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -620,22 +620,27 @@ respectively. Initially, we just store the "standard" name (PrelNames.fromInteg fromRationalName etc), but the renamer changes this to the appropriate user name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. +We treat the orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. + \begin{code} -lookupSyntaxName :: Name -- The standard name - -> RnMS Name -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnMS (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name = getModeRn `thenRn` \ mode -> case mode of { - InterfaceMode -> returnRn std_name ; -- Happens for 'derived' code - -- where we don't want to rebind + InterfaceMode -> returnRn (std_name, unitFV std_name) ; + -- Happens for 'derived' code + -- where we don't want to rebind other -> doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> if not no_prelude then - returnRn std_name -- Normal case + returnRn (std_name, unitFV std_name) -- Normal case else -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) } + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenRn` \ usr_name -> + returnRn (usr_name, mkFVs [usr_name, std_name]) } \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index bc63e44..3992a64 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -41,7 +41,7 @@ import PrelNames ( hasKey, assertIdKey, zipPName, lengthPName, indexPName, toPName, enumFromToPName, enumFromThenToPName, fromIntegerName, fromRationalName, minusName, negateName, - failMName, bindMName, thenMName, returnMName ) + monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) @@ -96,19 +96,19 @@ rnPat (NPatIn lit mb_neg) = rnOverLit lit `thenRn` \ (lit', fvs1) -> (case mb_neg of Nothing -> returnRn (Nothing, emptyFVs) - Just _ -> lookupSyntaxName negateName `thenRn` \ neg -> - returnRn (Just neg, unitFV neg) + Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) -> + returnRn (Just neg, fvs) ) `thenRn` \ (mb_neg', fvs2) -> returnRn (NPatIn lit' mb_neg', fvs1 `plusFV` fvs2 `addOneFV` eqClassName) -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit _) - = rnOverLit lit `thenRn` \ (lit', fvs) -> + = rnOverLit lit `thenRn` \ (lit', fvs1) -> lookupBndrRn name `thenRn` \ name' -> - lookupSyntaxName minusName `thenRn` \ minus -> + lookupSyntaxName minusName `thenRn` \ (minus, fvs2) -> returnRn (NPlusKPatIn name' lit' minus, - fvs `addOneFV` ordClassName `addOneFV` minus) + fvs1 `plusFV` fvs2 `addOneFV` ordClassName) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -343,9 +343,9 @@ rnExpr (OpApp e1 op _ e2) rnExpr (NegApp e _) = rnExpr e `thenRn` \ (e', fv_e) -> - lookupSyntaxName negateName `thenRn` \ neg_name -> + lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) -> mkNegAppRn e' neg_name `thenRn` \ final_e -> - returnRn (final_e, fv_e `addOneFV` neg_name) + returnRn (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -405,20 +405,20 @@ rnExpr e@(HsDo do_or_lc stmts _ ty src_loc) -- Generate the rebindable syntax for the monad (case do_or_lc of - DoExpr -> mapRn lookupSyntaxName monad_names - other -> returnRn [] - ) `thenRn` \ monad_names' -> + DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames + other -> returnRn ([], []) + ) `thenRn` \ (monad_names', monad_fvs) -> returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, - fvs `plusFV` implicit_fvs) + fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs) where - monad_names = [returnMName, failMName, bindMName, thenMName] - implicit_fvs = case do_or_lc of PArrComp -> mkFVs [replicatePName, mapPName, filterPName, falseDataConName, trueDataConName, crossPName, zipPName] - _ -> mkFVs [foldrName, buildName, monadClassName] + ListComp -> mkFVs [foldrName, buildName] + other -> emptyFVs + -- monadClassName pulls in the standard names -- Monad stuff should not be necessary for a list comprehension -- but the typechecker looks up the bind and return Ids anyway -- Oh well. @@ -859,32 +859,32 @@ litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat on -- in post-typechecker translations rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenRn` \ from_integer_name -> + = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) -> if inIntRange i then - returnRn (HsIntegral i from_integer_name, unitFV from_integer_name) + returnRn (HsIntegral i from_integer_name, fvs) else let - fvs = mkFVs [plusIntegerName, timesIntegerName] + extra_fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, -- out of small integers (DsUtils.mkIntegerLit) -- [NB: plusInteger, timesInteger aren't rebindable... -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] in - returnRn (HsIntegral i from_integer_name, fvs `addOneFV` from_integer_name) + returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenRn` \ from_rat_name -> + = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) -> let - fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] + extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. -- The Rational type is needed too, but that will come in - -- when fractionalClass does. + -- as part of the type for fromRational. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) in - returnRn (HsFractional i from_rat_name, fvs `addOneFV` from_rat_name) + returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7cb4a7f..e24e440 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -13,7 +13,8 @@ module Inst ( newDictsFromOld, newDicts, cloneDict, newMethod, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc, - newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon, + newOverloadedLit, newIPDict, + tcInstCall, tcInstDataCon, tcSyntaxName, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts, @@ -34,12 +35,14 @@ module Inst ( #include "HsVersions.h" +import {-# SOURCE #-} TcExpr( tcExpr ) + import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) import TcHsSyn ( TcExpr, TcId, TypecheckedHsExpr, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId ) +import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId, tcLookupGlobalId, tcLookupTyCon ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars @@ -47,14 +50,14 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet, SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv), tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, - tcSplitMethodTy, tcSplitPhiTy, tcFunArgTy, + tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, getClassPredTys, getClassPredTys_maybe, mkPredName, - tidyType, tidyTypes, tidyFreeTyVars, - tcCmpType, tcCmpTypes, tcCmpPred + tidyType, tidyTypes, tidyFreeTyVars, + tcCmpType, tcCmpTypes, tcCmpPred, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) @@ -70,7 +73,7 @@ import Literal ( inIntRange ) import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) -import PrelNames( fromIntegerName, fromRationalName ) +import PrelNames( fromIntegerName, fromRationalName, rationalTyConName ) import Util ( thenCmp, equalLength ) import BasicTypes( IPName(..), mapIPName, ipNameName ) @@ -158,6 +161,9 @@ data Inst | LitInst Id HsOverLit -- The literal from the occurrence site + -- INVARIANT: never a rebindable-syntax literal + -- Reason: tcSyntaxName does unification, and we + -- don't want to deal with that during tcSimplify TcType -- The type at which the literal is used InstLoc \end{code} @@ -450,11 +456,32 @@ newOverloadedLit :: InstOrigin -> HsOverLit -> TcType -> NF_TcM (TcExpr, LIE) -newOverloadedLit orig lit expected_ty - | Just expr <- shortCutLit lit expected_ty +newOverloadedLit orig lit@(HsIntegral i fi) expected_ty + | 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 fi `thenTc` \ (expr, lie, _) -> + returnTc (HsApp expr (HsLit (HsInteger i)), lie) + + | Just expr <- shortCutIntLit i expected_ty + = returnNF_Tc (expr, emptyLIE) + + | otherwise + = newLitInst orig lit expected_ty + +newOverloadedLit orig lit@(HsFractional r fr) expected_ty + | fr /= fromRationalName -- c.f. HsIntegral case + = tcSyntaxName orig expected_ty fromRationalName fr `thenTc` \ (expr, lie, _) -> + mkRatLit r `thenNF_Tc` \ rat_lit -> + returnTc (HsApp expr rat_lit, lie) + + | Just expr <- shortCutFracLit r expected_ty = returnNF_Tc (expr, emptyLIE) | otherwise + = newLitInst orig lit expected_ty + +newLitInst orig lit expected_ty = tcGetInstLoc orig `thenNF_Tc` \ loc -> tcGetUnique `thenNF_Tc` \ new_uniq -> zapToType expected_ty `thenNF_Tc_` @@ -466,21 +493,29 @@ newOverloadedLit orig lit expected_ty in returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst) -shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr -shortCutLit (HsIntegral i fi) ty - | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int +shortCutIntLit :: Integer -> TcType -> Maybe TcExpr +shortCutIntLit i ty + | isIntTy ty && inIntRange i -- Short cut for Int = Just (HsLit (HsInt i)) - | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer + | isIntegerTy ty -- Short cut for Integer = Just (HsLit (HsInteger i)) + | otherwise = Nothing -shortCutLit (HsFractional f fr) ty - | isFloatTy ty && fr == fromRationalName +shortCutFracLit :: Rational -> TcType -> Maybe TcExpr +shortCutFracLit f ty + | isFloatTy ty = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)]) - | isDoubleTy ty && fr == fromRationalName + | isDoubleTy ty = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) + | otherwise = Nothing -shortCutLit lit ty - = Nothing +mkRatLit :: Rational -> NF_TcM TcExpr +mkRatLit r + = tcLookupTyCon rationalTyConName `thenNF_Tc` \ rat_tc -> + let + rational_ty = mkGenTyConApp rat_tc [] + in + returnNF_Tc (HsLit (HsRat r rational_ty)) \end{code} @@ -633,26 +668,28 @@ lookupInst inst@(Method _ id tys theta _ loc) -- [Same shortcut as in newOverloadedLit, but we -- may have done some unification by now] -lookupInst inst@(LitInst u lit ty loc) - | Just expr <- shortCutLit lit ty +lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) + | Just expr <- shortCutIntLit i ty = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because -- expr may be a constructor application - -lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) - = tcLookupId from_integer_name `thenNF_Tc` \ from_integer -> + | otherwise + = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant + tcLookupGlobalId fromIntegerName `thenNF_Tc` \ from_integer -> newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnNF_Tc (GenInst [method_inst] + returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) (HsLit (HsInteger i)))) lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) - = tcLookupId from_rat_name `thenNF_Tc` \ from_rational -> + | Just expr <- shortCutFracLit f ty + = returnNF_Tc (GenInst [] expr) + + | otherwise + = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant + tcLookupGlobalId fromRationalName `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> - let - rational_ty = tcFunArgTy (idType method_id) - rational_lit = HsLit (HsRat f rational_ty) - in - returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) + mkRatLit f `thenNF_Tc` \ rat_lit -> + returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rat_lit)) \end{code} There is a second, simpler interface, when you want an instance of a @@ -677,3 +714,72 @@ lookupSimpleInst clas tys other -> returnNF_Tc Nothing \end{code} + + +%************************************************************************ +%* * + Re-mappable syntax +%* * +%************************************************************************ + + +Suppose we are doing the -fno-implicit-prelude thing, and we encounter +a do-expression. We have to find (>>) in the current environment, which is +done by the rename. Then we have to check that it has the same type as +Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had +this: + + (>>) :: HB m n mn => m a -> n b -> mn b + +So the idea is to generate a local binding for (>>), thus: + + let then72 :: forall a b. m a -> m b -> m b + then72 = ...something involving the user's (>>)... + in + ...the do-expression... + +Now the do-expression can proceed using then72, which has exactly +the expected type. + +In fact tcSyntaxName just generates the RHS for then72, because we only +want an actual binding in the do-expression case. For literals, we can +just use the expression inline. + +\begin{code} +tcSyntaxName :: InstOrigin + -> TcType -- Type to instantiate it at + -> Name -> Name -- (Standard name, user name) + -> TcM (TcExpr, LIE, TcType) -- Suitable expression with its type + +-- 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 user_nm + | std_nm == user_nm + = newMethodFromName orig ty std_nm `thenNF_Tc` \ inst -> + let + id = instToId inst + in + returnTc (HsVar id, unitLIE inst, idType id) + + | otherwise + = tcLookupGlobalId std_nm `thenNF_Tc` \ std_id -> + let + -- C.f. newMethodAtLoc + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau + in + tcAddErrCtxtM (syntaxNameCtxt user_nm orig tau1) $ + tcExpr (HsVar user_nm) tau1 `thenTc` \ (user_fn, lie) -> + returnTc (user_fn, lie, tau1) + +syntaxNameCtxt name orig ty tidy_env + = tcGetInstLoc orig `thenNF_Tc` \ inst_loc -> + let + msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> + ptext SLIT("(needed by a syntactic construct)"), + nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)), + nest 2 (pprInstLoc inst_loc)] + in + returnNF_Tc (tidy_env, msg) +\end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index b84b488..6475225 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,11 +9,12 @@ module TcExpr ( tcExpr, tcMonoExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsMatchContext(..), HsDoContext(..), - mkMonoBind + HsMatchContext(..), HsDoContext(..), MonoBinds(..), + mkMonoBind, andMonoBindList ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy, mkHsDictApp, mkHsTyApp ) +import TcHsSyn ( TcExpr, TcRecordBinds, TypecheckedMonoBinds, + simpleHsLitTy, mkHsDictApp, mkHsTyApp, mkHsLet ) import TcMonad import TcUnify ( tcSubExp, tcGen, (<$>), @@ -23,7 +24,7 @@ import BasicTypes ( RecFlag(..), isMarkedStrict ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, newMethodFromName, newIPDict, - newDicts, newMethodWithGivenTy, + newDicts, newMethodWithGivenTy, tcSyntaxName, instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) @@ -46,7 +47,8 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe ) +import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, + isDataConWrapId_maybe, mkSysLocal ) import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks ) @@ -55,12 +57,11 @@ import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) -import PrelNames ( cCallableClassName, - cReturnableClassName, +import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - ioTyConName + ioTyConName, monadNames ) import ListSetOps ( minusList ) import CmdLineOpts @@ -839,11 +840,11 @@ tcDoStmts ListComp stmts method_names src_loc res_ty stmts_lie) tcDoStmts DoExpr stmts method_names src_loc res_ty - = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ tc_ty -> + = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty -> newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy res_ty (mkAppTy tc_ty elt_ty) `thenTc_` + unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_` - tcStmts (DoCtxt DoExpr) (mkAppTy tc_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) -> + tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) -> -- Build the then and zero methods in case we need them -- It's important that "then" and "return" appear just once in the final LIE, @@ -853,14 +854,29 @@ tcDoStmts DoExpr stmts method_names src_loc res_ty -- then = then -- where the second "then" sees that it already exists in the "available" stuff. -- - mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts -> + mapNF_Tc (tc_syn_name m_ty) + (zipEqual "tcDoStmts" monadNames method_names) `thenNF_Tc` \ stuff -> + let + (binds, ids, lies) = unzip3 stuff + in - returnTc (HsDo DoExpr stmts' - (map instToId insts) + returnTc (mkHsLet (andMonoBindList binds) $ + HsDo DoExpr stmts' ids res_ty src_loc, - stmts_lie `plusLIE` mkLIE insts) -\end{code} + stmts_lie `plusLIE` plusLIEs lies) + where + tc_syn_name :: TcType -> (Name,Name) -> TcM (TypecheckedMonoBinds, Id, LIE) + tc_syn_name m_ty (std_nm, usr_nm) + = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenTc` \ (expr, lie, expr_ty) -> + case expr of + HsVar v -> returnTc (EmptyMonoBinds, v, lie) + other -> tcGetUnique `thenTc` \ uniq -> + let + id = mkSysLocal FSLIT("syn") uniq expr_ty + in + returnTc (VarMonoBind id expr, id, lie) +\end{code} %************************************************************************ %* * @@ -1016,6 +1032,14 @@ exprSigCtxt expr = hang (ptext SLIT("When checking the type signature of the expression:")) 4 (ppr expr) +exprCtxt expr + = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + +funAppCtxt fun arg arg_no + = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + quotes (ppr fun) <> text ", namely"]) + 4 (quotes (ppr arg)) + listCtxt expr = hang (ptext SLIT("In the list element:")) 4 (ppr expr) @@ -1025,14 +1049,6 @@ parrCtxt expr predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) - -funAppCtxt fun arg arg_no - = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), - quotes (ppr fun) <> text ", namely"]) - 4 (quotes (ppr arg)) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 548f710..8f2fd90 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,7 +17,8 @@ import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) import TcMonad import Inst ( InstOrigin(..), emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE, - newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon + newMethod, newMethodFromName, newOverloadedLit, newDicts, + tcInstDataCon, tcSyntaxName ) import Id ( mkLocalId, mkSysLocal ) import Name ( Name ) @@ -35,7 +36,7 @@ import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( dataConFieldLabels, dataConSourceArity ) -import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) +import PrelNames ( eqStringName, eqName, geName, minusName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable @@ -347,13 +348,13 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge -> -- The '-' part is re-mappable syntax - tcLookupId minus_name `thenNF_Tc` \ minus_sel_id -> - newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus -> + tcGetInstLoc origin `thenNF_Tc` \ loc -> + tcSyntaxName loc pat_ty minusName minus_name `thenTc` \ (minus_expr, minus_lie, _) -> returnTc (NPlusKPat bndr_id i pat_ty (SectionR (HsVar (instToId ge)) over_lit_expr) - (SectionR (HsVar (instToId minus)) over_lit_expr), - lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus], + (SectionR minus_expr over_lit_expr), + lie1 `plusLIE` lie2 `plusLIE` minus_lie `plusLIE` unitLIE ge, emptyBag, unitBag (name, bndr_id), emptyLIE) where origin = PatOrigin pat