summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2015-11-16 19:43:34 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2015-11-16 19:43:34 +0200
commitfe95463bdf42651d53d1edc7723491664257cc5a (patch)
treef43452b6cbe66b0d83e0a9fa65b83a5f05989833 /compiler
parent46a03fbec6a02761db079d1746532565f34c340f (diff)
downloadhaskell-fe95463bdf42651d53d1edc7723491664257cc5a.tar.gz
ApiAnnotations: Add SourceText for unicode tokens
Summary: At the moment there is no way to tell if a given token used its unicode variant or its normal one, except to look at the length of the token. This fails for the unicode '*'. Expose the original source text for unicode variants so that API Annotations can capture them specifically. Test Plan: ./validate Reviewers: mpickering, austin, bgamari Reviewed By: bgamari Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D1473 GHC Trac Issues: #11018
Diffstat (limited to 'compiler')
-rw-r--r--compiler/parser/ApiAnnotation.hs40
-rw-r--r--compiler/parser/Lexer.x100
-rw-r--r--compiler/parser/Parser.y161
3 files changed, 184 insertions, 117 deletions
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index 7376e305ea..c5ba4535b7 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -7,6 +7,8 @@ module ApiAnnotation (
ApiAnnKey,
AnnKeywordId(..),
AnnotationComment(..),
+ IsUnicodeSyntax(..),
+ unicodeAnn,
LRdrName -- Exists for haddocks only
) where
@@ -198,8 +200,10 @@ data AnnKeywordId
| AnnComma -- ^ as a list separator
| AnnCommaTuple -- ^ in a RdrName for a tuple
| AnnDarrow -- ^ '=>'
+ | AnnDarrowU -- ^ '=>', unicode variant
| AnnData
| AnnDcolon -- ^ '::'
+ | AnnDcolonU -- ^ '::', unicode variant
| AnnDefault
| AnnDeriving
| AnnDo
@@ -210,6 +214,7 @@ data AnnKeywordId
| AnnExport
| AnnFamily
| AnnForall
+ | AnnForallU -- ^ Unicode variant
| AnnForeign
| AnnFunId -- ^ for function name in matches where there are
-- multiple equations for the function.
@@ -223,6 +228,7 @@ data AnnKeywordId
| AnnInstance
| AnnLam
| AnnLarrow -- ^ '<-'
+ | AnnLarrowU -- ^ '<-', unicode variant
| AnnLet
| AnnMdo
| AnnMinus -- ^ '-'
@@ -241,9 +247,12 @@ data AnnKeywordId
| AnnProc
| AnnQualified
| AnnRarrow -- ^ '->'
+ | AnnRarrowU -- ^ '->', unicode variant
| AnnRec
| AnnRole
| AnnSafe
+ | AnnStar -- ^ '*'
+ | AnnStarU -- ^ '*', unicode variant.
| AnnSemi -- ^ ';'
| AnnSimpleQuote -- ^ '''
| AnnStatic -- ^ 'static'
@@ -261,11 +270,15 @@ data AnnKeywordId
| AnnVbar -- ^ '|'
| AnnWhere
| Annlarrowtail -- ^ '-<'
+ | AnnlarrowtailU -- ^ '-<', unicode variant
| Annrarrowtail -- ^ '->'
+ | AnnrarrowtailU -- ^ '->', unicode variant
| AnnLarrowtail -- ^ '-<<'
+ | AnnLarrowtailU -- ^ '-<<', unicode variant
| AnnRarrowtail -- ^ '>>-'
+ | AnnRarrowtailU -- ^ '>>-', unicode variant
| AnnEofPos
- deriving (Eq,Ord,Data,Typeable,Show)
+ deriving (Eq, Ord, Data, Typeable, Show)
instance Outputable AnnKeywordId where
ppr x = text (show x)
@@ -282,7 +295,7 @@ data AnnotationComment =
| AnnDocOptionsOld String -- ^ doc options declared "-- # ..."-style
| AnnLineComment String -- ^ comment starting by "--"
| AnnBlockComment String -- ^ comment in {- -}
- deriving (Eq,Ord,Data,Typeable,Show)
+ deriving (Eq, Ord, Data, Typeable, Show)
-- Note: these are based on the Token versions, but the Token type is
-- defined in Lexer.x and bringing it in here would create a loop
@@ -295,3 +308,26 @@ instance Outputable AnnotationComment where
-- 'ApiAnnotation.AnnTilde'
-- - May have 'ApiAnnotation.AnnComma' when in a list
type LRdrName = Located RdrName
+
+
+-- | Certain tokens can have alternate representations when unicode syntax is
+-- enabled. This flag is attached to those tokens in the lexer so that the
+-- original source representation can be reproduced in the corresponding
+-- 'ApiAnnotation'
+data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax
+ deriving (Eq, Ord, Data, Typeable, Show)
+
+-- | Convert a normal annotation into its unicode equivalent one
+unicodeAnn :: AnnKeywordId -> AnnKeywordId
+unicodeAnn AnnForall = AnnForallU
+unicodeAnn AnnDcolon = AnnDcolonU
+unicodeAnn AnnLarrow = AnnLarrowU
+unicodeAnn AnnRarrow = AnnRarrowU
+unicodeAnn AnnDarrow = AnnDarrowU
+unicodeAnn Annlarrowtail = AnnLarrowtailU
+unicodeAnn Annrarrowtail = AnnrarrowtailU
+unicodeAnn AnnLarrowtail = AnnLarrowtailU
+unicodeAnn AnnRarrowtail = AnnRarrowtailU
+unicodeAnn AnnStar = AnnStarU
+unicodeAnn ann = ann
+-- What about '*'?
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index acb6893b66..0bf26ce8de 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -535,7 +535,7 @@ data Token
| ITtype
| ITwhere
- | ITforall -- GHC extension keywords
+ | ITforall IsUnicodeSyntax -- GHC extension keywords
| ITexport
| ITlabel
| ITdynamic
@@ -587,20 +587,20 @@ data Token
| ITdotdot -- reserved symbols
| ITcolon
- | ITdcolon
+ | ITdcolon IsUnicodeSyntax
| ITequal
| ITlam
| ITlcase
| ITvbar
- | ITlarrow
- | ITrarrow
+ | ITlarrow IsUnicodeSyntax
+ | ITrarrow IsUnicodeSyntax
| ITat
| ITtilde
| ITtildehsh
- | ITdarrow
+ | ITdarrow IsUnicodeSyntax
| ITminus
| ITbang
- | ITstar
+ | ITstar IsUnicodeSyntax
| ITdot
| ITbiglam -- GHC-extension symbols
@@ -671,15 +671,15 @@ data Token
-- Arrow notation extension
| ITproc
| ITrec
- | IToparenbar -- (|
- | ITcparenbar -- |)
- | ITlarrowtail -- -<
- | ITrarrowtail -- >-
- | ITLarrowtail -- -<<
- | ITRarrowtail -- >>-
+ | IToparenbar -- (|
+ | ITcparenbar -- |)
+ | ITlarrowtail IsUnicodeSyntax -- -<
+ | ITrarrowtail IsUnicodeSyntax -- >-
+ | ITLarrowtail IsUnicodeSyntax -- -<<
+ | ITRarrowtail IsUnicodeSyntax -- >>-
- | ITunknown String -- Used when the lexer can't make sense of it
- | ITeof -- end of file token
+ | ITunknown String -- Used when the lexer can't make sense of it
+ | ITeof -- end of file token
-- Documentation annotations
| ITdocCommentNext String -- something beginning '-- |'
@@ -733,7 +733,8 @@ reservedWordsFM = listToUFM $
( "type", ITtype, 0 ),
( "where", ITwhere, 0 ),
- ( "forall", ITforall, xbit ExplicitForallBit .|.
+ ( "forall", ITforall NormalSyntax,
+ xbit ExplicitForallBit .|.
xbit InRulePragBit),
( "mdo", ITmdo, xbit RecursiveDoBit),
-- See Note [Lexing type pseudo-keywords]
@@ -784,44 +785,49 @@ a key detail to make all this work.
reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)
reservedSymsFM = listToUFM $
map (\ (x,y,z) -> (mkFastString x,(y,z)))
- [ ("..", ITdotdot, always)
+ [ ("..", ITdotdot, always)
-- (:) is a reserved op, meaning only list cons
- ,(":", ITcolon, always)
- ,("::", ITdcolon, always)
- ,("=", ITequal, always)
- ,("\\", ITlam, always)
- ,("|", ITvbar, always)
- ,("<-", ITlarrow, always)
- ,("->", ITrarrow, always)
- ,("@", ITat, always)
- ,("~", ITtilde, always)
- ,("~#", ITtildehsh, magicHashEnabled)
- ,("=>", ITdarrow, always)
- ,("-", ITminus, always)
- ,("!", ITbang, always)
+ ,(":", ITcolon, always)
+ ,("::", ITdcolon NormalSyntax, always)
+ ,("=", ITequal, always)
+ ,("\\", ITlam, always)
+ ,("|", ITvbar, always)
+ ,("<-", ITlarrow NormalSyntax, always)
+ ,("->", ITrarrow NormalSyntax, always)
+ ,("@", ITat, always)
+ ,("~", ITtilde, always)
+ ,("~#", ITtildehsh, magicHashEnabled)
+ ,("=>", ITdarrow NormalSyntax, always)
+ ,("-", ITminus, always)
+ ,("!", ITbang, always)
-- For data T (a::*) = MkT
- ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i)
+ ,("*", ITstar NormalSyntax, always)
+ -- \i -> kindSigsEnabled i || tyFamEnabled i)
-- For 'forall a . t'
,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i)
- ,("-<", ITlarrowtail, arrowsEnabled)
- ,(">-", ITrarrowtail, arrowsEnabled)
- ,("-<<", ITLarrowtail, arrowsEnabled)
- ,(">>-", ITRarrowtail, arrowsEnabled)
-
- ,("∷", ITdcolon, unicodeSyntaxEnabled)
- ,("⇒", ITdarrow, unicodeSyntaxEnabled)
- ,("∀", ITforall, unicodeSyntaxEnabled)
- ,("→", ITrarrow, unicodeSyntaxEnabled)
- ,("←", ITlarrow, unicodeSyntaxEnabled)
-
- ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
- ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
- ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
- ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
-
- ,("★", ITstar, unicodeSyntaxEnabled)
+ ,("-<", ITlarrowtail NormalSyntax, arrowsEnabled)
+ ,(">-", ITrarrowtail NormalSyntax, arrowsEnabled)
+ ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled)
+ ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled)
+
+ ,("∷", ITdcolon UnicodeSyntax, unicodeSyntaxEnabled)
+ ,("⇒", ITdarrow UnicodeSyntax, unicodeSyntaxEnabled)
+ ,("∀", ITforall UnicodeSyntax, unicodeSyntaxEnabled)
+ ,("→", ITrarrow UnicodeSyntax, unicodeSyntaxEnabled)
+ ,("←", ITlarrow UnicodeSyntax, unicodeSyntaxEnabled)
+
+ ,("⤙", ITlarrowtail UnicodeSyntax,
+ \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+ ,("⤚", ITrarrowtail UnicodeSyntax,
+ \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+ ,("⤛", ITLarrowtail UnicodeSyntax,
+ \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+ ,("⤜", ITRarrowtail UnicodeSyntax,
+ \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+
+ ,("★", ITstar UnicodeSyntax, unicodeSyntaxEnabled)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index a74d7a8b95..bf6e753d57 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -350,7 +350,7 @@ output it generates.
'type' { L _ ITtype }
'where' { L _ ITwhere }
- 'forall' { L _ ITforall } -- GHC extension keywords
+ 'forall' { L _ (ITforall _) } -- GHC extension keywords
'foreign' { L _ ITforeign }
'export' { L _ ITexport }
'label' { L _ ITlabel }
@@ -400,24 +400,24 @@ output it generates.
'..' { L _ ITdotdot } -- reserved symbols
':' { L _ ITcolon }
- '::' { L _ ITdcolon }
+ '::' { L _ (ITdcolon _) }
'=' { L _ ITequal }
'\\' { L _ ITlam }
'lcase' { L _ ITlcase }
'|' { L _ ITvbar }
- '<-' { L _ ITlarrow }
- '->' { L _ ITrarrow }
+ '<-' { L _ (ITlarrow _) }
+ '->' { L _ (ITrarrow _) }
'@' { L _ ITat }
'~' { L _ ITtilde }
'~#' { L _ ITtildehsh }
- '=>' { L _ ITdarrow }
+ '=>' { L _ (ITdarrow _) }
'-' { L _ ITminus }
'!' { L _ ITbang }
- '*' { L _ ITstar }
- '-<' { L _ ITlarrowtail } -- for arrow notation
- '>-' { L _ ITrarrowtail } -- for arrow notation
- '-<<' { L _ ITLarrowtail } -- for arrow notation
- '>>-' { L _ ITRarrowtail } -- for arrow notation
+ '*' { L _ (ITstar _) }
+ '-<' { L _ (ITlarrowtail _) } -- for arrow notation
+ '>-' { L _ (ITrarrowtail _) } -- for arrow notation
+ '-<<' { L _ (ITLarrowtail _) } -- for arrow notation
+ '>>-' { L _ (ITRarrowtail _) } -- for arrow notation
'.' { L _ ITdot }
'{' { L _ ITocurly } -- special symbols
@@ -509,7 +509,7 @@ identifier :: { Located RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
- [mj AnnOpenP $1,mj AnnRarrow $2,mj AnnCloseP $3] }
+ [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
-----------------------------------------------------------------------------
-- Module Header
@@ -948,7 +948,7 @@ opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) }
injectivity_cond :: { Located ([AddAnn], LInjectivityAnn RdrName) }
: tyvarid '->' inj_varids
- { sLL $1 $> ( [mj AnnRarrow $2]
+ { sLL $1 $> ( [mu AnnRarrow $2]
, (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))) }
inj_varids :: { Located [Located RdrName] }
@@ -1070,21 +1070,21 @@ data_or_newtype :: { Located (AddAnn, NewOrData) }
opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) }
: { noLoc ([] , Nothing) }
- | '::' kind { sLL $1 $> ([mj AnnDcolon $1], Just $2) }
+ | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) }
opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }
: { noLoc ([] , noLoc NoSig )}
- | '::' kind { sLL $1 $> ([mj AnnDcolon $1], sLL $1 $> (KindSig $2))}
+ | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }
: { noLoc ([] , noLoc NoSig )}
- | '::' kind { sLL $1 $> ([mj AnnDcolon $1], sLL $1 $> (KindSig $2))}
+ | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
| '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))}
opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName
, Maybe (LInjectivityAnn RdrName)))}
: { noLoc ([], (noLoc NoSig, Nothing)) }
- | '::' kind { sLL $1 $> ( [mj AnnDcolon $1]
+ | '::' kind { sLL $1 $> ( [mu AnnDcolon $1]
, (sLL $2 $> (KindSig $2), Nothing)) }
| '=' tv_bndr '|' injectivity_cond
{ sLL $1 $> ( mj AnnEqual $1 : mj AnnVbar $3 : fst (unLoc $4)
@@ -1098,7 +1098,7 @@ opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
- : context '=>' type {% addAnnotation (gl $1) AnnDarrow (gl $2)
+ : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> (return (sLL $1 $> (Just $1, $3)))
}
| type { sL1 $1 (Nothing, $1) }
@@ -1162,13 +1162,13 @@ pattern_synonym_decl :: { LHsDecl RdrName }
| 'pattern' pattern_synonym_lhs '<-' pat
{% let (name, args, as) = $2 in
ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
- (as ++ [mj AnnPattern $1,mj AnnLarrow $3]) }
+ (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args, as) = $2
; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
; ams (sLL $1 $> . ValD $
mkPatSynBind name args $4 (ExplicitBidirectional mg))
- (as ++ ((mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5))) )
+ (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
}}
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
@@ -1196,7 +1196,7 @@ pattern_synonym_sig :: { LSig RdrName }
{% do { let (flag, qtvs, req, prov, ty) = snd $ unLoc $4
; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) req prov ty
; ams (sLL $1 $> $ sig)
- (mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } }
+ (mj AnnPattern $1:mu AnnDcolon $3:(fst $ unLoc $4)) } }
ptype :: { Located ([AddAnn]
,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName
@@ -1205,13 +1205,13 @@ ptype :: { Located ([AddAnn]
{% do { hintExplicitForall (getLoc $1)
; let (_, qtvs', prov, req, ty) = snd $ unLoc $4
; return $ sLL $1 $>
- ((mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4))
+ ((mu AnnForall $1:mj AnnDot $3:(fst $ unLoc $4))
,(Explicit, $2 ++ qtvs', prov, req ,ty)) }}
| context '=>' context '=>' type
- { sLL $1 $> ([mj AnnDarrow $2,mj AnnDarrow $4]
+ { sLL $1 $> ([mu AnnDarrow $2,mu AnnDarrow $4]
,(Implicit, [], $1, $3, $5)) }
| context '=>' type
- { sLL $1 $> ([mj AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) }
+ { sLL $1 $> ([mu AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) }
| type
{ sL1 $1 ([],(Implicit, [], noLoc [], noLoc [], $1)) }
@@ -1230,7 +1230,7 @@ decl_cls : at_decl_cls { $1 }
; let err = text "in default signature" <> colon <+>
quotes (ppr ty)
; ams (sLL $1 $> $ SigD (GenericSig l ty))
- [mj AnnDefault $1,mj AnnDcolon $3] } }
+ [mj AnnDefault $1,mu AnnDcolon $3] } }
decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1)
@@ -1388,7 +1388,7 @@ rule_explicit_activation :: { ([AddAnn]
,NeverActive) }
rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) }
- : 'forall' rule_var_list '.' { ([mj AnnForall $1,mj AnnDot $3],$2) }
+ : 'forall' rule_var_list '.' { ([mu AnnForall $1,mj AnnDot $3],$2) }
| {- empty -} { ([],[]) }
rule_var_list :: { [LRuleBndr RdrName] }
@@ -1399,7 +1399,7 @@ rule_var :: { LRuleBndr RdrName }
: varid { sLL $1 $> (RuleBndr $1) }
| '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2
(mkHsWithBndrs $4)))
- [mop $1,mj AnnDcolon $3,mcp $5] }
+ [mop $1,mu AnnDcolon $3,mcp $5] }
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
@@ -1491,10 +1491,10 @@ safety :: { Located Safety }
fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsType RdrName)) }
- : STRING var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $3]
+ : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
,(L (getLoc $1)
(getStringLiteral $1), $2, $4)) }
- | var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $2]
+ | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
,(noLoc (StringLiteral "" nilFS), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
@@ -1505,11 +1505,11 @@ fspec :: { Located ([AddAnn]
opt_sig :: { ([AddAnn],Maybe (LHsType RdrName)) }
: {- empty -} { ([],Nothing) }
- | '::' sigtype { ([mj AnnDcolon $1],Just $2) }
+ | '::' sigtype { ([mu AnnDcolon $1],Just $2) }
opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
: {- empty -} { ([],Nothing) }
- | '::' atype { ([mj AnnDcolon $1],Just $2) }
+ | '::' atype { ([mu AnnDcolon $1],Just $2) }
sigtype :: { LHsType RdrName } -- Always a HsForAllTy,
-- to tell the renamer where to generalise
@@ -1556,12 +1556,12 @@ ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) $4)
- [mj AnnForall $1,mj AnnDot $3] }
- | context '=>' ctype {% addAnnotation (gl $1) AnnDarrow (gl $2)
+ [mu AnnForall $1,mj AnnDot $3] }
+ | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
mkQualifiedHsForAllTy $1 $3) }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
- [mj AnnVal $1,mj AnnDcolon $2] }
+ [mj AnnVal $1,mu AnnDcolon $2] }
| type { $1 }
----------------------
@@ -1579,12 +1579,12 @@ ctypedoc :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) $4)
- [mj AnnForall $1,mj AnnDot $3] }
- | context '=>' ctypedoc {% addAnnotation (gl $1) AnnDarrow (gl $2)
+ [mu AnnForall $1,mj AnnDot $3] }
+ | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
mkQualifiedHsForAllTy $1 $3) }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
- [mj AnnVal $1,mj AnnDcolon $2] }
+ [mj AnnVal $1,mu AnnDcolon $2] }
| typedoc { $1 }
----------------------
@@ -1611,9 +1611,9 @@ type :: { LHsType RdrName }
: btype { splitTilde $1 }
| btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
- | btype '->' ctype {% ams $1 [mj AnnRarrow $2]
+ | btype '->' ctype {% ams $1 [mu AnnRarrow $2]
>> ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
- [mj AnnRarrow $2] }
+ [mu AnnRarrow $2] }
| btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
[mj AnnSimpleQuote $2] }
| btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
@@ -1627,10 +1627,10 @@ typedoc :: { LHsType RdrName }
| btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
| btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
- [mj AnnRarrow $2] }
+ [mu AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 (splitTilde $1) $2)
(HsDocTy $1 $2)) $4)
- [mj AnnRarrow $3] }
+ [mu AnnRarrow $3] }
| btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
[mj AnnSimpleQuote $2] }
| btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
@@ -1670,7 +1670,7 @@ atype :: { LHsType RdrName }
| '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] }
| '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] }
| '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4)
- [mop $1,mj AnnDcolon $3,mcp $5] }
+ [mop $1,mu AnnDcolon $3,mcp $5] }
| quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
@@ -1733,7 +1733,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { sL1 $1 (UserTyVar (unLoc $1)) }
| '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4))
- [mop $1,mj AnnDcolon $3
+ [mop $1,mu AnnDcolon $3
,mcp $5] }
fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }
@@ -1749,7 +1749,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] }
fd :: { Located (FunDep (Located RdrName)) }
: varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)))
- [mj AnnRarrow $2] }
+ [mu AnnRarrow $2] }
varids0 :: { Located [Located RdrName] }
: {- empty -} { noLoc [] }
@@ -1778,14 +1778,15 @@ turn them into HsEqTy's.
kind :: { LHsKind RdrName }
: bkind { $1 }
| bkind '->' kind {% ams (sLL $1 $> $ HsFunTy $1 $3)
- [mj AnnRarrow $2] }
+ [mu AnnRarrow $2] }
bkind :: { LHsKind RdrName }
: akind { $1 }
| bkind akind { sLL $1 $> $ HsAppTy $1 $2 }
akind :: { LHsKind RdrName }
- : '*' { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
+ : '*' {% ams (sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName))
+ [mu AnnStar $1] }
| '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2)
[mop $1,mcp $3] }
| pkind { $1 }
@@ -1876,7 +1877,7 @@ gadt_constr :: { LConDecl RdrName }
: con_list '::' sigtype
{% do { let { (anns, gadtDecl) = mkGadtDecl (unLoc $1) $3 }
; ams (sLL $1 $> gadtDecl)
- (mj AnnDcolon $2:anns) } }
+ (mu AnnDcolon $2:anns) } }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1906,7 +1907,7 @@ constr :: { LConDecl RdrName }
addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con
(snd $ unLoc $2) $3 details))
($1 `mplus` $6))
- (mj AnnDarrow $4:(fst $ unLoc $2)) }
+ (mu AnnDarrow $4:(fst $ unLoc $2)) }
| maybe_docnext forall constr_stuff maybe_docprev
{% ams ( let (con,details) = unLoc $3 in
addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con
@@ -1915,7 +1916,7 @@ constr :: { LConDecl RdrName }
(fst $ unLoc $2) }
forall :: { Located ([AddAnn],[LHsTyVarBndr RdrName]) }
- : 'forall' tv_bndrs '.' { sLL $1 $> ([mj AnnForall $1,mj AnnDot $3],$2) }
+ : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3],$2) }
| {- empty -} { noLoc ([],[]) }
constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
@@ -1949,7 +1950,7 @@ fielddecl :: { LConDeclField RdrName }
: maybe_docnext sig_vars '::' ctype maybe_docprev
{% ams (L (comb2 $2 $4)
(ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5)))
- [mj AnnDcolon $3] }
+ [mu AnnDcolon $3] }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
@@ -2060,14 +2061,14 @@ sigdecl :: { LHsDecl RdrName }
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp '::' sigtypedoc
{% do s <- checkValSig $1 $3
- ; _ <- ams (sLL $1 $> ()) [mj AnnDcolon $2]
+ ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
; return (sLL $1 $> $ SigD s) }
| var ',' sig_vars '::' sigtypedoc
{% do { let sig = TypeSig ($1 : reverse (unLoc $3)) $5 PlaceHolder
; addAnnotation (gl $1) AnnComma (gl $2)
; ams ( sLL $1 $> $ SigD sig )
- [mj AnnDcolon $4] } }
+ [mu AnnDcolon $4] } }
| infix prec ops
{% ams (sLL $1 $> $ SigD
@@ -2088,13 +2089,13 @@ sigdecl :: { LHsDecl RdrName }
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(EmptyInlineSpec, FunLike) (snd $2)
in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
- (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
+ (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
{% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1) (snd $2))))
- (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
+ (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% ams (sLL $1 $>
@@ -2132,19 +2133,19 @@ quasiquote :: { Located (HsSplice RdrName) }
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3 PlaceHolder)
- [mj AnnDcolon $2] }
+ [mu AnnDcolon $2] }
| infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
HsFirstOrderApp True)
- [mj Annlarrowtail $2] }
+ [mu Annlarrowtail $2] }
| infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
HsFirstOrderApp False)
- [mj Annrarrowtail $2] }
+ [mu Annrarrowtail $2] }
| infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
HsHigherOrderApp True)
- [mj AnnLarrowtail $2] }
+ [mu AnnLarrowtail $2] }
| infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
HsHigherOrderApp False)
- [mj AnnRarrowtail $2] }
+ [mu AnnRarrowtail $2] }
| infixexp { $1 }
infixexp :: { LHsExpr RdrName }
@@ -2159,7 +2160,7 @@ exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
{% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match NonFunBindMatch ($2:$3) (snd $4) (unguardedGRHSs $6)]))
- (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) }
+ (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }
| 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
@@ -2205,7 +2206,7 @@ exp10 :: { LHsExpr RdrName }
ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
placeHolderType []))
-- TODO: is LL right here?
- [mj AnnProc $1,mj AnnRarrow $3] }
+ [mj AnnProc $1,mu AnnRarrow $3] }
| '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
[mo $1,mj AnnVal $2
@@ -2372,7 +2373,7 @@ texp :: { LHsExpr RdrName }
| qopm infixexp { sLL $1 $> $ SectionR $1 $2 }
-- View patterns get parenthesized above
- | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mj AnnRarrow $2] }
+ | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
-- Always at least one comma
tup_exprs :: { [LHsTupArg RdrName] }
@@ -2566,7 +2567,7 @@ alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }
ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
: '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
- [mj AnnRarrow $1] }
+ [mu AnnRarrow $1] }
| gdpats { sL1 $1 (reverse (unLoc $1)) }
gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
@@ -2591,7 +2592,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) }
gdpat :: { LGRHS RdrName (LHsExpr RdrName) }
: '|' guardquals '->' exp
{% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
- [mj AnnVbar $1,mj AnnRarrow $3] }
+ [mj AnnVbar $1,mu AnnRarrow $3] }
-- 'pat' recognises a pattern, including one with a bang at the top
-- e.g. "!x" or "!(x,y)" or "C a b" etc
@@ -2669,7 +2670,7 @@ stmt :: { LStmt RdrName (LHsExpr RdrName) }
qual :: { LStmt RdrName (LHsExpr RdrName) }
: bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3)
- [mj AnnLarrow $2] }
+ [mu AnnLarrow $2] }
| exp { sL1 $1 $ mkBodyStmt $1 }
| 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
@@ -2827,7 +2828,7 @@ ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit
(snd $2 + 1)))
(mo $1:mc $3:(mcommas (fst $2))) }
| '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
- [mop $1,mj AnnRarrow $2,mcp $3] }
+ [mop $1,mu AnnRarrow $2,mcp $3] }
| '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
| '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
| '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
@@ -2892,7 +2893,8 @@ tyconsym :: { Located RdrName }
: CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
| VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
| ':' { sL1 $1 $! consDataCon_RDR }
- | '*' { sL1 $1 $! mkUnqual tcClsName (fsLit "*") }
+ | '*' {% ams (sL1 $1 $! mkUnqual tcClsName (fsLit "*"))
+ [mu AnnStar $1] }
| '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
@@ -3030,7 +3032,7 @@ special_id
special_sym :: { Located FastString }
special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
| '.' { sL1 $1 (fsLit ".") }
- | '*' { sL1 $1 (fsLit "*") }
+ | '*' {% ams (sL1 $1 (fsLit "*")) [mu AnnStar $1] }
-----------------------------------------------------------------------------
-- Data constructors
@@ -3192,6 +3194,20 @@ getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
+isUnicode :: Located Token -> Bool
+isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
+isUnicode _ = False
+
getSCC :: Located Token -> P FastString
getSCC lt = do let s = getSTRING lt
err = "Spaces are not allowed in SCCs"
@@ -3324,6 +3340,16 @@ in ApiAnnotation.hs
mj :: AnnKeywordId -> Located e -> AddAnn
mj a l = (\s -> addAnnotation s a (gl l))
+-- |Construct an AddAnn from the annotation keyword and the Located Token. If
+-- the token has a unicode equivalent and this has been used, provide the
+-- unicode variant of the annotation.
+mu :: AnnKeywordId -> Located Token -> AddAnn
+mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
+
+-- | If the 'Token' is using its unicode variant return the unicode variant of
+-- the annotation
+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
+toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
gl = getLoc
@@ -3402,5 +3428,4 @@ oll l =
asl :: [Located a] -> Located b -> Located a -> P()
asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls
asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
-
}
View Lorry Controller Status