API Annotations: AnnTilde missing
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 1 Jan 2016 16:59:52 +0000 (18:59 +0200)
committerBen Gamari <ben@smart-cactus.org>
Fri, 1 Jan 2016 19:29:39 +0000 (20:29 +0100)
In T10689a.hs, the fragment

    data instance Sing (z :: [a])
      = z ~ '[] =>
        SNil
      | forall (m :: a)
               (n :: [a]). z ~ (:) m n =>
        SCons (Sing m) (Sing n)

ends up with the AnnTilde annotations for the two tildes not attached to
the final AST.

This patch moves the AnnTilde to the right place.

Closes #11321

(cherry picked from commit 0b8dc7d4d5b26e184a7698e22f9fe7d8ee3c90d4)

compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T11321.stderr [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/T11321.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test11321.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T

index 1bbbfbf..fb2aab5 100644 (file)
@@ -70,7 +70,8 @@ module Lexer (
    sccProfilingOn, hpcEnabled,
    addWarning,
    lexTokenStream,
-   addAnnotation,AddAnn,mkParensApiAnn
+   addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
+   moveAnnotations
   ) where
 
 -- base
@@ -2696,6 +2697,10 @@ addAnnotationOnly l a v = P $ \s -> POk s {
   annotations = ((l,a), [v]) : annotations s
   } ()
 
+-- |Given a location and a list of AddAnn, apply them all to the location.
+addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
+addAnnsAt loc anns = mapM_ (\a -> a loc) anns
+
 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
 -- 'AddAnn' values for the opening and closing bordering on the start
 -- and end of the span
@@ -2712,6 +2717,23 @@ mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
 
+-- | Move the annotations and comments belonging to the @old@ span to the @new@
+--   one.
+moveAnnotations :: SrcSpan -> SrcSpan -> P ()
+moveAnnotations old new = P $ \s ->
+  let
+    updateAnn ((l,a),v)
+      | l == old = ((new,a),v)
+      | otherwise = ((l,a),v)
+    updateComment (l,c)
+      | l == old = (new,c)
+      | otherwise = (l,c)
+  in
+    POk s {
+       annotations = map updateAnn (annotations s)
+     , annotations_comments = map updateComment (annotations_comments s)
+     } ()
+
 queueComment :: Located Token -> P()
 queueComment c = P $ \s -> POk s {
   comment_q = commentToAnnotation c : comment_q s
index 9ddeb56..ef6c0f5 100644 (file)
@@ -1591,7 +1591,7 @@ context :: { LHsContext RdrName }
                                                 } }
 
 context_no_ops :: { LHsContext RdrName }
