More Tweaks for API Anotations
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 30 Nov 2014 17:58:31 +0000 (11:58 -0600)
committerAustin Seipp <austin@well-typed.com>
Sun, 30 Nov 2014 17:59:43 +0000 (11:59 -0600)
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

compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsTypes.lhs
compiler/parser/ApiAnnotation.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
testsuite/tests/ghc-api/annotations/annotations.stdout
testsuite/tests/ghc-api/annotations/comments.stdout
testsuite/tests/ghc-api/annotations/parseTree.stdout

index 74e34df..cc68870 100644 (file)
@@ -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
index bfeec5a..af888cd 100644 (file)
@@ -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
 
index 4640a98..510f3dc 100644 (file)
@@ -176,6 +176,7 @@ data AnnKeywordId
     | AnnIf
     | AnnImport
     | AnnIn
+    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'
     | AnnInstance
     | AnnLam
     | AnnLarrow     -- ^ '<-'
index 7f4e718..e3f82ce 100644 (file)
@@ -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
+
 }
index d599381..601d6fe 100644 (file)
@@ -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))
 
index ddf4f8d..2142674 100644 (file)
 
 (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])
 ]
 
index 82ae6e1..25cf555 100644 (file)
@@ -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 #")])
 ]
index ed71b5a..cf8b82e 100644 (file)
@@ -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])
 
 (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])