Commit fe95463b authored by Alan Zimmerman's avatar Alan Zimmerman

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
parent 46a03fbe
......@@ -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 '*'?
......@@ -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
......
......@@ -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