-        : btype_no_ops                 {% do { let { ty = splitTilde $1 }
+        : btype_no_ops                 {% do { ty <- splitTilde $1
                                              ; (anns,ctx) <- checkContext ty
                                              ; if null (unLoc ctx)
                                                    then addAnnotation (gl ty) AnnUnit (gl ty)
@@ -1899,7 +1899,8 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
     -- see Note [Parsing data constructors is hard]
         : btype_no_ops                         {% do { c <- splitCon $1
                                                      ; return $ sLL $1 $> c } }
-        | btype_no_ops conop btype_no_ops      {  sLL $1 $> ($2, InfixCon (splitTilde $1) $3) }
+        | btype_no_ops conop btype_no_ops      {% do { ty <- splitTilde $1
+                                                     ; return $ sLL $1 $> ($2, InfixCon ty $3) } }
 
 {- Note [Parsing data constructors is hard]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3337,9 +3338,6 @@ in ApiAnnotation.hs
 
 -}
 
-addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
-addAnnsAt loc anns = mapM_ (\a -> a loc) anns
-
 -- |Construct an AddAnn from the annotation keyword and the location
 -- of the keyword itself
 mj :: AnnKeywordId -> Located e -> AddAnn
index 0f38086..1094f49 100644 (file)
@@ -1057,18 +1057,27 @@ isFunLhs e = go e [] []
 
 -- | Transform btype_no_ops with strict_mark's into HsEqTy's
 -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
-splitTilde :: LHsType RdrName -> LHsType RdrName
+splitTilde :: LHsType RdrName -> P (LHsType RdrName)
 splitTilde t = go t
   where go (L loc (HsAppTy t1 t2))
-          | L _ (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
-          = L loc (HsEqTy (go t1) t2')
+          | L lo (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
+          = do
+              moveAnnotations lo loc
+              t1' <- go t1
+              return (L loc (HsEqTy t1' t2'))
           | otherwise
-          = case go t1 of
-              (L _ (HsEqTy tl tr)) ->
-                L loc (HsEqTy tl (L (combineLocs tr t2) (HsAppTy tr t2)))
-              t -> L loc (HsAppTy t t2)
+          = do
+              t1' <- go t1
+              case t1' of
+                (L lo (HsEqTy tl tr)) -> do
+                  let lr = combineLocs tr t2
+                  moveAnnotations lo loc
+                  return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
+                t -> do
+                  return (L loc (HsAppTy t t2))
+
+        go t = return t
 
-        go t = t
 
 -- | Transform tyapps with strict_marks into uses of twiddle
 -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
@@ -1081,7 +1090,7 @@ splitTildeApps (t : rest) = do
             (L loc (HsBangTy
                     (HsSrcBang Nothing NoSrcUnpack SrcLazy)
                     ty))))
-          = addAnnotation l AnnTilde l >>
+          = addAnnotation l AnnTilde tilde_loc >>
             return
               [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
                L l (HsAppPrefix ty)]
index d0b9c2f..5947455 100644 (file)
@@ -110,3 +110,7 @@ T11018:
 .PHONY: T10276
 T10276:
        $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276
+
+.PHONY: T11321
+T11321:
+       $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11321
diff --git a/testsuite/tests/ghc-api/annotations/T11321.stderr b/testsuite/tests/ghc-api/annotations/T11321.stderr
new file mode 100644 (file)
index 0000000..8e26d46
--- /dev/null
@@ -0,0 +1,3 @@
+
+Test11321.hs:12:15: error:
+    Not in scope: type constructor or class ‘Sing’
diff --git a/testsuite/tests/ghc-api/annotations/T11321.stdout b/testsuite/tests/ghc-api/annotations/T11321.stdout
new file mode 100644 (file)
index 0000000..d4df67d
--- /dev/null
@@ -0,0 +1,45 @@
+---Problems (should be empty list)---
+[]
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+--    list of locations the keyword item appears in
+[
+((Test11321.hs:1:1,AnnModule), [Test11321.hs:10:1-6]),
+((Test11321.hs:1:1,AnnWhere), [Test11321.hs:10:18-22]),
+((Test11321.hs:(12,1)-(17,27),AnnData), [Test11321.hs:12:1-4]),
+((Test11321.hs:(12,1)-(17,27),AnnEqual), [Test11321.hs:13:3]),
+((Test11321.hs:(12,1)-(17,27),AnnInstance), [Test11321.hs:12:6-13]),
+((Test11321.hs:(12,1)-(17,27),AnnSemi), [Test11321.hs:18:1]),
+((Test11321.hs:12:20-29,AnnCloseP), [Test11321.hs:12:29]),
+((Test11321.hs:12:20-29,AnnDcolon), [Test11321.hs:12:23-24]),
+((Test11321.hs:12:20-29,AnnOpenP), [Test11321.hs:12:20]),
+((Test11321.hs:12:26-28,AnnCloseS), [Test11321.hs:12:28]),
+((Test11321.hs:12:26-28,AnnOpenS), [Test11321.hs:12:26]),
+((Test11321.hs:13:5-11,AnnTilde), [Test11321.hs:13:7]),
+((Test11321.hs:(13,5)-(14,8),AnnDarrow), [Test11321.hs:13:13-14]),
+((Test11321.hs:(13,5)-(14,8),AnnVbar), [Test11321.hs:15:3]),
+((Test11321.hs:13:9-11,AnnCloseS), [Test11321.hs:13:11]),
+((Test11321.hs:13:9-11,AnnOpenS), [Test11321.hs:13:10]),
+((Test11321.hs:13:9-11,AnnSimpleQuote), [Test11321.hs:13:9]),
+((Test11321.hs:(15,5)-(17,27),AnnDarrow), [Test11321.hs:16:36-37]),
+((Test11321.hs:(15,5)-(17,27),AnnDot), [Test11321.hs:16:22]),
+((Test11321.hs:(15,5)-(17,27),AnnForall), [Test11321.hs:15:5-10]),
+((Test11321.hs:15:12-19,AnnCloseP), [Test11321.hs:15:19]),
+((Test11321.hs:15:12-19,AnnDcolon), [Test11321.hs:15:15-16]),
+((Test11321.hs:15:12-19,AnnOpenP), [Test11321.hs:15:12]),
+((Test11321.hs:16:12-21,AnnCloseP), [Test11321.hs:16:21]),
+((Test11321.hs:16:12-21,AnnDcolon), [Test11321.hs:16:15-16]),
+((Test11321.hs:16:12-21,AnnOpenP), [Test11321.hs:16:12]),
+((Test11321.hs:16:18-20,AnnCloseS), [Test11321.hs:16:20]),
+((Test11321.hs:16:18-20,AnnOpenS), [Test11321.hs:16:18]),
+((Test11321.hs:16:24-34,AnnTilde), [Test11321.hs:16:26]),
+((Test11321.hs:16:28-30,AnnCloseP), [Test11321.hs:16:30]),
+((Test11321.hs:16:28-30,AnnOpenP), [Test11321.hs:16:28]),
+((Test11321.hs:16:28-30,AnnVal), [Test11321.hs:16:29]),
+((Test11321.hs:17:11-18,AnnCloseP), [Test11321.hs:17:18]),
+((Test11321.hs:17:11-18,AnnOpenP), [Test11321.hs:17:11]),
+((Test11321.hs:17:20-27,AnnCloseP), [Test11321.hs:17:27]),
+((Test11321.hs:17:20-27,AnnOpenP), [Test11321.hs:17:20]),
+((<no location info>,AnnEofPos), [Test11321.hs:18:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test11321.hs b/testsuite/tests/ghc-api/annotations/Test11321.hs
new file mode 100644 (file)
index 0000000..d88d997
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeOperators
+           , DataKinds
+           , PolyKinds
+           , TypeFamilies
+           , GADTs
+           , UndecidableInstances
+           , RankNTypes
+           , ScopedTypeVariables
+  #-}
+module Test11321 where
+
+data instance Sing (z :: [a])
+  = z ~ '[] =>
+    SNil
+  | forall (m :: a)
+           (n :: [a]). z ~ (:) m n =>
+    SCons (Sing m) (Sing n)
index c7c8542..ad6682e 100644 (file)
@@ -21,3 +21,4 @@ test('T10313',      normal, run_command, ['$MAKE -s --no-print-directory T10313'
 test('T11018',      normal, run_command, ['$MAKE -s --no-print-directory T11018'])
 test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export'])
 test('T10276',      normal, run_command, ['$MAKE -s --no-print-directory T10276'])
+test('T11321',      normal, run_command, ['$MAKE -s --no-print-directory T11321'])