{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | Rendering of types.
module Ormolu.Printer.Meat.Type
  ( p_hsType,
    p_hsTypePostDoc,
    hasDocStrings,
    p_hsContext,
    p_hsTyVarBndr,
    ForAllVisibility (..),
    p_forallBndrs,
    p_conDeclFields,
    p_lhsTypeArg,
    p_hsSigType,
    tyVarsToTyPats,
    hsOuterTyVarBndrsToHsType,
    lhsTypeToSigType,
  )
where

import Data.Foldable (for_)
import GHC.Hs
import GHC.Types.Basic hiding (isPromoted)
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Var
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
import Ormolu.Printer.Operators
import Ormolu.Utils

p_hsType :: HsType GhcPs -> R ()
p_hsType :: HsType GhcPs -> R ()
p_hsType HsType GhcPs
t = Bool -> TypeDocStyle -> HsType GhcPs -> R ()
p_hsType' (HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
t) TypeDocStyle
PipeStyle HsType GhcPs
t

p_hsTypePostDoc :: HsType GhcPs -> R ()
p_hsTypePostDoc :: HsType GhcPs -> R ()
p_hsTypePostDoc HsType GhcPs
t = Bool -> TypeDocStyle -> HsType GhcPs -> R ()
p_hsType' (HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
t) TypeDocStyle
CaretStyle HsType GhcPs
t

-- | How to render Haddocks associated with a type.
data TypeDocStyle
  = PipeStyle
  | CaretStyle

p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()
p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()
p_hsType' Bool
multilineArgs TypeDocStyle
docStyle = \case
  HsForAllTy XForAllTy GhcPs
_ HsForAllTelescope GhcPs
tele LHsType GhcPs
t -> do
    case HsForAllTelescope GhcPs
tele of
      HsForAllInvis XHsForAllInvis GhcPs
_ [LHsTyVarBndr Specificity GhcPs]
bndrs -> ForAllVisibility
-> (HsTyVarBndr Specificity GhcPs -> R ())
-> [LocatedA (HsTyVarBndr Specificity GhcPs)]
-> R ()
forall a. ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr Specificity GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LocatedA (HsTyVarBndr Specificity GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
bndrs
      HsForAllVis XHsForAllVis GhcPs
_ [LHsTyVarBndr () GhcPs]
bndrs -> ForAllVisibility
-> (HsTyVarBndr () GhcPs -> R ())
-> [LocatedA (HsTyVarBndr () GhcPs)]
-> R ()
forall a. ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
p_forallBndrs ForAllVisibility
ForAllVis HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LocatedA (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
bndrs
    R ()
interArgBreak
    HsType GhcPs -> R ()
p_hsTypeR (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t)
  HsQualTy XQualTy GhcPs
_ Maybe (LHsContext GhcPs)
qs' LHsType GhcPs
t -> do
    Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
    -> R ())
-> R ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
Maybe (LHsContext GhcPs)
qs' ((GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
  -> R ())
 -> R ())
-> (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
    -> R ())
-> R ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
qs -> do
      GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
qs [GenLocated SrcSpanAnnA (HsType GhcPs)] -> R ()
HsContext GhcPs -> R ()
p_hsContext
      R ()
space
      Text -> R ()
txt Text
"=>"
      R ()
interArgBreak
    case GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t of
      HsQualTy {} -> HsType GhcPs -> R ()
p_hsTypeR (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t)
      HsFunTy {} -> HsType GhcPs -> R ()
p_hsTypeR (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t)
      HsType GhcPs
_ -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsTypeR
  HsTyVar XTyVar GhcPs
_ PromotionFlag
p LIdP GhcPs
n -> do
    case PromotionFlag
p of
      PromotionFlag
IsPromoted -> do
        Text -> R ()
txt Text
"'"
        case RdrName -> String
forall o. Outputable o => o -> String
showOutputable (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
n) of
          Char
_ : Char
'\'' : String
_ -> R ()
space
          String
_ -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      PromotionFlag
NotPromoted -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
n
  HsAppTy XAppTy GhcPs
_ LHsType GhcPs
f LHsType GhcPs
x -> do
    let -- In order to format type applications with multiple parameters
        -- nicer, traverse the AST to gather the function and all the
        -- parameters together.
        gatherArgs :: GenLocated l (HsType pass)
-> [GenLocated l (HsType pass)]
-> (GenLocated l (HsType pass), [GenLocated l (HsType pass)])
gatherArgs GenLocated l (HsType pass)
f' [GenLocated l (HsType pass)]
knownArgs =
          case GenLocated l (HsType pass)
