{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | Rendering of types.
module Ormolu.Printer.Meat.Type
  ( p_hsType,
    startTypeAnnotation,
    startTypeAnnotationDecl,
    hasDocStrings,
    p_hsContext,
    p_hsContext',
    p_hsTyVarBndr,
    ForAllVisibility (..),
    p_forallBndrs,
    p_conDeclFields,
    p_lhsTypeArg,
    p_hsSigType,
    p_hsForAllTelescope,
    p_hsQualArrow,
    p_hsFun,
    hsOuterTyVarBndrsToHsType,
    lhsTypeToSigType,
  )
where

import Control.Monad
import Data.Choice (Choice, pattern With, pattern Without)
import Data.Choice qualified as Choice
import Data.Functor ((<&>))
import Data.List (sortOn)
import GHC.Data.Strict qualified as Strict
import GHC.Hs hiding (isPromoted)
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Utils.Outputable (Outputable)
import Ormolu.Config
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree)
import Ormolu.Printer.Meat.Declaration.StringLiteral
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice)
import Ormolu.Printer.Operators
import Ormolu.Utils

p_hsType :: HsType GhcPs -> R ()
p_hsType :: HsType GhcPs -> R ()
p_hsType HsType GhcPs
t = do
  layout <- R Layout
getLayout
  p_hsType' (Choice.fromBool $ hasDocStrings t || layout == MultiLine) t

p_hsType' :: Choice "multiline" -> HsType GhcPs -> R ()
p_hsType' :: Choice "multiline" -> HsType GhcPs -> R ()
p_hsType' Choice "multiline"
isMultiline = \case
  HsForAllTy XForAllTy GhcPs
_ HsForAllTelescope GhcPs
tele XRec GhcPs (HsType GhcPs)
t -> do
    Choice "multiline" -> HsForAllTelescope GhcPs -> R ()
p_hsForAllTelescope Choice "multiline"
isMultiline HsForAllTelescope GhcPs
tele
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
t HsType GhcPs -> R ()
p_hsType
  HsQualTy XQualTy GhcPs
_ LHsContext GhcPs
qs XRec GhcPs (HsType GhcPs)
t -> do
    GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
LHsContext GhcPs
qs [GenLocated SrcSpanAnnA (HsType GhcPs)] -> R ()
HsContext GhcPs -> R ()
p_hsContext
    Choice "multiline" -> R ()
p_hsQualArrow Choice "multiline"
isMultiline
    case GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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)
XRec GhcPs (HsType GhcPs)
t)
      HsFunTy {} -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
t HsType GhcPs -> R ()
p_hsType
      HsType GhcPs
_ -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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 a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      PromotionFlag
NotPromoted -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
n
  HsAppTy XAppTy GhcPs
