Improve error messages for (a %m) without LinearTypeswip/linear-types-caret

Detect when the user forgets to enable the LinearTypes
extension and produce a better error message.

Steals the (a %m) syntax from TypeOperators, the workaround
is to write (a % m) instead.

2 files changed, 19 insertions, 11 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 12f5b8be3b..abfcc6fbff 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -68,7 +68,8 @@ import GHC.Prelude
 
 -- compiler/basicTypes
 import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore )
+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName,
+                                   occNameFS, startsWithUnderscore )
 import GHC.Core.DataCon          ( DataCon, dataConName )
 import GHC.Types.SrcLoc
 import GHC.Unit.Module
@@ -2082,7 +2083,8 @@ infixtype :: { forall b. DisambTD b => PV (Located b) }
         : ftype %shift                  { $1 }
         | ftype tyop infixtype          { $1 >>= \ $1 ->
                                           $3 >>= \ $3 ->
-                                          mkHsOpTyPV $1 $2 $3 }
+                                          do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLoc $2)
+                                             ; mkHsOpTyPV $1 $2 $3 } }
         | unpackedness infixtype        { $2 >>= \ $2 ->
                                           mkUnpackednessPV $1 $2 }
 
@@ -3923,12 +3925,25 @@ fileSrcSpan = do
   return (mkSrcSpan loc loc)
 
 -- Hint about linear types
-hintLinear :: SrcSpan -> P ()
+hintLinear :: MonadP m => SrcSpan -> m ()
 hintLinear span = do
   linearEnabled <- getBit LinearTypesBit
   unless linearEnabled $ addError span $
     text "Enable LinearTypes to allow linear functions"
 
+-- Does this look like (a %m)?
+looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool
+looksLikeMult ty1 l_op ty2
+  | Unqual op_name <- unLoc l_op
+  , occNameFS op_name == fsLit "%"
+  , Just ty1_pos <- getBufSpan (getLoc ty1)
+  , Just pct_pos <- getBufSpan (getLoc l_op)
+  , Just ty2_pos <- getBufSpan (getLoc ty2)
+  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos
+  , bufSpanEnd pct_pos == bufSpanStart ty2_pos
+  = True
+  | otherwise = False
+
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
diff --git a/testsuite/tests/linear/should_fail/LinearNoExt.stderr b/testsuite/tests/linear/should_fail/LinearNoExt.stderr
index 9277e29ea5..e4afbd1048 100644
--- a/testsuite/tests/linear/should_fail/LinearNoExt.stderr
+++ b/testsuite/tests/linear/should_fail/LinearNoExt.stderr
@@ -1,10 +1,3 @@
 
 LinearNoExt.hs:3:14: error:
-    Not in scope: type constructor or class ‘%’
-
-LinearNoExt.hs:3:14: error:
-    Illegal operator ‘%’ in type ‘a % 1’
-      Use TypeOperators to allow operators in types
-
-LinearNoExt.hs:3:15: error:
-    Illegal type: ‘1’ Perhaps you intended to use DataKinds
+    Enable LinearTypes to allow linear functions