Prune L.H.S modules of GHC dependencies

Move around datatypes, functions and instances that are GHC-specific out
of the `Language.Haskell.Syntax.*` modules to reduce the GHC
dependencies in them -- progressing towards #21592

Creates a module `Language.Haskell.Syntax.Basic` to hold basic
definitions required by the other L.H.S modules (and don't belong in any
of them)

4 files changed, 224 insertions, 15 deletions

diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 686d9e6b25..c08031c223 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -600,6 +600,10 @@ pprTicks pp_no_debug pp_when_debug
          then pp_when_debug
          else pp_no_debug
 
+instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where
+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -651,20 +655,28 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
 type instance XTypeSig          (GhcPass p) = EpAnn AnnSig
 type instance XPatSynSig        (GhcPass p) = EpAnn AnnSig
 type instance XClassOpSig       (GhcPass p) = EpAnn AnnSig
-type instance XIdSig            (GhcPass p) = NoExtField -- No anns, generated
 type instance XFixSig           (GhcPass p) = EpAnn [AddEpAnn]
 type instance XInlineSig        (GhcPass p) = EpAnn [AddEpAnn]
 type instance XSpecSig          (GhcPass p) = EpAnn [AddEpAnn]
-type instance XSpecInstSig      (GhcPass p) = EpAnn [AddEpAnn]
-type instance XMinimalSig       (GhcPass p) = EpAnn [AddEpAnn]
-type instance XSCCFunSig        (GhcPass p) = EpAnn [AddEpAnn]
-type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn]
-
-type instance XXSig             (GhcPass p) = DataConCantHappen
+type instance XSpecInstSig      (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XMinimalSig       (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XSCCFunSig        (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+    -- SourceText: Note [Pragma source text] in GHC.Types.SourceText
+type instance XXSig             GhcPs = DataConCantHappen
+type instance XXSig             GhcRn = IdSig
+type instance XXSig             GhcTc = IdSig
 
 type instance XFixitySig  (GhcPass p) = NoExtField
 type instance XXFixitySig (GhcPass p) = DataConCantHappen
 
+-- | A type signature in generated code, notably the code
+-- generated for record selectors. We simply record the desired Id
+-- itself, replete with its name, type and IdDetails. Otherwise it's
+-- just like a type signature: there should be an accompanying binding
+newtype IdSig = IdSig { unIdSig :: Id }
+    deriving Data
+
 data AnnSig
   = AnnSig {
       asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option
@@ -714,7 +726,6 @@ ppr_sig (TypeSig _ vars ty)  = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (ClassOpSig _ is_deflt vars ty)
   | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
   | otherwise                = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig _ id)         = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig _ fix_sig)   = ppr fix_sig
 ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
   = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)
@@ -729,20 +740,20 @@ ppr_sig (InlineSig _ var inl)
       ppr_pfx = case inlinePragmaSource inl of
         SourceText src -> text src
         NoSourceText   -> text "{-#" <+> inlinePragmaName (inl_inline inl)
-ppr_sig (SpecInstSig _ src ty)
+ppr_sig (SpecInstSig (_, src) ty)
   = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
-ppr_sig (MinimalSig _ src bf)
+ppr_sig (MinimalSig (_, src) bf)
   = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
 ppr_sig (PatSynSig _ names sig_ty)
   = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
-ppr_sig (SCCFunSig _ src fn mlabel)
+ppr_sig (SCCFunSig (_, src) fn mlabel)
   = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )
       where
         ppr_fn = case ghcPass @p of
           GhcPs -> ppr fn
           GhcRn -> ppr fn
           GhcTc -> ppr fn
-ppr_sig (CompleteMatchSig _ src cs mty)
+ppr_sig (CompleteMatchSig (_, src) cs mty)
   = pragSrcBrackets src "{-# COMPLETE"
       ((hsep (punctuate comma (map ppr_n (unLoc cs))))
         <+> opt_sig)
@@ -752,6 +763,40 @@ ppr_sig (CompleteMatchSig _ src cs mty)
         GhcPs -> ppr n
         GhcRn -> ppr n
         GhcTc -> ppr n
