diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2014-11-30 11:58:31 -0600 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2014-11-30 11:59:43 -0600 |
commit | ed85d7e1ab0384bf00729b9b2fd1ef6bf25caebc (patch) | |
tree | f13bf10f348e29d2c51e16c48aaf974dbbc55544 | |
parent | 6d47ab3ab3684c4245bdccd97d19db83887aae9c (diff) | |
download | haskell-ed85d7e1ab0384bf00729b9b2fd1ef6bf25caebc.tar.gz |
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
-rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 20 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 2 | ||||
-rw-r--r-- | compiler/parser/ApiAnnotation.hs | 1 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 91 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/annotations.stdout | 6 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/comments.stdout | 7 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/parseTree.stdout | 10 |
8 files changed, 94 insertions, 47 deletions
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 74e34df7b9..cc68870ce5 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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 diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index bfeec5a899..af888cdae9 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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 diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index 4640a98219..510f3dc580 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -176,6 +176,7 @@ data AnnKeywordId | AnnIf | AnnImport | AnnIn + | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' | AnnInstance | AnnLam | AnnLarrow -- ^ '<-' diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 7f4e7185bd..e3f82ceb95 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -235,6 +235,21 @@ 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 + } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index d5993819f2..601d6fed46 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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)) diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout b/testsuite/tests/ghc-api/annotations/annotations.stdout index ddf4f8d3cf..2142674f9b 100644 --- a/testsuite/tests/ghc-api/annotations/annotations.stdout +++ b/testsuite/tests/ghc-api/annotations/annotations.stdout @@ -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]) ] diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout index 82ae6e1f50..25cf55557c 100644 --- a/testsuite/tests/ghc-api/annotations/comments.stdout +++ b/testsuite/tests/ghc-api/annotations/comments.stdout @@ -1,11 +1,12 @@ [ +( 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 #")]) ] diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout index ed71b5a3f4..cf8b82e029 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.stdout +++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout @@ -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]) |