Fix API Annotations for unboxed sums
authorAlan Zimmerman <alan.zimm@gmail.com>
Tue, 10 Jan 2017 18:16:34 +0000 (20:16 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Tue, 17 Jan 2017 18:15:10 +0000 (20:15 +0200)
An unboxed tuple such as

    (# | b | | | | | #)

Ends up in the parser via `tup_exprs` as

    Sum 2 7 lexp

where `lexp` is a `LHsExpr`

From an API annotation perspective, the 5 `AnnVbar`s after the `b` were attached
to `lexp`, but the leading `AnnVbar`s did not have a home.

This patch attaches them all to the the parent tuple expression. The first (alt
- 1) of them come before `lexp`, and the remaining (arity - alt) come after.

Test Plan: ./validate

Reviewers: osa1, austin, bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2968

GHC Trac Issues: #12417

compiler/hsSyn/HsExpr.hs
compiler/parser/Parser.y
testsuite/driver/extra_files.py
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T12417.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test12417.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T

index 18bf54a..f4aa88c 100644 (file)
@@ -364,9 +364,16 @@ data HsExpr id
         [LHsTupArg id]
         Boxity
 
+  -- | Used for unboxed sum types
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
+  --          'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@,
+  --
+  --  There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
+  --  the expression, (arity - alternative) after it
   | ExplicitSum
-          ConTag -- Alternative (one-based)
-          Arity  -- Sum arity
+          ConTag --  Alternative (one-based)
+          Arity  --  Sum arity
           (LHsExpr id)
           (PostTc id [Type])   -- the type arguments
 
index 5119ab4..2228674 100644 (file)
@@ -2488,14 +2488,14 @@ aexp2   :: { LHsExpr RdrName }
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
         | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
-        | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) $2
-                                              ; ams (sLL $1 $> e) [mop $1,mcp $3] } }
+        | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
+                                              ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
 
         | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
                                                          (Present $2)] Unboxed))
                                                [mo $1,mc $3] }
-        | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) $2
-                                              ; ams (sLL $1 $> e) [mo $1,mc $3] } }
+        | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
+                                              ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
 
         | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
         | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
@@ -2584,24 +2584,20 @@ texp :: { LHsExpr RdrName }
         | exp '->' texp   {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
 
 -- Always at least one comma or bar.
-tup_exprs :: { SumOrTuple }
+tup_exprs :: { ([AddAnn],SumOrTuple) }
            : texp commas_tup_tail
                           {% do { addAnnotation (gl $1) AnnComma (fst $2)
-                                ; return (Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+                                ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
 
-           | texp bars
-                          {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $2)
-                                ; return (Sum 1  (snd $2 + 1) $1) } }
+           | texp bars    { (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }
 
            | commas tup_tail
                 {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
                       ; return
-                           (Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }
+                           ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }
 
            | bars texp bars0
-                {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $1)
-                      ; mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $3)
-                      ; return (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } }
+                { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
 
 -- Always starts with commas; always follows an expr
 commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) }
@@ -3670,6 +3666,11 @@ mcs ll = mj AnnCloseS ll
 mcommas :: [SrcSpan] -> [AddAnn]
 mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss
 
+-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar
+--  entry for each SrcSpan
+mvbars :: [SrcSpan] -> [AddAnn]
+mvbars ss = map (\s -> mj AnnVbar (L s ())) ss
+
 -- |Get the location of the last element of a OrdList, or noSrcSpan
 oll :: OrdList (Located a) -> SrcSpan
 oll l =
