[project @ 2002-06-06 07:48:47 by simonpj]

Fix bogon in rebindable syntax implementation

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 703a0ac..62a8a28 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -10,16 +10,13 @@ module HsExpr where
 
 -- friends:
 import HsBinds         ( HsBinds(..), nullBinds )
-import HsTypes         ( PostTcType )
 import HsLit           ( HsLit, HsOverLit )
 import BasicTypes      ( Fixity(..) )
-import HsTypes         ( HsType )
+import HsTypes         ( HsType, PostTcType, SyntaxName )
 import HsImpExp                ( isOperator )
 
 -- others:
-import Name            ( Name )
 import ForeignCall     ( Safety )
-import Outputable      
 import PprType         ( pprParendType )
 import Type            ( Type  )
 import Var             ( TyVar )
@@ -27,6 +24,7 @@ import DataCon                ( DataCon )
 import CStrings                ( CLabelString, pprCLabelString )
 import BasicTypes      ( IPName, Boxity, tupleParens )
 import SrcLoc          ( SrcLoc )
+import Outputable      
 import FastString
 \end{code}
 
@@ -62,7 +60,7 @@ data HsExpr id pat
   -- They are eventually removed by the type checker.
 
   | NegApp     (HsExpr id pat) -- negated expr
-               Name            -- Name of 'negate' (see RnEnv.lookupSyntaxName)
+               SyntaxName      -- Name of 'negate' (see RnEnv.lookupSyntaxName)
 
   | HsPar      (HsExpr id pat) -- parenthesised expr
 

diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs
index 2675810..03dd717 100644 (file)
--- a/ghc/compiler/hsSyn/HsLit.lhs
+++ b/ghc/compiler/hsSyn/HsLit.lhs
@@ -9,8 +9,7 @@ module HsLit where
 #include "HsVersions.h"
 
 import Type    ( Type )
-import Name    ( Name )
-import HsTypes ( PostTcType )
+import HsTypes ( SyntaxName, PostTcType )
 import Outputable
 import FastString
 import Ratio   ( Rational )
@@ -58,9 +57,9 @@ instance Eq HsLit where
   lit1             == lit2              = False
 
 data HsOverLit                         -- An overloaded literal
-  = HsIntegral     Integer  Name       -- Integer-looking literals;
+  = HsIntegral     Integer  SyntaxName -- Integer-looking literals;
                                        -- The name is fromInteger
