andName,
orName
]
+
+monadNames :: [Name] -- The monad ops need by a HsDo
+monadNames = [returnMName, failMName, bindMName, thenMName]
\end{code}
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}
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 )
= 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) ->
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) ->
-- 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.
-- 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}
%************************************************************************
newDictsFromOld, newDicts, cloneDict,
newMethod, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc,
- newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon,
+ newOverloadedLit, newIPDict,
+ tcInstCall, tcInstDataCon, tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
#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
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 )
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 )
| 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}
-> 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_`
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}
-- [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
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}
#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, (<$>),
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethodFromName, newIPDict,
- newDicts, newMethodWithGivenTy,
+ newDicts, newMethodWithGivenTy, tcSyntaxName,
instToId, tcInstCall, tcInstDataCon
)
import TcBinds ( tcBindsAndThen )
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
)
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
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,
-- 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}
%************************************************************************
%* *
= 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)
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
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 )
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
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
projects / ghc-hetmet.git / commitdiff