index 8b0f99b..217e5d4 100644 (file)
@@ -43,6 +43,7 @@ extra_src_files = {
   'T10358': ['Test10358.hs'],
   'T10396': ['Test10396.hs'],
   'T10399': ['Test10399.hs'],
+  'T12417': ['Test12417.hs'],
   'T10420': ['rule-defining-plugin/'],
   'T10458': ['A.c'],
   'T10529a': ['hpc_sample_non_existing_module.tix'],
index 158dadb..6a6adda 100644 (file)
@@ -133,3 +133,7 @@ T11430:
 .PHONY: load-main
 load-main:
        $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs
+
+.PHONY: T12417
+T12417:
+       $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs
diff --git a/testsuite/tests/ghc-api/annotations/T12417.stdout b/testsuite/tests/ghc-api/annotations/T12417.stdout
new file mode 100644 (file)
index 0000000..3f61650
--- /dev/null
@@ -0,0 +1,68 @@
+---Problems (should be empty list)---
+[]
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+--    list of locations the keyword item appears in
+[
+((Test12417.hs:1:1,AnnModule), [Test12417.hs:3:1-6]),
+((Test12417.hs:1:1,AnnWhere), [Test12417.hs:3:18-22]),
+((Test12417.hs:5:1-15,AnnImport), [Test12417.hs:5:1-6]),
+((Test12417.hs:5:1-15,AnnSemi), [Test12417.hs:6:1]),
+((Test12417.hs:6:1-16,AnnImport), [Test12417.hs:6:1-6]),
+((Test12417.hs:6:1-16,AnnSemi), [Test12417.hs:8:1]),
+((Test12417.hs:8:1-34,AnnImport), [Test12417.hs:8:1-6]),
+((Test12417.hs:8:1-34,AnnSemi), [Test12417.hs:10:1]),
+((Test12417.hs:8:19-34,AnnCloseP), [Test12417.hs:8:34]),
+((Test12417.hs:8:19-34,AnnOpenP), [Test12417.hs:8:19]),
+((Test12417.hs:10:1-30,AnnEqual), [Test12417.hs:10:18]),
+((Test12417.hs:10:1-30,AnnSemi), [Test12417.hs:12:1]),
+((Test12417.hs:10:1-30,AnnType), [Test12417.hs:10:1-4]),
+((Test12417.hs:10:20-30,AnnClose), [Test12417.hs:10:29-30]),
+((Test12417.hs:10:20-30,AnnOpen), [Test12417.hs:10:20-21]),
+((Test12417.hs:10:23,AnnVbar), [Test12417.hs:10:25]),
+((Test12417.hs:12:1-56,AnnDcolon), [Test12417.hs:12:13-14]),
+((Test12417.hs:12:1-56,AnnSemi), [Test12417.hs:13:1]),
+((Test12417.hs:12:16-31,AnnCloseP), [Test12417.hs:12:31, Test12417.hs:12:31]),
+((Test12417.hs:12:16-31,AnnDarrow), [Test12417.hs:12:33-34]),
+((Test12417.hs:12:16-31,AnnOpenP), [Test12417.hs:12:16, Test12417.hs:12:16]),
+((Test12417.hs:12:17-22,AnnComma), [Test12417.hs:12:23]),
+((Test12417.hs:12:36-56,AnnRarrow), [Test12417.hs:12:48-49]),
+((Test12417.hs:13:1-48,AnnEqual), [Test12417.hs:13:27]),
+((Test12417.hs:13:1-48,AnnFunId), [Test12417.hs:13:1-11]),
+((Test12417.hs:13:1-48,AnnSemi), [Test12417.hs:14:1]),
+((Test12417.hs:13:13-24,AnnClose), [Test12417.hs:13:23-24]),
+((Test12417.hs:13:13-24,AnnOpen), [Test12417.hs:13:13-14]),
+((Test12417.hs:13:13-24,AnnVbar), [Test12417.hs:13:21]),
+((Test12417.hs:13:29-48,AnnVal), [Test12417.hs:13:37-38]),
+((Test12417.hs:14:1-50,AnnEqual), [Test12417.hs:14:27]),
+((Test12417.hs:14:1-50,AnnFunId), [Test12417.hs:14:1-11]),
+((Test12417.hs:14:1-50,AnnSemi), [Test12417.hs:16:1]),
+((Test12417.hs:14:13-25,AnnClose), [Test12417.hs:14:24-25]),
+((Test12417.hs:14:13-25,AnnOpen), [Test12417.hs:14:13-14]),
+((Test12417.hs:14:13-25,AnnVbar), [Test12417.hs:14:16]),
+((Test12417.hs:14:29-50,AnnVal), [Test12417.hs:14:38-39]),
+((Test12417.hs:16:1-75,AnnEqual), [Test12417.hs:16:8]),
+((Test12417.hs:16:1-75,AnnSemi), [Test12417.hs:18:1]),
+((Test12417.hs:16:1-75,AnnType), [Test12417.hs:16:1-4]),
+((Test12417.hs:16:10-75,AnnClose), [Test12417.hs:16:74-75]),
+((Test12417.hs:16:10-75,AnnOpen), [Test12417.hs:16:10-11]),
+((Test12417.hs:16:13-15,AnnVbar), [Test12417.hs:16:17]),
+((Test12417.hs:16:19-22,AnnVbar), [Test12417.hs:16:24]),
+((Test12417.hs:16:26-31,AnnVbar), [Test12417.hs:16:33]),
+((Test12417.hs:16:35-38,AnnVbar), [Test12417.hs:16:40]),
+((Test12417.hs:16:42-56,AnnVbar), [Test12417.hs:16:58]),
+((Test12417.hs:16:60-63,AnnVbar), [Test12417.hs:16:65]),
+((Test12417.hs:18:1-26,AnnDcolon), [Test12417.hs:18:13-14]),
+((Test12417.hs:18:1-26,AnnSemi), [Test12417.hs:19:1]),
+((Test12417.hs:18:16-26,AnnRarrow), [Test12417.hs:18:18-19]),
+((Test12417.hs:19:1-52,AnnEqual), [Test12417.hs:19:33]),
+((Test12417.hs:19:1-52,AnnFunId), [Test12417.hs:19:1-11]),
+((Test12417.hs:19:1-52,AnnSemi), [Test12417.hs:20:1]),
+((Test12417.hs:19:13-31,AnnClose), [Test12417.hs:19:30-31]),
+((Test12417.hs:19:13-31,AnnOpen), [Test12417.hs:19:13-14]),
+((Test12417.hs:19:13-31,AnnVbar), [Test12417.hs:19:16, Test12417.hs:19:20, Test12417.hs:19:22,
+ Test12417.hs:19:24, Test12417.hs:19:26, Test12417.hs:19:28]),
+((Test12417.hs:19:35-52,AnnVal), [Test12417.hs:19:44-45]),
+((<no location info>,AnnEofPos), [Test12417.hs:20:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test12417.hs b/testsuite/tests/ghc-api/annotations/Test12417.hs
new file mode 100644 (file)
index 0000000..67da7f2
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Test12417 where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type Either1 a b = (# a | b #)
+
+showEither1 :: (Show a, Show b) => Either1 a b -> String
+showEither1 (# left | #)  = "Left " ++ show left
+showEither1 (# | right #) = "Right " ++ show right
+
+type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)
+
+showEither4 :: T -> String
+showEither4 (# | b | | | | | #) = "Alt1: " ++ show b
index 831b6a7..fbe8c3e 100644 (file)
@@ -26,3 +26,4 @@ test('T11321',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory
 test('T11332',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T11332'])
 test('T11430',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T11430'])
 test('load-main',   ignore_stderr, run_command, ['$MAKE -s --no-print-directory load-main'])
+test('T12417',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T12417'])