summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/HsExpr.hs11
-rw-r--r--compiler/parser/Parser.y27
-rw-r--r--testsuite/driver/extra_files.py1
-rw-r--r--testsuite/tests/ghc-api/annotations/Makefile4
-rw-r--r--testsuite/tests/ghc-api/annotations/T12417.stdout68
-rw-r--r--testsuite/tests/ghc-api/annotations/Test12417.hs19
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T1
7 files changed, 116 insertions, 15 deletions
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 18bf54aebc..f4aa88c7aa 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 5119ab439c..222867483c 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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 =
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'])
View Lorry Controller Status