[Git][ghc/ghc][wip/az/apiann-annpercent] 5 commits: testsuite: Mark T12971 as fragile on Windows
Alan Zimmerman
gitlab at gitlab.haskell.org
Sun Oct 25 22:42:48 UTC 2020
Alan Zimmerman pushed to branch wip/az/apiann-annpercent at Glasgow Haskell Compiler / GHC
Commits:
cf3c3bcd by Ben Gamari at 2020-10-20T22:56:31-04:00
testsuite: Mark T12971 as fragile on Windows
Due to #17945.
- - - - -
e2c4a947 by Vladislav Zavialov at 2020-10-21T16:00:30+03:00
Parser regression tests, close #12862 #12446
These issues were fixed by earlier parser changes, most likely related
to whitespace-sensitive parsing.
- - - - -
711929e6 by Simon Peyton Jones at 2020-10-23T02:42:59-04:00
Fix error message location in tcCheckPatSynDecl
Ticket #18856 showed that we were failing to set the right location
for an error message. Easy to fix, happily.
Turns out that this also improves the error location in test T11010,
which was bogus before but we had never noticed.
- - - - -
730bb590 by Ben Gamari at 2020-10-23T02:43:33-04:00
cmm: Add Note reference to ForeignHint
- - - - -
60f7085a by Alan Zimmerman at 2020-10-25T22:37:56+00:00
Api Annotations: Introduce AnnPercent for HsExplicitMult
For the case
foo :: a %p -> b
The location of the '%' is captured, separate from the 'p'
- - - - -
15 changed files:
- compiler/GHC/Cmm/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/parser/should_compile/T12862.hs
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/parser/should_fail/T12446.hs
- + testsuite/tests/parser/should_fail/T12446.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/patsyn/should_fail/T11010.stderr
- + testsuite/tests/patsyn/should_fail/T18856.hs
- + testsuite/tests/patsyn/should_fail/T18856.stderr
- testsuite/tests/patsyn/should_fail/all.T
Changes:
=====================================
compiler/GHC/Cmm/Type.hs
=====================================
@@ -311,6 +311,8 @@ isVecType _ = False
-- Hints are extra type information we attach to the arguments and
-- results of a foreign call, where more type information is sometimes
-- needed by the ABI to make the correct kind of call.
+--
+-- See Note [Signed vs unsigned] for one case where this is used.
data ForeignHint
= NoHint | AddrHint | SignedHint
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2056,17 +2056,19 @@ type :: { LHsType GhcPs }
[mu AnnRarrow $2] }
| btype mult '->' ctype {% hintLinear (getLoc $2)
- >> ams $1 [mj AnnMult $2,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField ((unLoc $2) (toUnicode $3)) $1 $4)
- [mj AnnMult $2,mu AnnRarrow $3] }
+ >> let (arr, anns) = (unLoc $2) (toUnicode $3)
+ in (ams $1 (mu AnnRarrow $3:anns) -- See Note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4)
+ (mu AnnRarrow $3:anns)) }
| btype '->.' ctype {% hintLinear (getLoc $2)
>> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]
>> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)
[mu AnnLollyU $2] }
-mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
- : PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $2) }
+mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, [AddAnn])) }
+ : PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $2
+ (AddAnn AnnPercentOne (comb2 $1 $2), mj AnnPercent $1)) }
btype :: { LHsType GhcPs }
: infixtype {% runPV $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -301,7 +301,7 @@ data AnnKeywordId
| AnnMdo
| AnnMinus -- ^ '-'
| AnnModule
- | AnnMult -- ^ '%1'
+ | AnnPercentOne -- ^ '%1'
| AnnNewtype
| AnnName -- ^ where a name loses its location in the AST, this carries it
| AnnOf
@@ -318,6 +318,7 @@ data AnnKeywordId
| AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell
| AnnPackageName
| AnnPattern
+ | AnnPercent -- ^ '%' -- for HsExplicitMult
| AnnProc
| AnnQualified
| AnnRarrow -- ^ '->'
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2617,9 +2617,10 @@ mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
in L loc (mkHsOpTy x op y)
-mkMultTy :: IsUnicodeSyntax -> LHsType GhcPs -> HsArrow GhcPs
-mkMultTy u (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow u
-mkMultTy u t = HsExplicitMult u t
+mkMultTy :: IsUnicodeSyntax -> LHsType GhcPs -> (AddAnn, AddAnn) -> (HsArrow GhcPs, [AddAnn])
+mkMultTy u (L _ (HsTyLit _ (HsNumTy _ 1))) (ann,_)
+ = (HsLinearArrow u, [ann])
+mkMultTy u t (_, ann) = (HsExplicitMult u t, [ann])
-----------------------------------------------------------------------------
-- Token symbols
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -31,9 +31,9 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Zonk
import GHC.Builtin.Types.Prim
import GHC.Types.Name
+import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Core.PatSyn
-import GHC.Types.Name.Set
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -422,14 +422,22 @@ tcCheckPatSynDecl psb at PSB{ psb_id = lname@(L _ name), psb_args = details
; tc_patsyn_finish lname dir is_infix lpat'
(univ_bndrs, req_theta, ev_binds, req_dicts)
(ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
- (args', (map scaledThing arg_tys))
+ (args', map scaledThing arg_tys)
pat_ty rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
+ -- Look up the variable actually bound by lpat
+ -- and check that it has the expected type
tc_arg subst arg_name arg_ty
- = do { -- Look up the variable actually bound by lpat
- -- and check that it has the expected type
- arg_id <- tcLookupId arg_name
+ = setSrcSpan (nameSrcSpan arg_name) $
+ -- Set the SrcSpan to be the binding site of the Id (#18856)
+ -- e.g. pattern P :: Int -> Maybe (Int,Bool)
+ -- pattern P x = Just (x,True)
+ -- Before unifying x's actual type with its expected type, in tc_arg, set
+ -- location to x's binding site in lpat, namely the 'x' in Just (x,True).
+ -- Else the error message location is wherever tcCheckPat finished,
+ -- namely the right-hand corner of the pattern
+ do { arg_id <- tcLookupId arg_name
; wrap <- tcSubTypeSigma GenSigCtxt
(idType arg_id)
(substTyUnchecked subst arg_ty)
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -258,7 +258,7 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
test('T12955', normal, makefile_test, [])
-test('T12971', [when(opsys('mingw32'), expect_broken(17945)), ignore_stdout], makefile_test, [])
+test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
test('json', normal, compile_fail, ['-ddump-json'])
test('json2', normalise_version('base','ghc-prim'), compile, ['-ddump-types -ddump-json'])
test('T16167', exit_code(1), run_command,
=====================================
testsuite/tests/parser/should_compile/T12862.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeFamilies, InstanceSigs #-}
+{-# LANGUAGE BangPatterns #-} -- should parse even with BangPatterns enabled
+
+module T12862 where
+
+import Data.Kind (Type)
+
+class Key key where
+ data TotalMap key :: Type -> Type
+ (!) :: TotalMap key val -> (key -> val)
+
+instance Key Bool where
+ data TotalMap Bool val = BoolMap val val
+ (!) :: TotalMap Bool val -> (Bool -> val)
+ (BoolMap f _) ! False = f -- with parentheses
+ BoolMap f _ ! True = f -- without parentheses
=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -172,3 +172,4 @@ test('T15730a', normal, compile_and_run, [''])
test('T18130', normal, compile, [''])
test('T18834a', normal, compile, [''])
test('T18834b', normal, compile, [''])
+test('T12862', normal, compile, [''])
=====================================
testsuite/tests/parser/should_fail/T12446.hs
=====================================
@@ -0,0 +1,3 @@
+module T12446 where
+
+x = undefined @(_ ~ _)
=====================================
testsuite/tests/parser/should_fail/T12446.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T12446.hs:3:5: error:
+ Illegal visible type application ‘@(_ ~ _)’
+ Perhaps you intended to use TypeApplications
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -173,3 +173,4 @@ test('T18251c', normal, compile_fail, [''])
test('T18251d', normal, compile_fail, [''])
test('T18251e', normal, compile_fail, [''])
test('T18251f', normal, compile_fail, [''])
+test('T12446', normal, compile_fail, [''])
=====================================
testsuite/tests/patsyn/should_fail/T11010.stderr
=====================================
@@ -1,5 +1,5 @@
-T11010.hs:9:36: error:
+T11010.hs:9:34: error:
• Couldn't match type ‘a1’ with ‘Int’
Expected: a -> b
Actual: a1 -> b
@@ -12,3 +12,6 @@ T11010.hs:9:36: error:
• Relevant bindings include
x :: Expr a1 (bound at T11010.hs:9:36)
f :: a1 -> b (bound at T11010.hs:9:34)
+ |
+9 | pattern IntFun str f x = Fun str f x
+ | ^
=====================================
testsuite/tests/patsyn/should_fail/T18856.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+
+module T18856 where
+
+pattern P :: Int -> Bool -> (Int, Bool, [(Bool,Bool)])
+pattern P p q <- (q, p, [(True,False)])
+
=====================================
testsuite/tests/patsyn/should_fail/T18856.stderr
=====================================
@@ -0,0 +1,14 @@
+
+T18856.hs:6:19: error:
+ • Couldn't match expected type ‘Bool’ with actual type ‘Int’
+ • In the declaration for pattern synonym ‘P’
+ |
+6 | pattern P p q <- (q, p, [(True,False)])
+ | ^
+
+T18856.hs:6:22: error:
+ • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+ • In the declaration for pattern synonym ‘P’
+ |
+6 | pattern P p q <- (q, p, [(True,False)])
+ | ^
=====================================
testsuite/tests/patsyn/should_fail/all.T
=====================================
@@ -9,7 +9,7 @@ test('T9705-2', normal, compile_fail, [''])
test('unboxed-bind', normal, compile_fail, [''])
test('unboxed-wrapper-naked', normal, compile_fail, [''])
test('T10873', normal, compile_fail, [''])
-test('T11010', normal, compile_fail, [''])
+test('T11010', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('records-check-sels', normal, compile_fail, [''])
test('records-no-uni-update', normal, compile_fail, [''])
test('records-no-uni-update2', normal, compile_fail, [''])
@@ -47,3 +47,4 @@ test('T15692', normal, compile, ['']) # It has -fdefer-type-errors inside
test('T15694', normal, compile_fail, [''])
test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('T14552', normal, compile_fail, [''])
+test('T18856', normal, compile_fail, ['-fdiagnostics-show-caret'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc4976be22fbe3eba1fe5e6828e66c304f61a869...60f7085a068b0152ae720215c55a2b04e2b6bcb0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc4976be22fbe3eba1fe5e6828e66c304f61a869...60f7085a068b0152ae720215c55a2b04e2b6bcb0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201025/ecdaff13/attachment-0001.html>
More information about the ghc-commits
mailing list