Minor fix to pretty-printing of linear typeswip/ppr-arrow-chain

The function ppr_arrow_chain was not printing multiplicities.
Also remove the Outputable instance: no longer used, and could cover
bugs like those.

7 files changed, 31 insertions, 12 deletions

diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 1b814b5213..c4c7f90a71 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -1357,7 +1357,7 @@ MkT :: a %1 -> T a (with -XLinearTypes)
 or
 MkT :: a  -> T a (with -XNoLinearTypes)
 
-There are two different methods to retrieve a type of a datacon.
+There are three different methods to retrieve a type of a datacon.
 They differ in how linear fields are handled.
 
 1. dataConWrapperType:
@@ -1369,7 +1369,7 @@ The type of the constructor, with linear arrows replaced by unrestricted ones.
 Used when we don't want to introduce linear types to user (in holes
 and in types in hie used by haddock).
 
-3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled):
+3. dataConDisplayType (takes a boolean indicating if -XLinearTypes is enabled):
 The type we'd like to show in error messages, :info and -ddump-types.
 Ideally, it should reflect the type written by the user;
 the function returns a type with arrows that would be required
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 4b543cb8ef..997fbdceca 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -705,13 +705,16 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
                         , con_res_ty = res_ty, con_doc = doc })
   = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
     <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,
-              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
+              sep (ppr_args args ++ [ppr res_ty]) ])
   where
-    get_args (PrefixConGADT args) = map ppr args
-    get_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields)]
-
-    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
-    ppr_arrow_chain []     = empty
+    ppr_args (PrefixConGADT args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args
+    ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow]
+
+    -- Display linear arrows as unrestricted with -XNoLinearTypes
+    -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)
+    ppr_arr (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types ->
+                                  if show_linear_types then lollipop else arrow
+    ppr_arr arr = pprHsArrow arr
 
 ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 399c89f93d..e1f137052b 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -26,6 +26,7 @@ module GHC.Hs.Type (
         HsArrow(..), arrowToHsType,
         HsLinearArrowTokens(..),
         hsLinear, hsUnrestricted, isUnrestricted,
+        pprHsArrow,
 
         HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
         HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index 74f8f98432..6827438595 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -938,10 +938,6 @@ hsMult (HsScaled m _) = m
 hsScaledThing :: HsScaled pass a -> a
 hsScaledThing (HsScaled _ t) = t
 
-instance Outputable a => Outputable (HsScaled pass a) where
-   ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t
-                            ppr t
-
 {-
 Note [Unit tuples]
 ~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
index 5dc5df090c..850fd3ce5a 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
@@ -63,3 +63,4 @@ test('haddockExtraDocs', normal, compile, ['-haddock -Winvalid-haddock'])
 test('haddockTySyn', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed'])
 test('T8944', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed'])
 test('T17652', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed'])
+test('haddockLinear', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed'])
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.hs
new file mode 100644
index 0000000000..76293500d7
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE GADTs #-}
+module ShouldCompile where
+
+data T where
+  C1 :: Int %1 -> T
+  C2 :: Int %m -> T
+  C3 :: Int -> T
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.stderr
new file mode 100644
index 0000000000..41fce03725
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.stderr
@@ -0,0 +1,10 @@
+
+==================== Parser ====================
+module ShouldCompile where
+data T
+  where
+    C1 :: Int %1 -> T
+    C2 :: Int %m -> T
+    C3 :: Int -> T
+
+