Commit 2ddea0a8 authored by simonpj's avatar simonpj

[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).
parent 94f8d8ae
......@@ -216,6 +216,9 @@ knownKeyNames
andName,
orName
]
monadNames :: [Name] -- The monad ops need by a HsDo
monadNames = [returnMName, failMName, bindMName, thenMName]
\end{code}
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment