summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Decls.hs12
-rw-r--r--compiler/GHC/Hs/Type.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Type.hs55
-rw-r--r--testsuite/tests/th/T19737.hs14
-rw-r--r--testsuite/tests/th/T19737.stderr20
-rw-r--r--testsuite/tests/th/all.T1
6 files changed, 88 insertions, 16 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 9f3f6469e5..9f7b278ef3 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -810,17 +810,7 @@ pprHsFamInstLHS :: (OutputableBndrId p)
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
= hsep [ pprHsOuterFamEqnTyVarBndrs bndrs
, pprLHsContext mb_ctxt
- , pp_pats typats ]
- where
- pp_pats (patl:patr:pats)
- | Infix <- fixity
- = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in
- case pats of
- [] -> pp_op_app
- _ -> hsep (parens pp_op_app : map ppr pats)
-
- pp_pats pats = hsep [ pprPrefixOcc thing
- , hsep (map ppr pats)]
+ , pprHsArgsApp thing fixity typats ]
instance OutputableBndrId p
=> Outputable (ClsInstDecl (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index a666a87519..917063d6f4 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -37,7 +37,7 @@ module GHC.Hs.Type (
HsContext, LHsContext, fromMaybeContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
- HsArg(..), numVisibleArgs,
+ HsArg(..), numVisibleArgs, pprHsArgsApp,
LHsTypeArg, lhsTypeArgSrcSpan,
OutputableBndrFlag,
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index bbe3fe8b24..66c4cb97c7 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -34,7 +34,7 @@ module Language.Haskell.Syntax.Type (
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
- HsArg(..), numVisibleArgs,
+ HsArg(..), numVisibleArgs, pprHsArgsApp,
LHsTypeArg,
LBangType, BangType,
@@ -70,6 +70,7 @@ import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),
import GHC.Core.Type
import GHC.Hs.Doc
import GHC.Types.Basic
+import GHC.Types.Fixity
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -1214,10 +1215,56 @@ numVisibleArgs = count is_vis
-- type level equivalent
type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
+-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@
+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix
+-- or infix. Examples:
+--
+-- @
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering
+-- @
+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)
+ => id -> LexicalFixity -> [HsArg tm ty] -> SDoc
+pprHsArgsApp thing fixity (argl:argr:args)
+ | Infix <- fixity
+ = let pp_op_app = hsep [ ppr_single_hs_arg argl
+ , pprInfixOcc thing
+ , ppr_single_hs_arg argr ] in
+ case args of
+ [] -> pp_op_app
+ _ -> ppr_hs_args_prefix_app (parens pp_op_app) args
+
+pprHsArgsApp thing _fixity args
+ = ppr_hs_args_prefix_app (pprPrefixOcc thing) args
+
+-- | Pretty-print a prefix identifier to a list of 'HsArg's.
+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)
+ => SDoc -> [HsArg tm ty] -> SDoc
+ppr_hs_args_prefix_app acc [] = acc
+ppr_hs_args_prefix_app acc (arg:args) =
+ case arg of
+ HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+ HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+ HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args
+
+-- | Pretty-print an 'HsArg' in isolation.
+ppr_single_hs_arg :: (Outputable tm, Outputable ty)
+ => HsArg tm ty -> SDoc
+ppr_single_hs_arg (HsValArg tm) = ppr tm
+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty
+-- GHC shouldn't be constructing ASTs such that this case is ever reached.
+-- Still, it's possible some wily user might construct their own AST that
+-- allows this to be reachable, so don't fail here.
+ppr_single_hs_arg (HsArgPar{}) = empty
+
+-- | This instance is meant for debug-printing purposes. If you wish to
+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.
instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
- ppr (HsValArg tm) = ppr tm
- ppr (HsTypeArg _ ty) = char '@' <> ppr ty
- ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
+ ppr (HsValArg tm) = text "HsValArg" <+> ppr tm
+ ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty
+ ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
{-
Note [HsArgPar]
A HsArgPar indicates that everything to the left of this in the argument list is
diff --git a/testsuite/tests/th/T19737.hs b/testsuite/tests/th/T19737.hs
new file mode 100644
index 0000000000..72ec1fe053
--- /dev/null
+++ b/testsuite/tests/th/T19737.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -ddump-splices #-}
+module T19737 where
+
+import Language.Haskell.TH
+
+type family T a
+
+$(pure [ TySynInstD (TySynEqn Nothing (ConT ''T `AppT` ConT ''Char) (ConT ''Char))
+ , TySynInstD (TySynEqn Nothing (ParensT (ConT ''T) `AppT` ConT ''Int) (ConT ''Int))
+ , TySynInstD (TySynEqn Nothing (ParensT (ConT ''T `AppT` ConT ''Bool)) (ConT ''Bool))
+ , TySynInstD (TySynEqn Nothing (ParensT (ParensT (ConT ''T `AppT` ParensT (ConT ''Double)))) (ConT ''Double))
+ ])
diff --git a/testsuite/tests/th/T19737.stderr b/testsuite/tests/th/T19737.stderr
new file mode 100644
index 0000000000..ba1465b26a
--- /dev/null
+++ b/testsuite/tests/th/T19737.stderr
@@ -0,0 +1,20 @@
+T19737.hs:(10,2)-(14,9): Splicing declarations
+ pure
+ [TySynInstD
+ (TySynEqn Nothing (ConT ''T `AppT` ConT ''Char) (ConT ''Char)),
+ TySynInstD
+ (TySynEqn
+ Nothing (ParensT (ConT ''T) `AppT` ConT ''Int) (ConT ''Int)),
+ TySynInstD
+ (TySynEqn
+ Nothing (ParensT (ConT ''T `AppT` ConT ''Bool)) (ConT ''Bool)),
+ TySynInstD
+ (TySynEqn
+ Nothing
+ (ParensT (ParensT (ConT ''T `AppT` ParensT (ConT ''Double))))
+ (ConT ''Double))]
+ ======>
+ type instance T Char = Char
+ type instance (T) Int = Int
+ type instance (T Bool) = Bool
+ type instance ((T (Double))) = Double
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 857c9f3659..fb3bc7fb49 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -523,3 +523,4 @@ test('T19363', normal, compile_and_run, [''])
test('T19377', normal, compile, [''])
test('T17804', normal, compile, [''])
test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])
+test('T19737', normal, compile, [''])
View Lorry Controller Status