diff options
Diffstat (limited to 'compiler/Language/Haskell')
| -rw-r--r-- | compiler/Language/Haskell/Syntax/Type.hs | 55 |
1 files changed, 51 insertions, 4 deletions
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 |