Skip to content

GitLab

GHC
GHC
Commit ed85d7e1 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp
Browse files
Options

More Tweaks for API Anotations 

Summary: Attaching semis to preceding AST element, not following

Test Plan: sh ./validate

Reviewers: hvr, austin

Reviewed By: austin

Subscribers: cactus, thomie, carter

Differential Revision: https://phabricator.haskell.org/D529
parent 6d47ab3a
Hide whitespace changes
Inline Side-by-side
Showing with 94 additions and 47 deletions
compiler/hsSyn/HsBinds.lhs
View file @ ed85d7e1
......@@ -585,7 +585,9 @@ type LSig name = Located (Sig name)
-- | Signatures and pragmas
data Sig name
= -- | An ordinary type signature
-- @f :: Num a => a -> a@
--
-- > f :: Num a => a -> a
--
-- After renaming, this list of Names contains the named and unnamed
-- wildcards brought into scope by this signature. For a signature
-- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
......@@ -599,7 +601,12 @@ data Sig name
TypeSig [Located name] (LHsType name) (PostRn name [Name])
-- | A pattern synonym type signature
-- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
--
-- > pattern Single :: () => (Show a) => a -> [a]
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
| PatSynSig (Located name)
(HsExplicitFlag, LHsTyVarBndrs name)
(LHsContext name) -- Provided context
......@@ -610,6 +617,8 @@ data Sig name
--
-- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon'
| GenericSig [Located name] (LHsType name)
-- | A type signature in generated code, notably the code
......@@ -617,16 +626,15 @@ data Sig name
-- the desired Id itself, replete with its name, type
-- and IdDetails. Otherwise it's just like a type
-- signature: there should be an accompanying binding
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnDotdot'
| IdSig Id
-- | An ordinary fixity declaration
--
-- > infixl 8 ***
--
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
-- 'ApiAnnotation.AnnVal'
| FixSig (FixitySig name)
-- | An inline pragma
......
compiler/hsSyn/HsTypes.lhs
View file @ ed85d7e1
......@@ -17,6 +17,7 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
HsTyOp,LHsTyOp,
HsTyVarBndr(..), LHsTyVarBndr,
LHsTyVarBndrs(..),
HsWithBndrs(..),
......@@ -247,6 +248,7 @@ data HsType name
| HsFunTy (LHsType name) -- function type
(LHsType name)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
| HsListTy (LHsType name) -- Element type
......
compiler/parser/ApiAnnotation.hs
View file @ ed85d7e1
......@@ -176,6 +176,7 @@ data AnnKeywordId
| AnnIf
| AnnImport
| AnnIn
| AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'
| AnnInstance
| AnnLam
| AnnLarrow -- ^ '<-'
......
compiler/parser/Parser.y
View file @ ed85d7e1
......@@ -234,6 +234,21 @@ Be careful: there's no checking that you actually got this right, the
only symptom will be that the SrcSpans of your syntax will be
incorrect.
-- -----------------------------------------------------------------------------
-- API Annotations
A lot of the productions are now cluttered with calls to
aa,am,ams,amms etc.
These are helper functions to make sure that the locations of the
various keywords such as do / let / in are captured for use by tools
that want to do source to source conversions, such as refactorers or
structured editors.
The helper functions are defined at the bottom of this file.
See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background.
-- -----------------------------------------------------------------------------
-}
......@@ -581,7 +596,7 @@ qcname :: { Located RdrName } -- Variable or data constructor
-- whereas topdecls must contain at least one topdecl.
importdecls :: { [LImportDecl RdrName] }
: importdecls ';' importdecl {% (aa $3 (AnnSemi, $2)) >>
: importdecls ';' importdecl {% (asl $1 $2 $3) >>
return ($3 : $1) }
| importdecls ';' {% addAnnotation (gl $ head $1) AnnSemi (gl $2)
-- AZ: can $1 above ever be [] due to the {- empty -} production?
......@@ -637,9 +652,10 @@ impspec :: { Located (Bool, Located [LIE RdrName]) }
-----------------------------------------------------------------------------
-- Fixity Declarations
prec :: { Int }
: {- empty -} { 9 }
| INTEGER {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
prec :: { Located Int }
: {- empty -} { noLoc 9 }
| INTEGER
{% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
infix :: { Located FixityDirection }
: 'infix' { sL1 $1 InfixN }
......@@ -655,7 +671,7 @@ ops :: { Located (OrdList (Located RdrName)) }
-- Top-Level Declarations
topdecls :: { OrdList (LHsDecl RdrName) }
: topdecls ';' topdecl {% addAnnotation (oll $3) AnnSemi (gl $2)
: topdecls ';' topdecl {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return ($1 `appOL` $3) }
| topdecls ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return $1 }
......@@ -831,7 +847,7 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
{% addAnnotation (gl $3) AnnSemi (gl $2)
{% asl (unLoc $1) $2 $3
>> return (sLL $1 $> ($3 : unLoc $1)) }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
......@@ -1012,22 +1028,28 @@ where_decls :: { Located ([AddAnn]
,$3) }
pattern_synonym_sig :: { LSig RdrName }
: 'pattern' con '::' ptype
{% do { let (flag, qtvs, prov, req, ty) = unLoc $4
{% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4
; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty
; checkValidPatSynSig sig
; return $ sLL $1 $> $ sig } }
; ams (sLL $1 $> $ sig)
(mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } }
ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, LHsContext RdrName, LHsType RdrName) }
ptype :: { Located ([AddAnn]
,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName
, LHsContext RdrName, LHsType RdrName)) }
: 'forall' tv_bndrs '.' ptype
{% do { hintExplicitForall (getLoc $1)
; let (_, qtvs', prov, req, ty) = unLoc $4
; return $ sLL $1 $> (Explicit, $2 ++ qtvs', prov, req ,ty) }}
; let (_, qtvs', prov, req, ty) = snd $ unLoc $4
; return $ sLL $1 $>
((mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4))
,(Explicit, $2 ++ qtvs', prov, req ,ty)) }}
| context '=>' context '=>' type
{ sLL $1 $> (Implicit, [], $1, $3, $5) }
{ sLL $1 $> ([mj AnnDarrow $2,mj AnnDarrow $4]
,(Implicit, [], $1, $3, $5)) }
| context '=>' type
{ sLL $1 $> (Implicit, [], $1, noLoc [], $3) }
{ sLL $1 $> ([mj AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) }
| type
{ sL1 $1 (Implicit, [], noLoc [], noLoc [], $1) }
{ sL1 $1 ([],(Implicit, [], noLoc [], noLoc [], $1)) }
-----------------------------------------------------------------------------
-- Nested declarations
......@@ -1051,10 +1073,10 @@ decl_cls : at_decl_cls { sLL $1 $> (unitOL $1) }
[mj AnnDefault $1,mj AnnDcolon $3] } }
decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls {% addAnnotation (gl $3) AnnSemi (gl $2)
: decls_cls ';' decl_cls {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2)
>> return (sLL $1 $> ((unLoc $1) `appOL`
unLoc $3)) }
| decls_cls ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
| decls_cls ';' {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
| decl_cls { $1 }
| {- empty -} { noLoc nilOL }
......@@ -1083,10 +1105,10 @@ decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLo
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_inst ';' decl_inst {% addAnnotation (gl $3) AnnSemi (gl $2)
: decls_inst ';' decl_inst {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
>> return
(sLL $1 $> ((unLoc $1) `appOL` unLoc $3)) }
| decls_inst ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
| decls_inst ';' {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
| decl_inst { $1 }
| {- empty -} { noLoc nilOL }
......@@ -1110,14 +1132,14 @@ where_inst :: { Located ([AddAnn]
-- Declarations in binding groups other than classes and instances
--
decls :: { Located (OrdList (LHsDecl RdrName)) }
: decls ';' decl {% addAnnotation (gl $3) AnnSemi (gl $2)
: decls ';' decl {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
>> return (
let { this = unLoc $3;
rest = unLoc $1;
these = rest `appOL` this }
in rest `seq` this `seq` these `seq`
sLL $1 $> these) }
| decls ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
| decls ';' {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
| decl { $1 }
| {- empty -} { noLoc nilOL }
......@@ -1156,7 +1178,7 @@ wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) }
-- Transformation Rules
rules :: { OrdList (LHsDecl RdrName) }
: rules ';' rule {% addAnnotation (gl $3) AnnSemi (gl $2)
: rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return ($1 `snocOL` $3) }
| rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return $1 }
......@@ -1203,7 +1225,7 @@ rule_var :: { LRuleBndr RdrName }
-- Warnings and deprecations (c.f. rules)
warnings :: { OrdList (LHsDecl RdrName) }
: warnings ';' warning {% addAnnotation (oll $3) AnnSemi (gl $2)
: warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return ($1 `appOL` $3) }
| warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return $1 }
......@@ -1218,7 +1240,7 @@ warning :: { OrdList (LHsDecl RdrName) }
deprecations :: { OrdList (LHsDecl RdrName) }
: deprecations ';' deprecation
{% addAnnotation (oll $3) AnnSemi (gl $2)
{% addAnnotation (oll $1) AnnSemi (gl $2)
>> return ($1 `appOL` $3) }
| deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
>> return $1 }
......@@ -1346,7 +1368,7 @@ ctype :: { LHsType RdrName }
$1 $3)
[mj AnnDarrow $2] }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
[mj AnnDcolon $2] }
[mj AnnVal $1,mj AnnDcolon $2] }
| type { $1 }
----------------------
......@@ -1803,8 +1825,10 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
[mj AnnComma $2,mj AnnDcolon $4] } }
| infix prec ops
{ sLL $1 $> $ toOL [ sLL $1 $> $ SigD
(FixSig (FixitySig (fromOL $ unLoc $3) (Fixity $2 (unLoc $1)))) ] }
{% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD
(FixSig (FixitySig (fromOL $ unLoc $3)
(Fixity (unLoc $2) (unLoc $1)))) ])
[mj AnnInfix $1,mj AnnVal $2] }
| pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
......@@ -1813,8 +1837,6 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
(mkInlinePragma (getINLINE $1) (snd $2)))))
(mo $1:mc $4:fst $2) }
-- AZ TODO: adjust hsSyn so all the SpecSig from a single SPECIALISE
-- pragma is kept together
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% ams (
let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) (snd $2)
......@@ -2961,6 +2983,7 @@ aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a)
aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
-- |Add an annotation to a located element resulting from a monadic action
am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
am a (b,s) = do
av@(L l _) <- a
addAnnotation l b (gl s)
......@@ -2984,6 +3007,7 @@ amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
amsu a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return (unitOL a)
-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> SrcSpan -> P ()
mo ll = mj AnnOpen ll
mc ll = mj AnnClose ll
......@@ -2993,9 +3017,13 @@ mcommas :: [SrcSpan] -> [AddAnn]
mcommas ss = map (\s -> mj AnnComma (L s ())) ss
-- |Add the annotation to an AST element wrapped in a Just
ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan
-> P (Located (Maybe (Located a)))
ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a
-- |Add all [AddAnn] to an AST element wrapped in a Just
aljs :: Located (Maybe (Located a)) -> [AddAnn]
-> P (Located (Maybe (Located a)))
aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a
-- |Add all [AddAnn] to an AST element wrapped in a Just
......@@ -3006,4 +3034,11 @@ oll :: OrdList (Located a) -> SrcSpan
oll l = case fromOL l of
[] -> noSrcSpan
xs -> getLoc (last xs)
-- |Add a semicolon annotation in the right place in a list. If the
-- leading list is empty, add it to the tail
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
}
compiler/parser/RdrHsSyn.hs
View file @ ed85d7e1
......@@ -1296,9 +1296,9 @@ cmdStmtFail loc e = parseErrorSDoc loc
---------------------------------------------------------------------------
-- Miscellaneous utilities
checkPrecP :: Located Int -> P Int
checkPrecP :: Located Int -> P (Located Int)
checkPrecP (L l i)
| 0 <= i && i <= maxPrecedence = return i
| 0 <= i && i <= maxPrecedence = return (L l i)
| otherwise
= parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
......
testsuite/tests/ghc-api/annotations/annotations.stdout
View file @ ed85d7e1
......@@ -35,18 +35,18 @@
(AK AnnotationLet.hs:7:9-15 AnnFunId = [AnnotationLet.hs:7:9])
(AK AnnotationLet.hs:7:9-15 AnnSemi = [AnnotationLet.hs:8:9])
(AK AnnotationLet.hs:8:9-15 AnnEqual = [AnnotationLet.hs:8:13])
(AK AnnotationLet.hs:8:9-15 AnnFunId = [AnnotationLet.hs:8:9])
(AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:8:9])
(AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:9:9])
(AK AnnotationLet.hs:9:9-13 AnnEqual = [AnnotationLet.hs:9:11])
(AK AnnotationLet.hs:9:9-13 AnnFunId = [AnnotationLet.hs:9:9])
(AK AnnotationLet.hs:9:9-13 AnnSemi = [AnnotationLet.hs:9:9])
(AK <no location info> AnnEofPos = [AnnotationLet.hs:13:1])
]
......
testsuite/tests/ghc-api/annotations/comments.stdout
View file @ ed85d7e1
[
( CommentsTest.hs:9:1-33 =
[(CommentsTest.hs:9:1-33,AnnDocCommentNext " The function @foo@ does blah")])
( CommentsTest.hs:(10,7)-(13,14) =
[(CommentsTest.hs:12:15-24,AnnLineComment "-- value 2")])
( <no location info> =
[(CommentsTest.hs:9:1-33,AnnDocCommentNext " The function @foo@ does blah"),
(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
[(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
(CommentsTest.hs:1:1-31,AnnBlockComment "# LANGUAGE DeriveFoldable #")])
]
......
testsuite/tests/ghc-api/annotations/parseTree.stdout
View file @ ed85d7e1
......@@ -39,6 +39,8 @@
(AK AnnotationTuple.hs:(7,1)-(10,14) AnnFunId = [AnnotationTuple.hs:7:1-3])
(AK AnnotationTuple.hs:(7,1)-(10,14) AnnSemi = [AnnotationTuple.hs:12:1])
(AK AnnotationTuple.hs:(7,7)-(10,14) AnnIn = [AnnotationTuple.hs:10:7-8])
(AK AnnotationTuple.hs:(7,7)-(10,14) AnnLet = [AnnotationTuple.hs:7:7-9])
......@@ -47,17 +49,17 @@
(AK AnnotationTuple.hs:8:9-13 AnnFunId = [AnnotationTuple.hs:8:9])
(AK AnnotationTuple.hs:8:9-13 AnnSemi = [AnnotationTuple.hs:9:9])
(AK AnnotationTuple.hs:9:9-13 AnnEqual = [AnnotationTuple.hs:9:11])
(AK AnnotationTuple.hs:9:9-13 AnnFunId = [AnnotationTuple.hs:9:9])
(AK AnnotationTuple.hs:9:9-13 AnnSemi = [AnnotationTuple.hs:9:9])
(AK AnnotationTuple.hs:13:1-72 AnnEqual = [AnnotationTuple.hs:13:5])
(AK AnnotationTuple.hs:13:1-72 AnnFunId = [AnnotationTuple.hs:13:1-3])
(AK AnnotationTuple.hs:13:1-72 AnnSemi = [AnnotationTuple.hs:12:1])
(AK AnnotationTuple.hs:13:1-72 AnnSemi = [AnnotationTuple.hs:14:1])
(AK AnnotationTuple.hs:13:19-53 AnnClose = [AnnotationTuple.hs:13:53])
......@@ -95,8 +97,6 @@
(AK AnnotationTuple.hs:15:1-41 AnnFunId = [AnnotationTuple.hs:15:1-3])
(AK AnnotationTuple.hs:15:1-41 AnnSemi = [AnnotationTuple.hs:14:1])
(AK AnnotationTuple.hs:15:7-27 AnnClose = [AnnotationTuple.hs:15:27])
(AK AnnotationTuple.hs:15:7-27 AnnOpen = [AnnotationTuple.hs:15:7])
......
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