From 3f885dcbddb15dc79246a7f1cd1872f7a60e3cbc Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 6 Apr 2004 09:29:51 +0000 Subject: [PATCH] [project @ 2004-04-06 09:29:49 by simonpj] The "rebindable-syntax" stuff wasn't dealing with the new location information correctly. This commit fixes the problem, and thereby makes mdofail004 work right. Maybe others too. --- ghc/compiler/deSugar/DsExpr.lhs | 2 +- ghc/compiler/deSugar/DsUtils.lhs | 6 +++--- ghc/compiler/hsSyn/HsExpr.lhs | 2 +- ghc/compiler/rename/RnEnv.lhs | 4 ++-- ghc/compiler/typecheck/Inst.lhs | 42 +++++++++++++++++++----------------- ghc/compiler/typecheck/TcHsSyn.lhs | 2 +- ghc/compiler/typecheck/TcPat.lhs | 12 +++++------ 7 files changed, 36 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 0350843..cedb95f 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -665,7 +665,7 @@ dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets | otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed) body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt]) - [(n, nlHsVar id) | (n,id) <- ds_meths] -- A bit of a hack + [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack (mkAppTy m_ty tup_ty) Var return_id = lookupReboundName ds_meths returnMName diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 79e757c..7eab67f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -36,7 +36,7 @@ module DsUtils ( #include "HsVersions.h" import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr( dsLExpr ) +import {-# SOURCE #-} DsExpr( dsExpr ) import HsSyn import TcHsSyn ( hsPatType ) @@ -95,9 +95,9 @@ dsReboundNames rebound_ids where -- The cheapo special case can happen when we -- make an intermediate HsDo when desugaring a RecStmt - mk_bind (std_name, L _ (HsVar id)) = return ([], (std_name, id)) + mk_bind (std_name, HsVar id) = return ([], (std_name, id)) mk_bind (std_name, expr) - = dsLExpr expr `thenDs` \ rhs -> + = dsExpr expr `thenDs` \ rhs -> newSysLocalDs (exprType rhs) `thenDs` \ id -> return ([NonRec id rhs], (std_name, id)) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index dd10217..1ff0e8f 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -222,7 +222,7 @@ Table of bindings of names used in rebindable syntax. This gets filled in by the renamer. \begin{code} -type ReboundNames id = [(Name, LHsExpr id)] +type ReboundNames id = [(Name, HsExpr id)] -- * Before the renamer, this list is empty -- -- * After the renamer, it takes the form [(std_name, HsVar actual_name)] diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 417d873..1185fe5 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -499,9 +499,9 @@ lookupSyntaxNames std_names -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names) + returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) where - normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs) + normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f296e1b..ae64ae1 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -83,7 +83,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) -import SrcLoc ( mkSrcSpan, noLoc, Located(..) ) +import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) import Maybes ( isJust ) import Outputable @@ -393,10 +393,10 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty -- Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify -- ToDo: noLoc sadness - = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) -> - mkIntegerLit i `thenM` \ integer_lit -> - returnM (mkHsApp expr integer_lit) - + = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> + mkIntegerLit i `thenM` \ integer_lit -> + returnM (mkHsApp (noLoc expr) integer_lit) + -- The mkHsApp will get the loc from the literal | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -405,9 +405,10 @@ 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, noLoc (HsVar fr)) `thenM` \ (_,expr) -> - mkRatLit r `thenM` \ rat_lit -> - returnM (mkHsApp expr rat_lit) + = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) -> + mkRatLit r `thenM` \ rat_lit -> + returnM (mkHsApp (noLoc expr) rat_lit) + -- The mkHsApp will get the loc from the literal | Just expr <- shortCutFracLit r expected_ty = returnM expr @@ -805,41 +806,42 @@ just use the expression inline. \begin{code} tcSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at - -> (Name, LHsExpr Name) -- (Standard name, user name) - -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) + -> (Name, HsExpr Name) -- (Standard name, user name) + -> TcM (Name, HsExpr 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, L span (HsVar user_nm)) +tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm - = addSrcSpan span (tcStdSyntaxName orig ty std_nm) + = tcStdSyntaxName orig ty std_nm tcSyntaxName orig ty (std_nm, user_nm_expr) = tcLookupId std_nm `thenM` \ std_id -> let -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - tau1 = substTyWith [tv] [ty] tau + sigma1 = substTyWith [tv] [ty] tau -- Actually, the "tau-type" might be a sigma-type in the -- case of locally-polymorphic methods. in - addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $ + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ -- Check that the user-supplied thing has the - -- same type as the standard one - tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> - returnM (std_nm, expr) + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + getSrcSpanM `thenM` \ span -> + tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr -> + returnM (std_nm, unLoc expr) tcStdSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at -> Name -- Standard name - -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) + -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) tcStdSyntaxName orig ty std_nm = newMethodFromName orig ty std_nm `thenM` \ id -> - getSrcSpanM `thenM` \ span -> - returnM (std_nm, L span (HsVar id)) + returnM (std_nm, HsVar id) syntaxNameCtxt name orig ty tidy_env = getInstLoc orig `thenM` \ inst_loc -> diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index df44a06..a7a130d 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -566,7 +566,7 @@ zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id) zonkReboundNames env prs = mapM zonk prs where - zonk (n, e) = zonkLExpr env e `thenM` \ new_e -> + zonk (n, e) = zonkExpr env e `thenM` \ new_e -> returnM (n, new_e) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 7c680f0..e778e72 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -38,7 +38,7 @@ import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity ) import PrelNames ( eqStringName, eqName, geName, negateName, minusName, integralClassName ) import BasicTypes ( isBoxed ) -import SrcLoc ( Located(..), noLoc, unLoc ) +import SrcLoc ( Located(..), noLoc, unLoc, noLoc ) import Bag import Outputable import FastString @@ -274,8 +274,8 @@ tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty Nothing -> returnM pos_lit_expr -- Positive literal Just neg -> -- Negative literal -- The 'negate' is re-mappable syntax - tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) -> - returnM (mkHsApp neg_expr pos_lit_expr) + tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) -> + returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) ) `thenM` \ lit_expr -> let @@ -310,7 +310,7 @@ tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) newMethodFromName origin pat_ty' geName `thenM` \ ge -> -- The '-' part is re-mappable syntax - tcSyntaxName origin pat_ty' (minusName, noLoc (HsVar minus_name)) `thenM` \ (_, minus_expr) -> + tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) -> -- The Report says that n+k patterns must be in Integral -- We may not want this when using re-mappable syntax, though (ToDo?) @@ -319,8 +319,8 @@ tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) extendLIEs dicts `thenM_` returnM (NPlusKPatOut (L nm_loc bndr_id) i - (SectionR (nlHsVar ge) over_lit_expr) - (SectionR minus_expr over_lit_expr), + (SectionR (nlHsVar ge) over_lit_expr) + (SectionR (noLoc minus_expr) over_lit_expr), emptyBag, unitBag (name, bndr_id), []) where origin = PatOrigin pat -- 1.7.10.4