Commit 38f289fa authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

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
parent 715be013
......@@ -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
......
......@@ -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 =
......
......@@ -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'],
......
......@@ -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
---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])
]
{-# 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
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment