Commit f3d24c87 authored by simonpj's avatar simonpj
Browse files

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

Fix bogon in rebindable syntax implementation
parent b2f644fa
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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}
......
......@@ -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}
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment