[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.

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 0350843..cedb95f 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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