+ppr_sig (XSig x) = case ghcPass @p of
+                      GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id))
+                      GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id))
+
+hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc
+hsSigDoc (TypeSig {})           = text "type signature"
+hsSigDoc (PatSynSig {})         = text "pattern synonym signature"
+hsSigDoc (ClassOpSig _ is_deflt _ _)
+ | is_deflt                     = text "default type signature"
+ | otherwise                    = text "class method signature"
+hsSigDoc (SpecSig _ _ _ inl)    = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
+hsSigDoc (InlineSig _ _ prag)   = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"
+-- Using the 'inlinePragmaName' function ensures that the pragma name for any
+-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted
+-- from the InlineSpec field of the pragma.
+hsSigDoc (SpecInstSig (_, src) _)  = text (extractSpecPragName src) <+> text "instance pragma"
+hsSigDoc (FixSig {})            = text "fixity declaration"
+hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"
+hsSigDoc (SCCFunSig {})         = text "SCC pragma"
+hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"
+hsSigDoc (XSig _)               = case ghcPass @p of
+                                    GhcRn -> text "id signature"
+                                    GhcTc -> text "id signature"
+
+-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src
+-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE
+-- instance pragma of the form: "SourceText {-# SPECIALIZE"
+--
+-- Extraction ensures that all variants of the pragma name (with a 'Z' or an
+-- 'S') are output exactly as used in the pragma.
+extractSpecPragName :: SourceText -> String
+extractSpecPragName srcTxt =  case (words $ show srcTxt) of
+     (_:_:pragName:_) -> filter (/= '\"') pragName
+     _                -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt)
 
 instance OutputableBndrId p
        => Outputable (FixitySig (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index 3b9b6948c6..838e3348dd 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -25,14 +25,15 @@ import GHC.Prelude
 
 import {-# SOURCE #-} GHC.Hs.Expr( pprExpr )
 
-import Language.Haskell.Syntax.Lit
-
+import GHC.Types.Basic (PprPrec(..), topPrec )
+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
 import GHC.Types.SourceText
 import GHC.Core.Type
 import GHC.Utils.Outputable
+import GHC.Hs.Extension
 import Language.Haskell.Syntax.Expr ( HsExpr )
 import Language.Haskell.Syntax.Extension
-import GHC.Hs.Extension
+import Language.Haskell.Syntax.Lit
 
 {-
 ************************************************************************
@@ -103,6 +104,37 @@ type instance XXOverLit (GhcPass _) = DataConCantHappen
 overLitType :: HsOverLit GhcTc -> Type
 overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty
 
+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
+-- @ol@ needs to be parenthesized under precedence @p@.
+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
+  where
+    go :: OverLitVal -> Bool
+    go (HsIntegral x)   = p > topPrec && il_neg x
+    go (HsFractional x) = p > topPrec && fl_neg x
+    go (HsIsString {})  = False
+hsOverLitNeedsParens _ (XOverLit { }) = False
+
+-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
+-- to be parenthesized under precedence @p@.
+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens p = go
+  where
+    go (HsChar {})        = False
+    go (HsCharPrim {})    = False
+    go (HsString {})      = False
+    go (HsStringPrim {})  = False
+    go (HsInt _ x)        = p > topPrec && il_neg x
+    go (HsIntPrim _ x)    = p > topPrec && x < 0
+    go (HsWordPrim {})    = False
+    go (HsInt64Prim _ x)  = p > topPrec && x < 0
+    go (HsWord64Prim {})  = False
+    go (HsInteger _ x _)  = p > topPrec && x < 0
+    go (HsRat _ x _)      = p > topPrec && fl_neg x
+    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x
+    go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+    go (XLit _)           = False
+
 -- | Convert a literal from one index type to another
 convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
 convertLit (HsChar a x)       = HsChar a x
@@ -161,6 +193,11 @@ instance OutputableBndrId p
   ppr (OverLit {ol_val=val, ol_ext=ext})
         = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext)))
 
+instance Outputable OverLitVal where
+  ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))
+  ppr (HsFractional f)   = ppr f
+  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)
+
 -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
 -- match warnings. All are printed the same (i.e., without hashes if they are
 -- primitive and not wrapped in constructors if they are boxed). This happens