-  | HsFractional    Rational Name      -- Frac-looking literals
+  | HsFractional    Rational SyntaxName        -- Frac-looking literals
                                        -- The name is fromRational
 
 instance Eq HsOverLit where

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 10e22b8..6f0cc21 100644 (file)
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -22,7 +22,7 @@ module HsPat (
 -- friends:
 import HsLit           ( HsLit, HsOverLit )
 import HsExpr          ( HsExpr )
-import HsTypes         ( HsType )
+import HsTypes         ( HsType, SyntaxName )
 import BasicTypes      ( Fixity, Boxity, tupleParens )
 
 -- others:
@@ -55,13 +55,12 @@ data InPat name
                    (InPat name)
 
   | NPatIn         HsOverLit           -- Always positive
-                   (Maybe Name)        -- Just (Name of 'negate') for negative
+                   (Maybe SyntaxName)  -- Just (Name of 'negate') for negative
                                        -- patterns, Nothing otherwise
-                                       --  (see RnEnv.lookupSyntaxName)
 
   | NPlusKPatIn            name                -- n+k pattern
                    HsOverLit           -- It'll always be an HsIntegral
-                   Name                -- Name of '-' (see RnEnv.lookupSyntaxName)
+                   SyntaxName          -- Name of '-' (see RnEnv.lookupSyntaxName)
 
   -- We preserve prefix negation and parenthesis for the precedence parser.
 

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 738ab16..1706134 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -17,6 +17,9 @@ module HsTypes (
        -- Type place holder
        , PostTcType, placeHolderType,
 
+       -- Name place holder
+       , SyntaxName, placeHolderName,
+
        -- Printing
        , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
 
@@ -37,17 +40,18 @@ import TcType               ( Type, Kind, ThetaType, SourceType(..),
 import TypeRep         ( Type(..), TyNote(..) )        -- toHsType sees the representation
 import TyCon           ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn )
 import RdrName         ( RdrName, mkUnqual )
-import Name            ( Name, getName )
-import OccName         ( NameSpace, tvName )
+import Name            ( Name, getName, mkInternalName )
+import OccName         ( NameSpace, mkVarOcc, tvName )
 import Var             ( TyVar, tyVarKind )
 import Subst           ( substTyWith )
 import PprType         ( {- instance Outputable Kind -}, pprParendKind, pprKind )
 import BasicTypes      ( Boxity(..), Arity, IPName, tupleParens )
 import PrelNames       ( mkTupConRdrName, listTyConKey, parrTyConKey,
-                         usOnceTyConKey, usManyTyConKey, hasKey,
+                         usOnceTyConKey, usManyTyConKey, hasKey, unboundKey,
                          usOnceTyConName, usManyTyConName )
-import FiniteMap
+import SrcLoc          ( builtinSrcLoc )
 import Util            ( eqListBy, lengthIs )
+import FiniteMap
 import Outputable
 \end{code}
 
@@ -66,6 +70,18 @@ type PostTcType = Type               -- Used for slots in the abstract syntax
 
 placeHolderType :: PostTcType  -- Used before typechecking
 placeHolderType  = panic "Evaluated the place holder for a PostTcType"
+
+
+type SyntaxName = Name         -- These names are filled in by the renamer
+                               -- Before then they are a placeHolderName (so that
+                               --      we can still print the HsSyn)
+                               -- They correspond to "rebindable syntax";
+                               -- See RnEnv.lookupSyntaxName
+
+placeHolderName :: SyntaxName
+placeHolderName = mkInternalName unboundKey 
+                       (mkVarOcc FSLIT("syntaxPlaceHolder")) 
+                       builtinSrcLoc
 \end{code}
 
 

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 6f8bd63..374a441 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -62,14 +62,11 @@ module RdrHsSyn (
 import HsSyn           -- Lots of it
 import OccName         ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
                           mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
-                         mkGenOcc2, mkVarOcc
+                         mkGenOcc2
                        )
-import PrelNames       ( unboundKey )
-import Name            ( mkInternalName )
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
 import List            ( nub )
 import BasicTypes      ( RecFlag(..) )
-import SrcLoc          ( builtinSrcLoc )
 import Class            ( DefMeth (..) )
 \end{code}
 
@@ -262,10 +259,6 @@ mkHsIntegral   i      = HsIntegral   i  placeHolderName
 mkHsFractional f      = HsFractional f  placeHolderName
 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
-
-placeHolderName = mkInternalName unboundKey 
-                       (mkVarOcc FSLIT("syntaxPlaceHolder")) 
-                       builtinSrcLoc
 \end{code}
 
 

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index fd08c0f..bc63e44 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -95,9 +95,9 @@ rnPat (LitPatIn lit)
 rnPat (NPatIn lit mb_neg) 
   = rnOverLit lit                      `thenRn` \ (lit', fvs1) ->
     (case mb_neg of
-       Nothing  -> returnRn (Nothing, emptyFVs)
-       Just neg -> lookupSyntaxName neg        `thenRn` \ neg' ->
-                   returnRn (Just neg', unitFV neg')
+       Nothing -> returnRn (Nothing, emptyFVs)
+       Just _  -> lookupSyntaxName negateName  `thenRn` \ neg ->
+                  returnRn (Just neg, unitFV neg)
     )                                  `thenRn` \ (mb_neg', fvs2) ->
     returnRn (NPatIn lit' mb_neg', 
              fvs1 `plusFV` fvs2 `addOneFV` eqClassName)