diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2020-10-28 23:09:48 +0000 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2020-11-09 14:15:16 -0500 |
commit | 25a24e5d64a21bc5b3c5b737abc6bf0432b1dd1a (patch) | |
tree | 39fafca33edb0872f4153a670ec98d1a0cf716d8 | |
parent | e615aa85ef136d26555455fb4baf8a7aba83fd75 (diff) | |
download | haskell-25a24e5d64a21bc5b3c5b737abc6bf0432b1dd1a.tar.gz |
Restrict Linear arrow %1 to exactly literal 1 only
This disallows `a %001 -> b`, and makes sure the type literal is
printed from its SourceText so it is clear why.
Closes #18888
(cherry picked from commit 616bec0dee67ae4841c4e60e9406cc9c63358223)
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/T18888.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/T18888.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/T18888_datakinds.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/T18888_datakinds.stderr | 5 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/all.T | 2 |
7 files changed, 25 insertions, 3 deletions
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index f383b61705..9ab8bc8c01 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1978,8 +1978,8 @@ ppr_fun_ty mult ty1 ty2 -------------------------- ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy _ i) = integer i -ppr_tylit (HsStrTy _ s) = text (show s) +ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) +ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 5325813911..88e3d04928 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -3070,7 +3070,8 @@ mkLHsOpTy x op y = in L loc (mkHsOpTy x op y) mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn) -mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy _ 1))) +mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) + -- See #18888 for the use of (SourceText "1") above = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t)) mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) diff --git a/testsuite/tests/linear/should_fail/T18888.hs b/testsuite/tests/linear/should_fail/T18888.hs new file mode 100644 index 0000000000..870c993cdb --- /dev/null +++ b/testsuite/tests/linear/should_fail/T18888.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module T18888 where + +f :: a %001 -> b +f x = undefined x diff --git a/testsuite/tests/linear/should_fail/T18888.stderr b/testsuite/tests/linear/should_fail/T18888.stderr new file mode 100644 index 0000000000..c224a5b331 --- /dev/null +++ b/testsuite/tests/linear/should_fail/T18888.stderr @@ -0,0 +1,3 @@ + +T18888.hs:4:9: + Illegal type: ‘001’ Perhaps you intended to use DataKinds diff --git a/testsuite/tests/linear/should_fail/T18888_datakinds.hs b/testsuite/tests/linear/should_fail/T18888_datakinds.hs new file mode 100644 index 0000000000..8b4bd18247 --- /dev/null +++ b/testsuite/tests/linear/should_fail/T18888_datakinds.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE DataKinds #-} +module T18888 where + +f :: a %001 -> b +f x = undefined x diff --git a/testsuite/tests/linear/should_fail/T18888_datakinds.stderr b/testsuite/tests/linear/should_fail/T18888_datakinds.stderr new file mode 100644 index 0000000000..a2a7ad88c7 --- /dev/null +++ b/testsuite/tests/linear/should_fail/T18888_datakinds.stderr @@ -0,0 +1,5 @@ + +T18888_datakinds.hs:5:9: + Expected kind ‘GHC.Types.Multiplicity’, + but ‘001’ has kind ‘GHC.Num.Natural.Natural’ + In the type signature: f :: a %001 -> b diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T index eddda95ba7..313458061d 100644 --- a/testsuite/tests/linear/should_fail/all.T +++ b/testsuite/tests/linear/should_fail/all.T @@ -30,3 +30,5 @@ test('LinearIf', normal, compile_fail, ['']) test('LinearPatternGuardWildcard', normal, compile_fail, ['']) test('LinearFFI', normal, compile_fail, ['']) test('LinearTHFail', normal, compile_fail, ['']) +test('T18888', normal, compile_fail, ['']) +test('T18888_datakinds', normal, compile_fail, ['']) |