Skip to content

GitLab

Commit f34c0728 authored by Austin Seipp's avatar Austin Seipp
Browse files
Options

Revert "ApiAnnotations : Nested forall loses forall annotation" 

This reverts commit 81030ede.

Alan is abandoning this approach in favor of D836.
parent 81030ede
Hide whitespace changes
Inline Side-by-side
Showing with 37 additions and 284 deletions
compiler/parser/Parser.y
View file @ f34c0728
......@@ -565,7 +565,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) }
%name parseFullStmt stmt
%name parseStmt maybe_stmt
%name parseIdentifier identifier
%name parseType ctype_noann
%name parseType ctype
%partial parseHeader header
%%
......@@ -909,7 +909,7 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% amms (mkTySynonym (comb2 $1 $4) $2 (snd $ unLoc $4))
{% amms (mkTySynonym (comb2 $1 $4) $2 $4)
[mj AnnType $1,mj AnnEqual $3] }
-- type family declarations
......@@ -1024,7 +1024,7 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
: type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { (eqn,ann) <- mkTyFamInstEqn $1 (snd $ unLoc $3)
{% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } }
-- Associated type family declarations
......@@ -1404,7 +1404,7 @@ rule_var_list :: { [LRuleBndr RdrName] }
rule_var :: { LRuleBndr RdrName }
: varid { sLL $1 $> (RuleBndr $1) }
| '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2
(mkHsWithBndrs (snd $ unLoc $4))))
(mkHsWithBndrs $4)))
[mop $1,mj AnnDcolon $3,mcp $5] }
-----------------------------------------------------------------------------
......@@ -1518,13 +1518,11 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
sigtype :: { LHsType RdrName } -- Always a HsForAllTy,
-- to tell the renamer where to generalise
: ctype {% ams (sL1 $1 (mkImplicitHsForAllTy (noLoc []) (snd $ unLoc $1)))
(fst $ unLoc $1) }
: ctype { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy
: ctypedoc {% ams (sL1 $1 (mkImplicitHsForAllTy (noLoc []) (snd $ unLoc $1)))
(fst $ unLoc $1) }
: ctypedoc { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
......@@ -1556,22 +1554,17 @@ strict_mark :: { Located ([AddAnn],HsBang) }
-- better error message if we parse it here
-- A ctype is a for-all type
ctype :: { Located ([AddAnn],LHsType RdrName) }
ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4),
sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) (snd $ unLoc $4)))
(mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) }
ams (sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) $4)
[mj AnnForall $1,mj AnnDot $3] }
| context '=>' ctype {% addAnnotation (gl $1) AnnDarrow (gl $2)
>> ams (sLL $1 $> ([], sLL $1 $> $
mkQualifiedHsForAllTy $1 (snd $ unLoc $3)))
(fst $ unLoc $3) }
| ipvar '::' type {% ams (sLL $1 $> ([],sLL $1 $> (HsIParamTy (unLoc $1) $3)))
>> return (sLL $1 $> $
mkQualifiedHsForAllTy $1 $3) }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
[mj AnnVal $1,mj AnnDcolon $2] }
| type { sL1 $1 ([], $1) }
ctype_noann :: { LHsType RdrName }
ctype_noann : ctype { snd $ unLoc $1 }
| type { $1 }
----------------------
-- Notes for 'ctypedoc'
......@@ -1584,19 +1577,17 @@ ctype_noann : ctype { snd $ unLoc $1 }
-- If we allow comments on types here, it's not clear if the comment applies
-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
ctypedoc :: { Located ([AddAnn],LHsType RdrName) }
ctypedoc :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4),
sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) (snd $ unLoc $4)))
(mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) }
ams (sLL $1 $> $ mkExplicitHsForAllTy $2
(noLoc []) $4)
[mj AnnForall $1,mj AnnDot $3] }
| context '=>' ctypedoc {% addAnnotation (gl $1) AnnDarrow (gl $2)
>> ams (sLL $1 $>
([], sLL $1 $> $ mkQualifiedHsForAllTy $1 (snd $ unLoc $3)))
(fst $ unLoc $3) }
| ipvar '::' type {% ams (sLL $1 $> ([],sLL $1 $> (HsIParamTy (unLoc $1) $3)))
>> return (sLL $1 $> $
mkQualifiedHsForAllTy $1 $3) }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
[mj AnnDcolon $2] }
| typedoc { sL1 $1 ([],$1) }
| typedoc { $1 }
----------------------
-- Notes for 'context'
......@@ -1624,7 +1615,7 @@ type :: { LHsType RdrName }
: btype { $1 }
| btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype '->' ctype {% ams (sLL $1 $> $ HsFunTy $1 (snd $ unLoc $3))
| btype '->' ctype {% ams (sLL $1 $> $ HsFunTy $1 $3)
[mj AnnRarrow $2] }
| btype '~' btype {% ams (sLL $1 $> $ HsEqTy $1 $3)
[mj AnnTilde $2] }
......@@ -1641,10 +1632,10 @@ typedoc :: { LHsType RdrName }
| btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
| btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
| btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 (snd $ unLoc $3))
| btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3)
[mj AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2)
(HsDocTy $1 $2)) (snd $ unLoc $4))
(HsDocTy $1 $2)) $4)
[mj AnnRarrow $3] }
| btype '~' btype {% ams (sLL $1 $> $ HsEqTy $1 $3)
[mj AnnTilde $2] }
......@@ -1678,16 +1669,16 @@ atype :: { LHsType RdrName }
| '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
ams (sLL $1 $> $ HsTupleTy
HsBoxedOrConstraintTuple ((snd $ unLoc $2) : $4))
HsBoxedOrConstraintTuple ($2 : $4))
[mop $1,mcp $5] }
| '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
[mo $1,mc $2] }
| '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
[mo $1,mc $3] }
| '[' ctype ']' {% ams (sLL $1 $> $ HsListTy (snd $ unLoc $2)) [mos $1,mcs $3] }
| '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy (snd $ unLoc $2)) [mo $1,mc $3] }
| '(' ctype ')' {% ams (sLL $1 $> $ HsParTy (snd $ unLoc $2)) [mop $1,mcp $3] }
| '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig (snd $ unLoc $2) $4)
| '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] }
| '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] }
| '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] }
| '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4)
[mop $1,mj AnnDcolon $3,mcp $5] }
| quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2)
......@@ -1698,7 +1689,7 @@ atype :: { LHsType RdrName }
| SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')'
{% addAnnotation (gl $3) AnnComma (gl $4) >>
ams (sLL $1 $> $ HsExplicitTupleTy [] ((snd $ unLoc $3) : $5))
ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
[mj AnnSimpleQuote $1,mop $2,mcp $6] }
| SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy
placeHolderKind $3)
......@@ -1713,7 +1704,7 @@ atype :: { LHsType RdrName }
| '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
ams (sLL $1 $> $ HsExplicitListTy
placeHolderKind ((snd $ unLoc $2) : $4))
placeHolderKind ($2 : $4))
[mos $1,mcs $5] }
| INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
(getINTEGER $1) }
......@@ -1739,9 +1730,9 @@ comma_types0 :: { [LHsType RdrName] } -- Zero or more: ty,ty,ty
| {- empty -} { [] }
comma_types1 :: { [LHsType RdrName] } -- One or more: ty,ty,ty
: ctype { [snd $ unLoc $1] }
: ctype { [$1] }
| ctype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2)
>> return ((snd $ unLoc $1) : $3) }
>> return ($1 : $3) }
tv_bndrs :: { [LHsTyVarBndr RdrName] }
: tv_bndr tv_bndrs { $1 : $2 }
......@@ -1930,7 +1921,7 @@ fielddecl :: { LConDeclField RdrName }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
{% ams (L (comb2 $2 $4)
(ConDeclField (reverse (unLoc $2)) (snd $ unLoc $4) ($1 `mplus` $5)))
(ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)))
[mj AnnDcolon $3] }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
......@@ -2320,8 +2311,8 @@ aexp2 :: { LHsExpr RdrName }
| '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
| '[t|' ctype '|]' {% checkNoPartialType
(text "in type brackets" <> colon
<+> quotes (text "[t|" <+> ppr (snd $ unLoc $2) <+> text "|]")) (snd $ unLoc $2) >>
ams (sLL $1 $> $ HsBracket (TypBr (snd $ unLoc $2))) [mo $1,mc $3] }
<+> quotes (text "[t|" <+> ppr $2 <+> text "|]")) $2 >>
ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
| '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
ams (sLL $1 $> $ HsBracket (PatBr p))
[mo $1,mc $3] }
......
testsuite/tests/ghc-api/annotations/.gitignore
View file @ f34c0728
......@@ -5,7 +5,6 @@ exampleTest
listcomps
t10255
t10268
t10278
*.hi
*.o
*.run.*
......
testsuite/tests/ghc-api/annotations/Makefile
View file @ f34c0728
......@@ -43,9 +43,4 @@ T10268:
'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10268
./t10268 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
T10278:
rm -f t10278.o t10278.hi
'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10278
./t10278 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
.PHONY: clean annotations parseTree comments exampleTest listcomps
testsuite/tests/ghc-api/annotations/T10278.stderr deleted 100644 → 0
View file @ 81030ede
Test10278.hs:9:27: error:
Not in scope: type constructor or class ‘Tower’
Test10278.hs:9:39: error:
Not in scope: type constructor or class ‘Tower’
Test10278.hs:10:34: error:
Not in scope: type constructor or class ‘Tower’
Test10278.hs:10:46: error:
Not in scope: type constructor or class ‘Tower’
Test10278.hs:12:24: error: Not in scope: ‘zeroNewton’
Test10278.hs:12:36: error: Not in scope: ‘diffUU’
testsuite/tests/ghc-api/annotations/T10278.stdout deleted 100644 → 0
View file @ 81030ede
---Problems---------------------
[
(AK Test10278.hs:4:31-61 AnnDot = [Test10278.hs:4:42])
(AK Test10278.hs:4:31-61 AnnForall = [Test10278.hs:4:31-36])
(AK Test10278.hs:(8,32)-(10,57) AnnDot = [Test10278.hs:8:43])
(AK Test10278.hs:(8,32)-(10,57) AnnForall = [Test10278.hs:8:32-37])
]
--------------------------------
[
(AK Test10278.hs:1:1 AnnModule = [Test10278.hs:2:1-6])
(AK Test10278.hs:1:1 AnnWhere = [Test10278.hs:2:18-22])
(AK Test10278.hs:4:1-61 AnnDcolon = [Test10278.hs:4:16-17])
(AK Test10278.hs:4:1-61 AnnSemi = [Test10278.hs:5:1])
(AK Test10278.hs:4:19-61 AnnDot = [Test10278.hs:4:29, Test10278.hs:4:42, Test10278.hs:4:29,
Test10278.hs:4:42])
(AK Test10278.hs:4:19-61 AnnForall = [Test10278.hs:4:19-24, Test10278.hs:4:31-36, Test10278.hs:4:19-24,
Test10278.hs:4:31-36])
(AK Test10278.hs:4:31-61 AnnDot = [Test10278.hs:4:42])
(AK Test10278.hs:4:31-61 AnnForall = [Test10278.hs:4:31-36])
(AK Test10278.hs:4:44-61 AnnRarrow = [Test10278.hs:4:48-49])
(AK Test10278.hs:4:51-61 AnnRarrow = [Test10278.hs:4:56-57])
(AK Test10278.hs:5:1-26 AnnEqual = [Test10278.hs:5:16])
(AK Test10278.hs:5:1-26 AnnFunId = [Test10278.hs:5:1-14])
(AK Test10278.hs:5:1-26 AnnSemi = [Test10278.hs:7:1])
(AK Test10278.hs:(7,1)-(11,33) AnnDcolon = [Test10278.hs:7:17-18])
(AK Test10278.hs:(7,1)-(11,33) AnnSemi = [Test10278.hs:12:1])
(AK Test10278.hs:7:20-39 AnnCloseP = [Test10278.hs:7:39])
(AK Test10278.hs:7:20-39 AnnDarrow = [Test10278.hs:7:41-42])
(AK Test10278.hs:7:20-39 AnnOpenP = [Test10278.hs:7:20])
(AK Test10278.hs:7:21-24 AnnComma = [Test10278.hs:7:25])
(AK Test10278.hs:(8,19)-(10,58) AnnCloseP = [Test10278.hs:10:58])
(AK Test10278.hs:(8,19)-(10,58) AnnOpenP = [Test10278.hs:8:19])
(AK Test10278.hs:(8,19)-(11,33) AnnRarrow = [Test10278.hs:11:23-24])
(AK Test10278.hs:(8,20)-(10,57) AnnDot = [Test10278.hs:8:30, Test10278.hs:8:43])
(AK Test10278.hs:(8,20)-(10,57) AnnForall = [Test10278.hs:8:20-25, Test10278.hs:8:32-37])
(AK Test10278.hs:(8,32)-(10,57) AnnDot = [Test10278.hs:8:43])
(AK Test10278.hs:(8,32)-(10,57) AnnForall = [Test10278.hs:8:32-37])
(AK Test10278.hs:(9,27)-(10,57) AnnRarrow = [Test10278.hs:10:31-32])
(AK Test10278.hs:9:38-50 AnnCloseP = [Test10278.hs:9:50])
(AK Test10278.hs:9:38-50 AnnOpenP = [Test10278.hs:9:38])
(AK Test10278.hs:10:45-57 AnnCloseP = [Test10278.hs:10:57])
(AK Test10278.hs:10:45-57 AnnOpenP = [Test10278.hs:10:45])
(AK Test10278.hs:11:26-33 AnnRarrow = [Test10278.hs:11:28-29])
(AK Test10278.hs:11:31-33 AnnCloseS = [Test10278.hs:11:33])
(AK Test10278.hs:11:31-33 AnnOpenS = [Test10278.hs:11:31])
(AK Test10278.hs:12:1-47 AnnEqual = [Test10278.hs:12:22])
(AK Test10278.hs:12:1-47 AnnFunId = [Test10278.hs:12:1-15])
(AK Test10278.hs:12:1-47 AnnSemi = [Test10278.hs:13:1])
(AK Test10278.hs:12:35-44 AnnCloseP = [Test10278.hs:12:44])
(AK Test10278.hs:12:35-44 AnnOpenP = [Test10278.hs:12:35])
(AK <no location info> AnnEofPos = [Test10278.hs:13:1])
]
testsuite/tests/ghc-api/annotations/Test10278.hs deleted 100644 → 0
View file @ 81030ede
{-# LANGUAGE ScopedTypeVariables #-}
module Test10278 where
extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int
extremumNewton = undefined
extremumNewton1 :: (Eq a, Fractional a) =>
(forall tag. forall tag1.
Tower tag1 (Tower tag a)
-> Tower tag1 (Tower tag a))
-> a -> [a]
extremumNewton1 f x0 = zeroNewton (diffUU f) x0
testsuite/tests/ghc-api/annotations/all.T
View file @ f34c0728
......@@ -5,4 +5,3 @@ test('exampleTest', normal, run_command, ['$MAKE -s --no-print-directory example
test('listcomps', normal, run_command, ['$MAKE -s --no-print-directory listcomps'])
test('T10255', normal, run_command, ['$MAKE -s --no-print-directory t10255'])
test('T10268', normal, run_command, ['$MAKE -s --no-print-directory T10268'])
test('T10278', normal, run_command, ['$MAKE -s --no-print-directory T10278'])
testsuite/tests/ghc-api/annotations/t10278.hs deleted 100644 → 0
View file @ 81030ede
{-# LANGUAGE RankNTypes #-}
-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where
-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import MonadUtils
import Outputable
import ApiAnnotation
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Dynamic ( fromDynamic,Dynamic )
main::IO()
main = do
[libdir] <- getArgs
testOneFile libdir "Test10278"
testOneFile libdir fileName = do
((anns,cs),p) <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
let mn =mkModuleName fileName
addTarget Target { targetId = TargetModule mn
, targetAllowObjCode = True
, targetContents = Nothing }
load LoadAllTargets
modSum <- getModSummary mn
p <- parseModule modSum
return (pm_annotations p,p)
let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
-- putStrLn (pp spans)
problems = filter (\(s,a) -> not (Set.member s spans))
$ getAnnSrcSpans (anns,cs)
putStrLn "---Problems---------------------"
putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
putStrLn "--------------------------------"
putStrLn (intercalate "\n" [showAnns anns])
where
getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
getAllSrcSpans :: (Data t) => t -> [SrcSpan]
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
getSrcSpan :: SrcSpan -> [SrcSpan]
getSrcSpan ss = [ss]
showAnns anns = "[\n" ++ (intercalate "\n"
$ map (\((s,k),v)
-> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
$ Map.toList anns)
++ "]\n"
pp a = showPpr unsafeGlobalDynFlags a
-- ---------------------------------------------------------------------
-- Copied from syb for the test
-- | Generic queries of type \"r\",
-- i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r
-- | Make a generic query;
-- start from a type-specific case;
-- return a constant otherwise
--
mkQ :: ( Typeable a
, Typeable b
)
=> r
-> (b -> r)
-> a
-> r
(r `mkQ` br) a = case cast a of
Just b -> br b
Nothing -> r
-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results
everything k f x = foldl k (f x) (gmapQ (everything k f) x)
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