_ XRec GhcPs (HsType GhcPs)
f XRec GhcPs (HsType 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
_ XRec pass (HsType pass)
l XRec pass (HsType pass)
r) -> GenLocated l (HsType pass)
-> [GenLocated l (HsType pass)]
-> (GenLocated l (HsType pass), [GenLocated l (HsType pass)])
gatherArgs GenLocated l (HsType pass)
XRec pass (HsType pass)
l (GenLocated l (HsType pass)
XRec pass (HsType 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}.
(XRec pass (HsType 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)
XRec GhcPs (HsType GhcPs)
f [GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
x]
    [SrcSpan] -> R () -> R ()
switchLayout (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
f SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated 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. HasLoc 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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
args
  HsAppKindTy XAppKindTy GhcPs
_ XRec GhcPs (HsType GhcPs)
ty XRec GhcPs (HsType 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. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
kd HsType GhcPs -> R ()
p_hsType
  HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
arrow XRec GhcPs (HsType GhcPs)
x XRec GhcPs (HsType GhcPs)
y -> do
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
x HsType GhcPs -> R ()
p_hsType
    Choice "multiline"
-> (HsType GhcPs -> R ())
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> R ()
forall l a.
HasLoc l =>
Choice "multiline"
-> (a -> R ())
-> HsArrowOf (GenLocated l a) GhcPs
-> GenLocated l a
-> R ()
p_hsFun Choice "multiline"
isMultiline HsType GhcPs -> R ()
p_hsTypeR HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
HsArrow GhcPs
arrow GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
y
  HsListTy XListTy GhcPs
_ XRec GhcPs (HsType GhcPs)
t ->
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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. HasLoc 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 (R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"|" R () -> R () -> R ()
forall a b. R a -> R b -> R b
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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsOpTy XOpTy GhcPs
_ PromotionFlag
_ XRec GhcPs (HsType GhcPs)
x LIdP GhcPs
op XRec GhcPs (HsType GhcPs)
y -> do
    modFixityMap <- R ModuleFixityMap
askModuleFixityMap
    debug <- askDebug
    let 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
BinaryOpBranches (XRec GhcPs (HsType GhcPs)
-> OpTree
     (XRec GhcPs (HsType GhcPs)) (GenLocated SrcSpanAnnN RdrName)
tyOpTree XRec GhcPs (HsType GhcPs)
x) GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
op (XRec GhcPs (HsType GhcPs)
-> OpTree
     (XRec GhcPs (HsType GhcPs)) (GenLocated SrcSpanAnnN RdrName)
tyOpTree XRec GhcPs (HsType GhcPs)
y)
    p_tyOpTree
      (reassociateOpTree debug (Just . unLoc) modFixityMap opTree)
  HsParTy XParTy GhcPs
_ XRec GhcPs (HsType GhcPs)
t -> do
    csSpans <-
      (GenLocated RealSrcSpan Comment -> SrcSpan)
-> [GenLocated RealSrcSpan Comment] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RealSrcSpan -> Maybe BufSpan -> SrcSpan)
-> Maybe BufSpan -> RealSrcSpan -> SrcSpan
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan Maybe BufSpan
forall a. Maybe a
Strict.Nothing (RealSrcSpan -> SrcSpan)
-> (GenLocated RealSrcSpan Comment -> RealSrcSpan)
-> GenLocated RealSrcSpan Comment
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated RealSrcSpan Comment -> RealSrcSpan
forall l e. GenLocated l e -> l
getLoc) ([GenLocated RealSrcSpan Comment] -> [SrcSpan])
-> R [GenLocated RealSrcSpan Comment] -> R [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R [GenLocated RealSrcSpan Comment]
getEnclosingComments
    switchLayout (locA t : csSpans) $
      parens N (sitcc $ located t p_hsType)
  HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
n XRec GhcPs (HsType GhcPs)
t -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated EpAnnCO HsIPName -> (HsIPName -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated EpAnnCO HsIPName
XRec GhcPs HsIPName
n HsIPName -> R ()
forall a. Outputable a => a -> R ()
atom
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
t HsType GhcPs -> R ()
p_hsType
  HsStarTy XStarTy GhcPs
_ Bool
_ -> R ()
token'star
  HsKindSig XKindSig GhcPs
_ XRec GhcPs (HsType GhcPs)
t XRec GhcPs (HsType 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. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
t HsType GhcPs -> R ()
p_hsType
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
k HsType GhcPs -> R ()
p_hsType
  HsSpliceTy XSpliceTy GhcPs
_ HsUntypedSplice GhcPs
splice -> SpliceDecoration -> HsUntypedSplice GhcPs -> R ()
p_hsUntypedSplice SpliceDecoration
DollarSplice HsUntypedSplice GhcPs
splice
  HsDocTy XDocTy GhcPs
_ XRec GhcPs (HsType GhcPs)
t LHsDoc GhcPs
str -> do
    usePipe <-
      (forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle)
-> R FunctionArrowsStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f FunctionArrowsStyle
forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle
poFunctionArrows R FunctionArrowsStyle -> (FunctionArrowsStyle -> Bool) -> R Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        FunctionArrowsStyle
TrailingArrows -> Bool
True
        FunctionArrowsStyle
LeadingArrows -> Bool
False
        FunctionArrowsStyle
LeadingArgsArrows -> Bool
False
    if usePipe
      then do
        p_hsDoc Pipe (With #endNewline) str
        located t p_hsType
      else do
        located t p_hsType
        newline
        p_hsDoc Caret (Without #endNewline) str
  HsBangTy XBangTy GhcPs
_ (HsBang SrcUnpackedness
u SrcStrictness
s) XRec GhcPs (HsType GhcPs)
t -> do
    case SrcUnpackedness
u of
      SrcUnpackedness
SrcUnpack -> Text -> R ()
txt Text
"{-# UNPACK #-}" R () -> R () -> R ()
forall a b. R a -> R b -> R b
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 a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
      SrcUnpackedness
NoSrcUnpack -> () -> R ()
forall a. a -> R a
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 a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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 a. a -> R a
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 this list is promoted and the first element starts with a single
      -- quote, 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
startsWithSingleQuote HsType GhcPs
t -> R ()
space
        (PromotionFlag, [GenLocated SrcSpanAnnA (HsType GhcPs)])
_ -> () -> R ()
forall a. a -> R a
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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsExplicitTupleTy XExplicitTupleTy GhcPs
_ PromotionFlag
p HsContext GhcPs
xs -> do
    case PromotionFlag
p of
      PromotionFlag
IsPromoted -> Text -> R ()
txt Text
"'"
      PromotionFlag
NotPromoted -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      -- If this tuple is promoted and the first element starts with a single
      -- quote, 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
startsWithSingleQuote HsType GhcPs
t -> R ()
space
        (PromotionFlag, [GenLocated SrcSpanAnnA (HsType GhcPs)])
_ -> () -> R ()
forall a. a -> R a
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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsType) [GenLocated SrcSpanAnnA (HsType GhcPs)]
HsContext GhcPs
xs
  HsTyLit XTyLit GhcPs
_ HsTyLit GhcPs
t ->
    case HsTyLit GhcPs
t of
      HsStrTy (SourceText FastString
s) FastString
_ -> FastString -> R ()
p_stringLit FastString
s
      HsTyLit GhcPs
a -> HsTyLit GhcPs -> R ()
forall a. Outputable a => a -> R ()
atom HsTyLit GhcPs
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
    startsWithSingleQuote :: HsType GhcPs -> Bool
startsWithSingleQuote = \case
      HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ HsType GhcPs
f) XRec GhcPs (HsType GhcPs)
_ -> HsType GhcPs -> Bool
startsWithSingleQuote HsType GhcPs
f
      HsTyVar XTyVar GhcPs
_ PromotionFlag
IsPromoted LIdP GhcPs
_ -> Bool
True
      HsExplicitTupleTy {} -> Bool
True
      HsExplicitListTy {} -> Bool
True
      HsTyLit XTyLit GhcPs
_ HsCharTy {} -> Bool
True
      HsType GhcPs
_ -> Bool
False
    p_hsTypeR :: HsType GhcPs -> R ()
p_hsTypeR HsType GhcPs
m = Choice "multiline" -> HsType GhcPs -> R ()
p_hsType' Choice "multiline"
isMultiline HsType GhcPs
m

startTypeAnnotation ::
  (HasLoc l) =>
  GenLocated l a ->
  (a -> R ()) ->
  R ()
startTypeAnnotation :: forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation = R () -> R () -> GenLocated l a -> (a -> R ()) -> R ()
forall l a.
HasLoc l =>
R () -> R () -> GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation' R ()
breakpoint R ()
breakpoint

startTypeAnnotationDecl ::
  (HasLoc l) =>
  GenLocated l a ->
  (a -> HsType GhcPs) ->
  (a -> R ()) ->
  R ()
startTypeAnnotationDecl :: forall l a.
HasLoc l =>
GenLocated l a -> (a -> HsType GhcPs) -> (a -> R ()) -> R ()
startTypeAnnotationDecl GenLocated l a
lItem a -> HsType GhcPs
getType =
  R () -> R () -> GenLocated l a -> (a -> R ()) -> R ()
forall l a.
HasLoc l =>
R () -> R () -> GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation'
    ( if HsType GhcPs -> Bool
hasDocStrings (HsType GhcPs -> Bool) -> HsType GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ a -> HsType GhcPs
getType (a -> HsType GhcPs) -> a -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ GenLocated l a -> a
forall l e. GenLocated l e -> e
unLoc GenLocated l a
lItem
        then R ()
newline
        else R ()
breakpoint
    )
    R ()
breakpoint
    GenLocated l a
lItem

startTypeAnnotation' ::
  (HasLoc l) =>
  R () ->
  R () ->
  GenLocated l a ->
  (a -> R ()) ->
  R ()
startTypeAnnotation' :: forall l a.
HasLoc l =>
R () -> R () -> GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation' R ()
breakTrailing R ()
breakLeading GenLocated l a
lItem a -> R ()
renderItem =
  (forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle)
-> R FunctionArrowsStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f FunctionArrowsStyle
forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle
poFunctionArrows R FunctionArrowsStyle -> (FunctionArrowsStyle -> R ()) -> R ()
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FunctionArrowsStyle
TrailingArrows -> do
      R ()
space
      R ()
token'dcolon
      R ()
breakTrailing
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
lItem a -> R ()
renderItem
    FunctionArrowsStyle
LeadingArrows -> do
      R ()
breakLeading
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
lItem ((a -> R ()) -> R ()) -> (a -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \a
item -> do
        R ()
token'dcolon
        R ()
space
        a -> R ()
renderItem a
item
    FunctionArrowsStyle
LeadingArgsArrows -> do
      R ()
space
      R ()
token'dcolon
      R ()
breakTrailing
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
lItem a -> R ()
renderItem

-- | 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 SrcSpanAnnA
_ HsType GhcPs
x) (L SrcSpanAnnA
_ HsType GhcPs
y) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x Bool -> Bool -> Bool
|| HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
y
  HsForAllTy XForAllTy GhcPs
_ HsForAllTelescope GhcPs
_ (L SrcSpanAnnA
_ HsType GhcPs
x) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x
  HsQualTy XQualTy GhcPs
_ LHsContext GhcPs
_ (L SrcSpanAnnA
_ HsType GhcPs
x) -> HsType GhcPs -> Bool
hasDocStrings HsType GhcPs
x
  HsType GhcPs
_ -> Bool
False

p_hsContext :: HsContext GhcPs -> R ()
p_hsContext :: HsContext GhcPs -> R ()
p_hsContext = (HsType GhcPs -> R ()) -> HsContext GhcPs -> R ()
forall a.
(Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>
(a -> R ()) -> [XRec GhcPs a] -> R ()
p_hsContext' HsType GhcPs -> R ()
p_hsType

p_hsContext' ::
  (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>
  (a -> R ()) ->
  [XRec GhcPs a] ->
  R ()
p_hsContext' :: forall a.
(Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>
(a -> R ()) -> [XRec GhcPs a] -> R ()
p_hsContext' a -> R ()
f = \case
  [] -> Text -> R ()
txt Text
"()"
  [XRec GhcPs a
x] -> GenLocated (Anno a) a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated (Anno a) a
XRec GhcPs a
x a -> R ()
f
  [XRec GhcPs a]
xs -> do
    shouldSort <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poSortConstraints
    let sort = if Bool
shouldSort then (GenLocated (Anno a) a -> String)
-> [GenLocated (Anno a) a] -> [GenLocated (Anno a) a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn GenLocated (Anno a) a -> String
forall o. Outputable o => o -> String
showOutputable else [GenLocated (Anno a) a] -> [GenLocated (Anno a) a]
forall a. a -> a
id
    parens N $ sep commaDel (sitcc . located' f) (sort xs)

class IsTyVarBndrFlag flag where
  isInferred :: flag -> Bool
  p_tyVarBndrFlag :: flag -> R ()
  p_tyVarBndrFlag flag
_ = () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

instance IsTyVarBndrFlag (HsBndrVis GhcPs) where
  isInferred :: HsBndrVis GhcPs -> Bool
isInferred HsBndrVis GhcPs
_ = Bool
False
  p_tyVarBndrFlag :: HsBndrVis GhcPs -> R ()
p_tyVarBndrFlag = \case
    HsBndrRequired NoExtField
XBndrRequired GhcPs
NoExtField -> () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    HsBndrInvisible XBndrInvisible GhcPs
_ -> Text -> R ()
txt Text
"@"

p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr :: forall flag. IsTyVarBndrFlag flag => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr HsTvb {flag
XTyVarBndr GhcPs
HsBndrKind GhcPs
HsBndrVar GhcPs
tvb_ext :: XTyVarBndr GhcPs
tvb_flag :: flag
tvb_var :: HsBndrVar GhcPs
tvb_kind :: HsBndrKind GhcPs
tvb_ext :: forall flag pass. HsTyVarBndr flag pass -> XTyVarBndr pass
tvb_flag :: forall flag pass. HsTyVarBndr flag pass -> flag
tvb_kind :: forall flag pass. HsTyVarBndr flag pass -> HsBndrKind pass
tvb_var :: forall flag pass. HsTyVarBndr flag pass -> HsBndrVar pass
..} = do
  flag -> R ()
forall flag. IsTyVarBndrFlag flag => flag -> R ()
p_tyVarBndrFlag flag
tvb_flag
  let wrap :: R () -> R ()
wrap
        | flag -> Bool
forall flag. IsTyVarBndrFlag flag => flag -> Bool
isInferred flag
tvb_flag = BracketStyle -> R () -> R ()
braces BracketStyle
N
        | Bool
otherwise = case HsBndrKind GhcPs
tvb_kind of
            HsBndrKind {} -> BracketStyle -> R () -> R ()
parens BracketStyle
N
            HsBndrNoKind {} -> R () -> R ()
forall a. a -> a
id
  R () -> R ()
wrap (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    case HsBndrVar GhcPs
tvb_var of
      HsBndrVar XBndrVar GhcPs
_ LIdP GhcPs
x -> GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
x
      HsBndrWildCard XBndrWildCard GhcPs
_ -> Text -> R ()
txt Text
"_"
    case HsBndrKind GhcPs
tvb_kind of
      HsBndrKind XBndrKind GhcPs
_ XRec GhcPs (HsType GhcPs)
k -> R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
k HsType GhcPs -> R ()
p_hsType
      HsBndrNoKind XBndrNoKind GhcPs
_ -> () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data ForAllVisibility = ForAllInvis | ForAllVis

-- | Render several @forall@-ed variables.
p_forallBndrs ::
  (HasLoc l) =>
  ForAllVisibility ->
  (a -> R ()) ->
  [GenLocated l a] ->
  R ()
p_forallBndrs :: forall l a.
HasLoc l =>
ForAllVisibility -> (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrs ForAllVisibility
vis a -> R ()
p [GenLocated l a]
tyvars = do
  (a -> R ()) -> [GenLocated l a] -> R ()
forall l a. HasLoc l => (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrsStart a -> R ()
p [GenLocated l a]
tyvars
  ForAllVisibility -> R ()
p_forallBndrsEnd ForAllVisibility
vis

p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrsStart :: forall l a. HasLoc l => (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrsStart a -> R ()
_ [] = R ()
token'forall
p_forallBndrsStart a -> R ()
p [GenLocated l a]
tyvars = do
  [SrcSpan] -> R () -> R ()
switchLayout (GenLocated l a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (GenLocated l a -> SrcSpan) -> [GenLocated l a] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated l a]
tyvars) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    R ()
token'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 () -> (GenLocated l a -> R ()) -> [GenLocated l a] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc (R () -> R ())
-> (GenLocated l a -> R ()) -> GenLocated l a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> R ()) -> GenLocated l a -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' a -> R ()
p) [GenLocated l a]
tyvars

p_forallBndrsEnd :: ForAllVisibility -> R ()
p_forallBndrsEnd :: ForAllVisibility -> R ()
p_forallBndrsEnd ForAllVisibility
ForAllInvis = Text -> R ()
txt Text
"." R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
p_forallBndrsEnd ForAllVisibility
ForAllVis = R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
token'rarrow

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. HasLoc 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 (LHsDoc GhcPs)
XConDeclField GhcPs
XRec GhcPs (HsType GhcPs)
cd_fld_ext :: XConDeclField GhcPs
cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_type :: XRec GhcPs (HsType GhcPs)
cd_fld_doc :: Maybe (LHsDoc GhcPs)
cd_fld_doc :: forall pass. ConDeclField pass -> Maybe (LHsDoc pass)
cd_fld_ext :: forall pass. ConDeclField pass -> XConDeclField pass
cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass
..} = do
  commaStyle <- (forall (f :: * -> *). PrinterOpts f -> f CommaStyle)
-> R CommaStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f CommaStyle
forall (f :: * -> *). PrinterOpts f -> f CommaStyle
poCommaStyle
  when (commaStyle == Trailing) $
    mapM_ (p_hsDoc Pipe (With #endNewline)) cd_fld_doc
  sitcc $
    sep
      commaDel
      (located' (p_rdrName . foLabel))
      cd_fld_names
  getPrinterOpt poFunctionArrows >>= \case
    FunctionArrowsStyle
LeadingArrows -> R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      R ()
breakpoint
      R ()
token'dcolon
      R ()
space
      HsType GhcPs -> R ()
p_hsType (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
cd_fld_type)
    FunctionArrowsStyle
TrailingArrows -> do
      R ()
space
      R ()
token'dcolon
      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)
XRec GhcPs (HsType GhcPs)
cd_fld_type)
    FunctionArrowsStyle
LeadingArgsArrows -> do
      R ()
space
      R ()
token'dcolon
      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)
XRec GhcPs (HsType GhcPs)
cd_fld_type)
  when (commaStyle == Leading) $
    mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) cd_fld_doc

p_lhsTypeArg :: LHsTypeArg GhcPs -> R ()
p_lhsTypeArg :: LHsTypeArg GhcPs -> R ()
p_lhsTypeArg = \case
  HsValArg NoExtField
XValArg GhcPs
NoExtField XRec GhcPs (HsType GhcPs)
ty -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType 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 XTypeArg GhcPs
_ XRec GhcPs (HsType GhcPs)
ty -> Text -> R ()
txt Text
"@" R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
ty HsType GhcPs -> R ()
p_hsType
  -- NOTE(amesgen) is this unreachable or just not implemented?
  HsArgPar XArgPar GhcPs
_ -> String -> R ()
forall a. String -> a
notImplemented String
"HsArgPar"

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

p_hsForAllTelescope ::
  Choice "multiline" ->
  HsForAllTelescope GhcPs ->
  R ()
p_hsForAllTelescope :: Choice "multiline" -> HsForAllTelescope GhcPs -> R ()
p_hsForAllTelescope Choice "multiline"
isMultiline HsForAllTelescope GhcPs
tele = do
  vis <-
    case HsForAllTelescope GhcPs
tele of
      HsForAllInvis XHsForAllInvis GhcPs
_ [LHsTyVarBndr Specificity GhcPs]
bndrs -> do
        (HsTyVarBndr Specificity GhcPs -> R ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> R ()
forall l a. HasLoc l => (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrsStart HsTyVarBndr Specificity GhcPs -> R ()
forall flag. IsTyVarBndrFlag flag => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
bndrs
        ForAllVisibility -> R ForAllVisibility
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForAllVisibility
ForAllInvis
      HsForAllVis XHsForAllVis GhcPs
_ [LHsTyVarBndr () GhcPs]
bndrs -> do
        (HsTyVarBndr () GhcPs -> R ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] -> R ()
forall l a. HasLoc l => (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrsStart HsTyVarBndr () GhcPs -> R ()
forall flag. IsTyVarBndrFlag flag => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
bndrs
        ForAllVisibility -> R ForAllVisibility
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForAllVisibility
ForAllVis

  getPrinterOpt poFunctionArrows >>= \case
    FunctionArrowsStyle
LeadingArrows | Choice "multiline" -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.isTrue Choice "multiline"
isMultiline -> do
      R ()
interArgBreak
      Text -> R ()
txt Text
" "
      ForAllVisibility -> R ()
p_forallBndrsEnd ForAllVisibility
vis
    FunctionArrowsStyle
_ -> do
      ForAllVisibility -> R ()
p_forallBndrsEnd ForAllVisibility
vis
      R ()
interArgBreak
  where
    interArgBreak :: R ()
interArgBreak = if Choice "multiline" -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.isTrue Choice "multiline"
isMultiline then R ()
newline else R ()
breakpoint

p_hsQualArrow :: Choice "multiline" -> R ()
p_hsQualArrow :: Choice "multiline" -> R ()
p_hsQualArrow Choice "multiline"
isMultiline =
  (forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle)
-> R FunctionArrowsStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f FunctionArrowsStyle
forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle
poFunctionArrows R FunctionArrowsStyle -> (FunctionArrowsStyle -> R ()) -> R ()
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FunctionArrowsStyle
LeadingArrows -> R ()
interArgBreak R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
token'darrow R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
    FunctionArrowsStyle
TrailingArrows -> R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
token'darrow R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
interArgBreak
    FunctionArrowsStyle
LeadingArgsArrows -> R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
token'darrow R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
interArgBreak
  where
    interArgBreak :: R ()
interArgBreak = if Choice "multiline" -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.isTrue Choice "multiline"
isMultiline then R ()
newline else R ()
breakpoint

p_hsFun ::
  (HasLoc l) =>
  Choice "multiline" ->
  (a -> R ()) ->
  HsArrowOf (GenLocated l a) GhcPs ->
  GenLocated l a ->
  R ()
p_hsFun :: forall l a.
HasLoc l =>
Choice "multiline"
-> (a -> R ())
-> HsArrowOf (GenLocated l a) GhcPs
-> GenLocated l a
-> R ()
p_hsFun Choice "multiline"
isMultiline a -> R ()
renderItem HsArrowOf (GenLocated l a) GhcPs
arrow GenLocated l a
rhsLoc =
  (forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle)
-> R FunctionArrowsStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f FunctionArrowsStyle
forall (f :: * -> *). PrinterOpts f -> f FunctionArrowsStyle
poFunctionArrows R FunctionArrowsStyle -> (FunctionArrowsStyle -> R ()) -> R ()
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FunctionArrowsStyle
LeadingArrows -> do
      R ()
interArgBreak
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
rhsLoc ((a -> R ()) -> R ()) -> (a -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \a
rhs -> do
        R ()
renderArrow
        R ()
space
        a -> R ()
renderItem a
rhs
    FunctionArrowsStyle
TrailingArrows -> do
      R ()
space
      R ()
renderArrow
      R ()
interArgBreak
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
rhsLoc ((a -> R ()) -> R ()) -> (a -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \a
rhs -> do
        a -> R ()
renderItem a
rhs
    FunctionArrowsStyle
LeadingArgsArrows -> do
      R ()
interArgBreak
      GenLocated l a -> (a -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated l a
rhsLoc ((a -> R ()) -> R ()) -> (a -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \a
rhs -> do
        R ()
renderArrow
        R ()
space
        a -> R ()
renderItem a
rhs
  where
    interArgBreak :: R ()
interArgBreak = if Choice "multiline" -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.isTrue Choice "multiline"
isMultiline then R ()
newline else R ()
breakpoint
    renderArrow :: R ()
renderArrow = (GenLocated l a -> R ())
-> HsArrowOf (GenLocated l a) GhcPs -> R ()
forall mult. (mult -> R ()) -> HsArrowOf mult GhcPs -> R ()
p_arrow ((a -> R ()) -> GenLocated l a -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' a -> R ()
renderItem) HsArrowOf (GenLocated l a) GhcPs
arrow

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

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

lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs
lhsTypeToSigType :: XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
lhsTypeToSigType XRec GhcPs (HsType GhcPs)
ty =
  SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsType GhcPs)
XRec GhcPs (HsType GhcPs)
ty) (HsSigType GhcPs -> LHsSigType GhcPs)
-> (XRec GhcPs (HsType GhcPs) -> HsSigType GhcPs)
-> XRec GhcPs (HsType GhcPs)
-> LHsSigType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsSig GhcPs
-> HsOuterSigTyVarBndrs GhcPs
-> XRec GhcPs (HsType 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) (XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsType GhcPs)
ty