From: simonpj Date: Thu, 6 Jun 2002 07:48:48 +0000 (+0000) Subject: [project @ 2002-06-06 07:48:47 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1985 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f3d24c87016078e0e50fa80575e04f340f86acb4;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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)