summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/parser/Lexer.x6
-rw-r--r--compiler/parser/Parser.y47
-rw-r--r--compiler/parser/RdrHsSyn.hs25
-rw-r--r--compiler/prelude/PrelNames.hs4
-rw-r--r--compiler/rename/RnTypes.hs8
-rw-r--r--compiler/rename/RnUnbound.hs15
6 files changed, 41 insertions, 64 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index c4d0d4d127..c8a55c6b2f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -818,9 +818,7 @@ reservedWordsFM = listToUFM $
( "type", ITtype, 0 ),
( "where", ITwhere, 0 ),
- ( "forall", ITforall NormalSyntax,
- xbit ExplicitForallBit .|.
- xbit InRulePragBit),
+ ( "forall", ITforall NormalSyntax, 0),
( "mdo", ITmdo, xbit RecursiveDoBit),
-- See Note [Lexing type pseudo-keywords]
( "family", ITfamily, 0 ),
@@ -2304,7 +2302,7 @@ data ExtBits
| ThQuotesBit
| IpBit
| OverloadedLabelsBit -- #x overloaded labels
- | ExplicitForallBit -- the 'forall' keyword and '.' symbol
+ | ExplicitForallBit -- the 'forall' keyword
| BangPatBit -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
| PatternSynonymsBit -- pattern synonyms
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 07515679b1..f69ad9f096 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1239,7 +1239,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: 'forall' tv_bndrs '.' type '=' ktype
- {% do { hintExplicitForall (getLoc $1)
+ {% do { hintExplicitForall $1
; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
[mu AnnForall $1, mj AnnDot $3] } }
@@ -1383,12 +1383,12 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
| type { sL1 $1 (Nothing, $1) }
tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
- : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall (getLoc $1)
+ : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1
>> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
>> ams (sLL $1 $> $ (Just $4, Just $2, $6))
[mu AnnForall $1, mj AnnDot $3])
}
- | 'forall' tv_bndrs '.' type {% hintExplicitForall (getLoc $1)
+ | 'forall' tv_bndrs '.' type {% hintExplicitForall $1
>> ams (sLL $1 $> $ (Nothing, Just $2, $4))
[mu AnnForall $1, mj AnnDot $3]
}
@@ -1667,7 +1667,7 @@ rule_explicit_activation :: { ([AddAnn]
rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) }
: 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
- in hintExplicitForall (getLoc $1)
+ in hintExplicitForall $1
>> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
>> return ([mu AnnForall $1,mj AnnDot $3,
mu AnnForall $4,mj AnnDot $6],
@@ -1855,7 +1855,7 @@ ktypedoc :: { LHsType GhcPs }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
- : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
+ : 'forall' tv_bndrs '.' ctype {% hintExplicitForall $1 >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
, hst_xforall = noExt
@@ -1882,7 +1882,7 @@ ctype :: { LHsType GhcPs }
-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
ctypedoc :: { LHsType GhcPs }
- : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
+ : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall $1 >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
, hst_xforall = noExt
@@ -3369,7 +3369,7 @@ tyvarop :: { Located RdrName }
tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2))
[mj AnnBackquote $1,mj AnnVal $2
,mj AnnBackquote $3] }
- | '.' {% hintExplicitForall' (getLoc $1) }
+ | '.' { sL1 $1 $ mkUnqual tcClsName (fsLit ".") }
tyvarid :: { Located RdrName }
: VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) }
@@ -3470,7 +3470,7 @@ special_id
special_sym :: { Located FastString }
special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
| '.' { sL1 $1 (fsLit ".") }
- | '*' { sL1 $1 (fsLit (if isUnicode $1 then "\x2605" else "*")) }
+ | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) }
-----------------------------------------------------------------------------
-- Data constructors
@@ -3765,32 +3765,19 @@ hintIf span msg = do
then parseErrorSDoc span $ text $ "parse error in if statement"
else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
--- Hint about explicit-forall, assuming UnicodeSyntax is on
-hintExplicitForall :: SrcSpan -> P ()
-hintExplicitForall span = do
+-- Hint about explicit-forall
+hintExplicitForall :: Located Token -> P ()
+hintExplicitForall tok = do
forall <- getBit ExplicitForallBit
rulePrag <- getBit InRulePragBit
- unless (forall || rulePrag) $ parseErrorSDoc span $ vcat
- [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL
+ unless (forall || rulePrag) $ parseErrorSDoc (getLoc tok) $ vcat
+ [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"
, text "Perhaps you intended to use RankNTypes or a similar language"
- , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
+ , text "extension to enable explicit-forall syntax:" <+>
+ forallSymDoc <+> text "<tvs>. <type>"
]
-
--- Hint about explicit-forall, assuming UnicodeSyntax is off
-hintExplicitForall' :: SrcSpan -> P (Located RdrName)
-hintExplicitForall' span = do
- forall <- getBit ExplicitForallBit
- let illegalDot = "Illegal symbol '.' in type"
- if forall
- then parseErrorSDoc span $ vcat
- [ text illegalDot
- , text "Perhaps you meant to write 'forall <tvs>. <type>'?"
- ]
- else parseErrorSDoc span $ vcat
- [ text illegalDot
- , text "Perhaps you intended to use RankNTypes or a similar language"
- , text "extension to enable explicit-forall syntax: forall <tvs>. <type>"
- ]
+ where
+ forallSymDoc = text (forallSym (isUnicode tok))
checkIfBang :: LHsExpr GhcPs -> Bool
checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index c1777759da..5c995c71ca 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -71,6 +71,10 @@ module RdrHsSyn (
mkImpExpSubSpec,
checkImportSpec,
+ -- Token symbols
+ forallSym,
+ starSym,
+
-- Warnings and errors
warnStarIsType,
failOpFewArgs,
@@ -97,7 +101,7 @@ import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
listTyConName, listTyConKey, eqTyCon_RDR,
tupleTyConName, cTupleTyConNameArity_maybe )
import ForeignCall
-import PrelNames ( forall_tv_RDR, allNameStrings )
+import PrelNames ( allNameStrings )
import SrcLoc
import Unique ( hasKey )
import OrdList ( OrdList, fromOL )
@@ -571,14 +575,10 @@ tyConToDataCon loc tc
= return (cL loc (setRdrNameSpace tc srcDataName))
| otherwise
- = Left (loc, msg $$ extra)
+ = Left (loc, msg)
where
occ = rdrNameOcc tc
-
msg = text "Not a data constructor:" <+> quotes (ppr tc)
- extra | tc == forall_tv_RDR
- = text "Perhaps you intended to use ExistentialQuantification"
- | otherwise = empty
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
@@ -958,7 +958,7 @@ checkTyClHdr is_cls ty
-- workaround to define '*' despite StarIsType
go _ (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
- ; let name = mkOccName tcClsName (if isUni then "★" else "*")
+ ; let name = mkOccName tcClsName (starSym isUni)
; return (cL l (Unqual name), acc, fix, ann) }
go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix
@@ -2333,3 +2333,14 @@ mkLHsDocTy t doc =
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
+
+-----------------------------------------------------------------------------
+-- Token symbols
+
+starSym :: Bool -> String
+starSym True = "★"
+starSym False = "*"
+
+forallSym :: Bool -> String
+forallSym True = "∀"
+forallSym False = "forall"
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 5c86f65bb8..d586219e36 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -645,10 +645,6 @@ main_RDR_Unqual = mkUnqual varName (fsLit "main")
-- We definitely don't want an Orig RdrName, because
-- main might, in principle, be imported into module Main
-forall_tv_RDR, dot_tv_RDR :: RdrName
-forall_tv_RDR = mkUnqual tvName (fsLit "forall")
-dot_tv_RDR = mkUnqual tvName (fsLit ".")
-
eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,
ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName
eq_RDR = nameRdrName eqName
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 3703f1ac63..8ec8f3e69f 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -44,7 +44,6 @@ import DynFlags
import HsSyn
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
-import RnUnbound ( perhapsForallMsg )
import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
, pprHsDocContext, bindLocalNamesFV, typeAppErr
, newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
@@ -1463,12 +1462,7 @@ warnUnusedForAll in_doc (dL->L loc tv) used_names
opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr op overall_ty
= hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
- 2 extra
- where
- extra | op == dot_tv_RDR
- = perhapsForallMsg
- | otherwise
- = text "Use TypeOperators to allow operators in types"
+ 2 (text "Use TypeOperators to allow operators in types")
{-
************************************************************************
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
index bdda66f00b..2de2fc1f0c 100644
--- a/compiler/rename/RnUnbound.hs
+++ b/compiler/rename/RnUnbound.hs
@@ -12,7 +12,6 @@ module RnUnbound ( mkUnboundName
, WhereLooking(..)
, unboundName
, unboundNameX
- , perhapsForallMsg
, notInScopeErr ) where
import GhcPrelude
@@ -24,7 +23,7 @@ import Name
import Module
import SrcLoc
import Outputable
-import PrelNames ( mkUnboundName, forall_tv_RDR, isUnboundName, getUnique)
+import PrelNames ( mkUnboundName, isUnboundName, getUnique)
import Util
import Maybes
import DynFlags
@@ -78,13 +77,10 @@ unboundNameX where_look rdr_name extra
notInScopeErr :: RdrName -> SDoc
notInScopeErr rdr_name
- = vcat [ hang (text "Not in scope:")
- 2 (what <+> quotes (ppr rdr_name))
- , extra ]
+ = hang (text "Not in scope:")
+ 2 (what <+> quotes (ppr rdr_name))
where
what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
- extra | rdr_name == forall_tv_RDR = perhapsForallMsg
- | otherwise = Outputable.empty
type HowInScope = Either SrcSpan ImpDeclSpec
-- Left loc => locally bound at loc
@@ -352,11 +348,6 @@ extensionSuggestions rdrName
= text "Perhaps you meant to use RecursiveDo"
| otherwise = Outputable.empty
-perhapsForallMsg :: SDoc
-perhapsForallMsg
- = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"
- , text "to enable explicit-forall syntax: forall <tvs>. <type>"]
-
qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
-- Ones for which the qualified version is in scope
qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }
View Lorry Controller Status