Commit 0b8dc7d4 authored by Alan Zimmerman's avatar Alan Zimmerman

API Annotations: AnnTilde missing

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
parent f3cc3456
......@@ -70,7 +70,8 @@ module Lexer (
sccProfilingOn, hpcEnabled,
addWarning,
lexTokenStream,
addAnnotation,AddAnn,mkParensApiAnn
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
moveAnnotations
) where
-- base
......@@ -2692,6 +2693,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
......@@ -2708,6 +2713,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
......
......@@ -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
......
......@@ -1053,18 +1053,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
......@@ -1077,7 +1086,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)]
......
......@@ -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
Test11321.hs:12:15: error:
Not in scope: type constructor or class ‘Sing’
---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])
]
{-# 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)
......@@ -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'])
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