f' of
            L l
_ (HsAppTy XAppTy pass
_ LHsType pass
l LHsType pass
r) -> GenLocated l (HsType pass)
-> [GenLocated l (HsType pass)]
-> (GenLocated l (HsType pass), [GenLocated l (HsType pass)])
gatherArgs GenLocated l (HsType pass)
LHsType pass
l (GenLocated l (HsType pass)
LHsType pass
r GenLocated l (HsType pass)
-> [GenLocated l (HsType pass)] -> [GenLocated l (HsType pass)]
forall a. a -> [a] -> [a]
: [GenLocated l (HsType pass)]
knownArgs)
            GenLocated l (HsType pass)
_ -> (GenLocated l (HsType pass)
f', [GenLocated l (HsType pass)]
knownArgs)
        (GenLocated SrcSpanAnnA (HsType GhcPs)
func, [GenLocated SrcSpanAnnA (HsType GhcPs)]
args) = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> (GenLocated SrcSpanAnnA (HsType GhcPs),
    [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall pass l.
(LHsType pass ~ GenLocated l (HsType pass)) =>
GenLocated l (HsType pass)
-> [GenLocated l (HsType pass)]
-> (GenLocated l (HsType pass), [GenLocated l (HsType pass)])
gatherArgs GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
f [GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x]
    [SrcSpan] -> R () -> R ()
switchLayout (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
f SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [GenLocated SrcSpanAnnA (HsType GhcPs)]
args) (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
func HsType GhcPs -> R ()
p_hsType
      R ()
breakpoint
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
        R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint ((HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
args
  HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
kd -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    -- The first argument is the location of the "@..." part. Not 100% sure,
    -- but I think we can ignore it as long as we use 'located' on both the
    -- type and the kind.
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty HsType GhcPs -> R ()
p_hsType
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> R ()
txt Text
"@"
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
kd HsType GhcPs -> R ()
p_hsType
  HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
arrow LHsType GhcPs
x y :: LHsType GhcPs
y@(L _ y') -> do
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x HsType GhcPs -> R ()
p_hsType
    R ()
space
    case HsArrow GhcPs
arrow of
      HsUnrestrictedArrow IsUnicodeSyntax
_ -> Text -> R ()
txt Text
"->"
      HsLinearArrow IsUnicodeSyntax
_ Maybe AddEpAnn
_ -> Text -> R ()
txt Text
"%1 ->"
      HsExplicitMult IsUnicodeSyntax
_ Maybe AddEpAnn
_ LHsType GhcPs
mult -> do
        Text -> R ()
txt Text
"%"
        HsType GhcPs -> R ()
p_hsTypeR (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
mult)
        R ()
space
        Text -> R ()
txt Text
"->"
    R ()
interArgBreak
    case HsType GhcPs
y' of
      HsFunTy {} -> HsType GhcPs -> R ()
p_hsTypeR HsType GhcPs
y'
      HsType GhcPs
_ -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
y HsType GhcPs -> R ()
p_hsTypeR
  HsListTy XListTy GhcPs
_ LHsType GhcPs
t ->
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t (BracketStyle -> R () -> R ()
brackets BracketStyle
N (R () -> R ()) -> (HsType GhcPs -> R ()) -> HsType GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> R ()
p_hsType)
  HsTupleTy XTupleTy GhcPs
_ HsTupleSort
tsort HsContext GhcPs
xs ->
    let parens' :: R () -> R ()
parens' =
          case HsTupleSort
tsort of
            HsTupleSort
HsUnboxedTuple -> BracketStyle -> R () -> R ()
parensHash BracketStyle
N
            HsTupleSort
HsBoxedOrConstraintTuple -> BracketStyle -> R () -> R ()
parens BracketStyle
N
     in R () -> R ()
parens' (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsSumTy XSumTy GhcPs
_ HsContext GhcPs
xs ->
    BracketStyle -> R () -> R ()
parensHash BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
"|" R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsOpTy XOpTy GhcPs
_ LHsType GhcPs
x LIdP GhcPs
op LHsType GhcPs
y ->
    R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      let opTree :: OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
opTree = OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op
OpBranch (LHsType GhcPs
-> OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
tyOpTree LHsType GhcPs
x) GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
op (LHsType GhcPs
-> OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
tyOpTree LHsType GhcPs
y)
       in OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName) -> R ()
p_tyOpTree ((RdrName -> Maybe RdrName)
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
forall l l' op ty.
(HasSrcSpan l, HasSrcSpan l') =>
(op -> Maybe RdrName)
-> OpTree (GenLocated l ty) (GenLocated l' op)
-> OpTree (GenLocated l ty) (GenLocated l' op)
reassociateOpTree RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
opTree)
  HsParTy XParTy GhcPs
_ LHsType GhcPs
t ->
    BracketStyle -> R () -> R ()
parens BracketStyle
N (GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType)
  HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
n LHsType GhcPs
t -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpan HsIPName -> (HsIPName -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpan HsIPName
XRec GhcPs HsIPName
n HsIPName -> R ()
forall a. Outputable a => a -> R ()
atom
    R ()
space
    Text -> R ()
txt Text
"::"
    R ()
breakpoint
    R () -> R ()
inci (GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType)
  HsStarTy XStarTy GhcPs
_ Bool
_ -> Text -> R ()
txt Text
"*"
  HsKindSig XKindSig GhcPs
_ LHsType GhcPs
t LHsType GhcPs
k -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType
    R ()
space
    Text -> R ()
txt Text
"::"
    R ()
breakpoint
    R () -> R ()
inci (GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
k HsType GhcPs -> R ()
p_hsType)
  HsSpliceTy XSpliceTy GhcPs
_ HsSplice GhcPs
splice -> HsSplice GhcPs -> R ()
p_hsSplice HsSplice GhcPs
splice
  HsDocTy XDocTy GhcPs
_ LHsType GhcPs
t LHsDocString
str ->
    case TypeDocStyle
docStyle of
      TypeDocStyle
PipeStyle -> do
        HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True LHsDocString
str
        GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType
      TypeDocStyle
CaretStyle -> do
        GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType
        R ()
newline
        HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Caret Bool
False LHsDocString
str
  HsBangTy XBangTy GhcPs
_ (HsSrcBang SourceText
_ SrcUnpackedness
u SrcStrictness
s) LHsType GhcPs
t -> do
    case SrcUnpackedness
u of
      SrcUnpackedness
SrcUnpack -> Text -> R ()
txt Text
"{-# UNPACK #-}" R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
      SrcUnpackedness
SrcNoUnpack -> Text -> R ()
txt Text
"{-# NOUNPACK #-}" R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
      SrcUnpackedness
NoSrcUnpack -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case SrcStrictness
s of
      SrcStrictness
SrcLazy -> Text -> R ()
txt Text
"~"
      SrcStrictness
SrcStrict -> Text -> R ()
txt Text
"!"
      SrcStrictness
NoSrcStrict -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType
  HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
fields ->
    [LConDeclField GhcPs] -> R ()
p_conDeclFields [LConDeclField GhcPs]
fields
  HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
p HsContext GhcPs
xs -> do
    case PromotionFlag
p of
      PromotionFlag
IsPromoted -> Text -> R ()
txt Text
"'"
      PromotionFlag
NotPromoted -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    BracketStyle -> R () -> R ()
brackets BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      -- If both this list itself and the first element is promoted,
      -- we need to put a space in between or it fails to parse.
      case (PromotionFlag
p, [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs) of
        (PromotionFlag
IsPromoted, L SrcSpanAnnA
_ HsType GhcPs
t : [GenLocated SrcSpanAnnA (HsType GhcPs)]
_) | HsType GhcPs -> Bool
isPromoted HsType GhcPs
t -> R ()
space
        (PromotionFlag, [GenLocated SrcSpanAnnA (HsType GhcPs)])
_ -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
xs -> do
    Text -> R ()
txt Text
"'"
    BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      case HsContext GhcPs
xs of
        L _ t : HsContext GhcPs
_ | HsType GhcPs -> Bool
isPromoted HsType GhcPs
t -> R ()
space
        HsContext GhcPs
_ -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel ((HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsTyLit XTyLit GhcPs
_ HsTyLit
t ->
    case HsTyLit
t of
      HsStrTy (SourceText String
s) FastString
_ -> String -> R ()
p_stringLit String
s
      HsTyLit
a -> HsTyLit -> R ()
forall a. Outputable a => a -> R ()
atom HsTyLit
a
  HsWildCardTy XWildCardTy GhcPs
_ -> Text -> R ()
txt Text
"_"
  XHsType XXType GhcPs
t -> HsCoreTy -> R ()
forall a. Outputable a => a -> R ()
atom HsCoreTy
XXType GhcPs
t
  where
    isPromoted :: HsType GhcPs -> Bool
isPromoted = \case
      HsAppTy XAppTy GhcPs
_ (L _ f) LHsType GhcPs
_ -> HsType GhcPs -> Bool
isPromoted HsType GhcPs
f
      HsTyVar XTyVar GhcPs
_ PromotionFlag
IsPromoted LIdP GhcPs
_ -> Bool
True
      HsExplicitTupleTy {} -> Bool
True
      HsExplicitListTy {} -> Bool
True
      HsType GhcPs
_ -> Bool
False
    interArgBreak :: R ()
interArgBreak =
      if Bool
multilineArgs
        then R ()
newline
        else R ()
breakpoint
    p_hsTypeR :: HsType GhcPs -> R ()
p_hsTypeR = Bool -> TypeDocStyle -> HsType GhcPs -> R ()
p_hsType' Bool
multilineArgs TypeDocStyle
docStyle

-- | Return 'True' if at least one argument in 'HsType' has a doc string
-- attached to it.
hasDocStrings :: HsType GhcPs -> Bool
hasDocStrings :: HsType GhcPs -> Bool
hasDocStrings = \case
  HsDocTy {} -> Bool
True
  HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
_ (L _ x) (L _ y) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x Bool -> Bool -> Bool
|| HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
y
  HsForAllTy XForAllTy GhcPs
_ HsForAllTelescope GhcPs
_ (L _ x) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x
  HsQualTy XQualTy GhcPs
_ Maybe (LHsContext GhcPs)
_ (L _ x) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x
  HsType GhcPs
_ -> Bool
False

p_hsContext :: HsContext GhcPs -> R ()
p_hsContext :: HsContext GhcPs -> R ()
p_hsContext = \case
  [] -> Text -> R ()
txt Text
"()"
  [LHsType GhcPs
x] -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x HsType GhcPs -> R ()
p_hsType
  HsContext GhcPs
xs -> BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs

class IsInferredTyVarBndr flag where
  isInferred :: flag -> Bool

instance IsInferredTyVarBndr () where
  isInferred :: () -> Bool
isInferred () = Bool
False

instance IsInferredTyVarBndr Specificity where
  isInferred :: Specificity -> Bool
isInferred = \case
    Specificity
InferredSpec -> Bool
True
    Specificity
SpecifiedSpec -> Bool
False

p_hsTyVarBndr :: IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr :: HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr = \case
  UserTyVar XUserTyVar GhcPs
_ flag
flag LIdP GhcPs
x ->
    (if flag -> Bool
forall flag. IsInferredTyVarBndr flag => flag -> Bool
isInferred flag
flag then BracketStyle -> R () -> R ()
braces BracketStyle
N else R () -> R ()
forall a. a -> a
id) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
x
  KindedTyVar XKindedTyVar GhcPs
_ flag
flag LIdP GhcPs
l LHsType GhcPs
k -> (if flag -> Bool
forall flag. IsInferredTyVarBndr flag => flag -> Bool
isInferred flag
flag then BracketStyle -> R () -> R ()
braces else BracketStyle -> R () -> R ()
parens) BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpanAnnN RdrName -> (RdrName -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
l RdrName -> R ()
forall a. Outputable a => a -> R ()
atom
    R ()
space
    Text -> R ()
txt Text
"::"
    R ()
breakpoint
    R () -> R ()
inci (GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
k HsType GhcPs -> R ()
p_hsType)

data ForAllVisibility = ForAllInvis | ForAllVis

-- | Render several @forall@-ed variables.
p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis a -> R ()
_ [] = Text -> R ()
txt Text
"forall."
p_forallBndrs ForAllVisibility
ForAllVis a -> R ()
_ [] = Text -> R ()
txt Text
"forall ->"
p_forallBndrs ForAllVisibility
vis a -> R ()
p [LocatedA a]
tyvars =
  [SrcSpan] -> R () -> R ()
switchLayout (LocatedA a -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LocatedA a -> SrcSpan) -> [LocatedA a] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocatedA a]
tyvars) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> R ()
txt Text
"forall"
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LocatedA a -> R ()) -> [LocatedA a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc (R () -> R ()) -> (LocatedA a -> R ()) -> LocatedA a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> R ()) -> LocatedA a -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' a -> R ()
p) [LocatedA a]
tyvars
      case ForAllVisibility
vis of
        ForAllVisibility
ForAllInvis -> Text -> R ()
txt Text
"."
        ForAllVisibility
ForAllVis -> R ()
space R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"->"

p_conDeclFields :: [LConDeclField GhcPs] -> R ()
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
p_conDeclFields [LConDeclField GhcPs]
xs =
  BracketStyle -> R () -> R ()
braces BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> R ())
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDeclField GhcPs -> R ())
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' ConDeclField GhcPs -> R ()
p_conDeclField) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
[LConDeclField GhcPs]
xs

p_conDeclField :: ConDeclField GhcPs -> R ()
p_conDeclField :: ConDeclField GhcPs -> R ()
p_conDeclField ConDeclField {[LFieldOcc GhcPs]
Maybe LHsDocString
LHsType GhcPs
XConDeclField GhcPs
cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass
cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_ext :: forall pass. ConDeclField pass -> XConDeclField pass
cd_fld_doc :: forall pass. ConDeclField pass -> Maybe LHsDocString
cd_fld_doc :: Maybe LHsDocString
cd_fld_type :: LHsType GhcPs
cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_ext :: XConDeclField GhcPs
..} = do
  (LHsDocString -> R ()) -> Maybe LHsDocString -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True) Maybe LHsDocString
cd_fld_doc
  R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
    R ()
-> (GenLocated SrcSpan (FieldOcc GhcPs) -> R ())
-> [GenLocated SrcSpan (FieldOcc GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
      R ()
commaDel
      ((FieldOcc GhcPs -> R ())
-> GenLocated SrcSpan (FieldOcc GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' (GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName (GenLocated SrcSpanAnnN RdrName -> R ())
-> (FieldOcc GhcPs -> GenLocated SrcSpanAnnN RdrName)
-> FieldOcc GhcPs
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcPs -> GenLocated SrcSpanAnnN RdrName
forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc))
      [GenLocated SrcSpan (FieldOcc GhcPs)]
[LFieldOcc GhcPs]
cd_fld_names
  R ()
space
  Text -> R ()
txt Text
"::"
  R ()
breakpoint
  R () -> R ()
sitcc (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> R ()
p_hsType (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
cd_fld_type)

tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName)
tyOpTree :: LHsType GhcPs
-> OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
tyOpTree (L _ (HsOpTy _ l op r)) =
  OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op
OpBranch (LHsType GhcPs
-> OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
tyOpTree LHsType GhcPs
l) GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
op (LHsType GhcPs
-> OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
tyOpTree LHsType GhcPs
r)
tyOpTree LHsType GhcPs
n = GenLocated SrcSpanAnnA (HsType GhcPs)
-> OpTree
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnN RdrName)
forall ty op. ty -> OpTree ty op
OpNode GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
n

p_tyOpTree :: OpTree (LHsType GhcPs) (LocatedN RdrName) -> R ()
p_tyOpTree :: OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName) -> R ()
p_tyOpTree (OpNode LHsType GhcPs
n) = GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
n HsType GhcPs -> R ()
p_hsType
p_tyOpTree (OpBranch OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
l GenLocated SrcSpanAnnN RdrName
op OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
r) = do
  [SrcSpan] -> R () -> R ()
switchLayout [OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
-> SrcSpan
forall l a b. HasSrcSpan l => OpTree (GenLocated l a) b -> SrcSpan
opTreeLoc OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
l] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
    OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName) -> R ()
p_tyOpTree OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
l
  R ()
breakpoint
  R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SrcSpan] -> R () -> R ()
switchLayout [OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
-> SrcSpan
forall l a b. HasSrcSpan l => OpTree (GenLocated l a) b -> SrcSpan
opTreeLoc OpTree
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnN RdrName)
OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
r] (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
op
    R ()
space
    OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName) -> R ()
p_tyOpTree OpTree (LHsType GhcPs) (GenLocated SrcSpanAnnN RdrName)
r

p_lhsTypeArg :: LHsTypeArg GhcPs -> R ()
p_lhsTypeArg :: LHsTypeArg GhcPs -> R ()
p_lhsTypeArg = \case
  HsValArg LHsType GhcPs
ty -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty HsType GhcPs -> R ()
p_hsType
  -- first argument is the SrcSpan of the @,
  -- but the @ always has to be directly before the type argument
  HsTypeArg SrcSpan
_ LHsType GhcPs
ty -> Text -> R ()
txt Text
"@" R () -> R () -> R ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty HsType GhcPs -> R ()
p_hsType
  -- NOTE(amesgen) is this unreachable or just not implemented?
  HsArgPar SrcSpan
_ -> String -> R ()
forall a. String -> a
notImplemented String
"HsArgPar"

p_hsSigType :: HsSigType GhcPs -> R ()
p_hsSigType :: HsSigType GhcPs -> R ()
p_hsSigType HsSig {LHsType GhcPs
HsOuterSigTyVarBndrs GhcPs
XHsSig GhcPs
sig_ext :: forall pass. HsSigType pass -> XHsSig pass
sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_body :: LHsType GhcPs
sig_bndrs :: HsOuterSigTyVarBndrs GhcPs
sig_ext :: XHsSig GhcPs
..} =
  HsType GhcPs -> R ()
p_hsType (HsType GhcPs -> R ()) -> HsType GhcPs -> R ()
forall a b. (a -> b) -> a -> b
$ HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsType GhcPs
hsOuterTyVarBndrsToHsType HsOuterSigTyVarBndrs GhcPs
sig_bndrs LHsType GhcPs
sig_body

----------------------------------------------------------------------------
-- Conversion functions

tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs
tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs
tyVarToType = \case
  UserTyVar XUserTyVar GhcPs
_ () LIdP GhcPs
tvar -> XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall ann. EpAnn ann
EpAnnNotUsed PromotionFlag
NotPromoted LIdP GhcPs
tvar
  KindedTyVar XKindedTyVar GhcPs
_ () LIdP GhcPs
tvar LHsType GhcPs
kind ->
    -- Note: we always add parentheses because for whatever reason GHC does
    -- not use HsParTy for left-hand sides of declarations. Please see
    -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
    -- long as 'tyVarToType' does not get applied to right-hand sides of
    -- declarations.
    XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall ann. EpAnn ann
EpAnnNotUsed (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$
      XKindSig GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig XKindSig GhcPs
forall ann. EpAnn ann
EpAnnNotUsed (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall ann. EpAnn ann
EpAnnNotUsed PromotionFlag
NotPromoted LIdP GhcPs
tvar)) LHsType GhcPs
kind

tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs
tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs
tyVarsToTyPats HsQTvs {[LHsTyVarBndr () GhcPs]
XHsQTvs GhcPs
hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit :: [LHsTyVarBndr () GhcPs]
hsq_ext :: XHsQTvs GhcPs
..} = GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. tm -> HsArg tm ty
HsValArg (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> (LocatedA (HsTyVarBndr () GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> LocatedA (HsTyVarBndr () GhcPs)
-> HsArg
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr () GhcPs -> HsType GhcPs)
-> LocatedA (HsTyVarBndr () GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr () GhcPs -> HsType GhcPs
tyVarToType (LocatedA (HsTyVarBndr () GhcPs)
 -> HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [LocatedA (HsTyVarBndr () GhcPs)]
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocatedA (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
hsq_explicit

-- could be generalized to also handle () instead of Specificity
hsOuterTyVarBndrsToHsType ::
  HsOuterTyVarBndrs Specificity GhcPs ->
  LHsType GhcPs ->
  HsType GhcPs
hsOuterTyVarBndrsToHsType :: HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsType GhcPs
hsOuterTyVarBndrsToHsType HsOuterSigTyVarBndrs GhcPs
obndrs LHsType GhcPs
ty = case HsOuterSigTyVarBndrs GhcPs
obndrs of
  HsOuterImplicit XHsOuterImplicit GhcPs
NoExtField -> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty
  HsOuterExplicit XHsOuterExplicit GhcPs Specificity
_ [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
bndrs ->
    XForAllTy GhcPs
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy NoExtField
XForAllTy GhcPs
NoExtField (EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallTy
forall ann. EpAnn ann
EpAnnNotUsed [LHsTyVarBndr Specificity GhcPs]
[LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
bndrs) LHsType GhcPs
ty

lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs
lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs
lhsTypeToSigType LHsType GhcPs
ty =
  Located (HsSigType GhcPs)
-> LocatedAn AnnListItem (HsSigType GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsSigType GhcPs)
 -> LocatedAn AnnListItem (HsSigType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> Located (HsSigType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> LocatedAn AnnListItem (HsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsSigType GhcPs -> Located (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty) (HsSigType GhcPs -> Located (HsSigType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsSigType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> Located (HsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsSig GhcPs
-> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsSigType GhcPs
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig NoExtField
XHsSig GhcPs
NoExtField (XHsOuterImplicit GhcPs -> HsOuterSigTyVarBndrs GhcPs
forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit NoExtField
XHsOuterImplicit GhcPs
NoExtField) (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> LocatedAn AnnListItem (HsSigType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> LocatedAn AnnListItem (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty