Fix API Annotations for unboxed sums

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

5 files changed, 93 insertions, 0 deletions

diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py
index 8b0f99b768..217e5d437a 100644
--- a/testsuite/driver/extra_files.py
+++ b/testsuite/driver/extra_files.py
@@ -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'],
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 158dadb72c..6a6addae70 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -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
index 0000000000..3f61650d84
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T12417.stdout
@@ -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
index 0000000000..67da7f2107
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test12417.hs
@@ -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
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 831b6a7792..fbe8c3e35f 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -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'])