@@ -181,3 +218,4 @@ pmPprHsLit (HsInteger _ i _)  = integer i
 pmPprHsLit (HsRat _ f _)      = ppr f
 pmPprHsLit (HsFloatPrim _ f)  = ppr f
 pmPprHsLit (HsDoublePrim _ d) = ppr d
+
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 102587026e..2b8eb269bb 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -260,6 +261,24 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
 ************************************************************************
 -}
 
+instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where
+  ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty
+
+instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)
+      => Outputable (HsRecFields p arg) where
+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
+        = braces (fsep (punctuate comma (map ppr flds)))
+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })
+        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
+        where
+          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
+
+instance (Outputable p, OutputableBndr p, Outputable arg)
+      => Outputable (HsFieldBind p arg) where
+  ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,
+                     hfbPun = pun })
+    = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
+
 instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
     ppr = pprPat
 
@@ -734,3 +753,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
 type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns
 type instance Anno ConLike = SrcSpanAnnN
 type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
+type instance Anno RecFieldsDotDot = SrcSpan
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 1635019dbe..73709e2849 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -112,8 +113,10 @@ import GHC.Hs.Doc
 import GHC.Types.Basic
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
+import GHC.Utils.Misc (count)
 
 import Data.Maybe
+import Data.Data (Data)
 
 import qualified Data.Semigroup as S
 
@@ -207,6 +210,14 @@ type instance XHsPS GhcPs = EpAnnCO
 type instance XHsPS GhcRn = HsPSRn
 type instance XHsPS GhcTc = HsPSRn
 
+-- | The extension field for 'HsPatSigType', which is only used in the
+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.
+data HsPSRn = HsPSRn
+  { hsps_nwcs    :: [Name] -- ^ Wildcard names
+  , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names
+  }
+  deriving Data
+
 type instance XXHsPatSigType (GhcPass _) = DataConCantHappen
 
 type instance XHsSig (GhcPass _) = NoExtField
@@ -533,6 +544,66 @@ lhsTypeArgSrcSpan arg = case arg of
 
 --------------------------------
 
+numVisibleArgs :: [HsArg tm ty] -> Arity
+numVisibleArgs = count is_vis
+  where is_vis (HsValArg _) = True
+        is_vis _            = False
+
+--------------------------------
+
+-- | @'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)     = text "HsValArg"  <+> ppr tm
+  ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty
+  ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp
+
+--------------------------------
+
 -- | Decompose a pattern synonym type signature into its constituent parts.
 --
 -- Note that this function looks through parentheses, so it will work on types
@@ -919,6 +990,41 @@ instance (OutputableBndrId p)
        => Outputable (HsPatSigType (GhcPass p)) where
     ppr (HsPS { hsps_body = ty }) = ppr ty
 
+
+instance Outputable HsTyLit where
+    ppr = ppr_tylit
+
+instance Outputable HsIPName where
+    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters
+
+instance OutputableBndr HsIPName where
+    pprBndr _ n   = ppr n         -- Simple for now
+    pprInfixOcc  n = ppr n
+    pprPrefixOcc n = ppr n
+
+instance (Outputable tyarg, Outputable arg, Outputable rec)
+         => Outputable (HsConDetails tyarg arg rec) where
+  ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args
+  ppr (RecCon rec)            = text "RecCon:" <+> ppr rec
+  ppr (InfixCon l r)          = text "InfixCon:" <+> ppr [l, r]
+
+instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where
+  ppr = ppr . foLabel
+
+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where
+  pprInfixOcc  = pprInfixOcc . unXRec @pass . foLabel
+  pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel
+
+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where
+  pprInfixOcc  = pprInfixOcc . unLoc
+  pprPrefixOcc = pprPrefixOcc . unLoc
+
+
+ppr_tylit :: HsTyLit -> SDoc
+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)
+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))
+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))
+
 pprAnonWildCard :: SDoc
 pprAnonWildCard = char '_'