Restrict Linear arrow %1 to exactly literal 1 onlywip/T18888

This disallows `a %001 -> b`, and makes sure the type literal is
printed from its SourceText so it is clear why.

Closes #18888

7 files changed, 25 insertions, 3 deletions

diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 1845f060ed..1ae23c779d 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1982,8 +1982,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 84aa3e09bc..e95abd6597 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2620,7 +2620,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 95cb337711..60bf3c4337 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -32,3 +32,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, [''])