{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Renedring of data type declarations.
module Ormolu.Printer.Meat.Declaration.Data
  ( p_dataDecl,
  )
where

import Control.Monad
import Data.Maybe (isJust, maybeToList)
import Data.Void
import qualified GHC.Data.Strict as Strict
import GHC.Hs
import GHC.Types.Fixity
import GHC.Types.ForeignCall
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
import Ormolu.Utils (matchAddEpAnn)

p_dataDecl ::
  -- | Whether to format as data family
  FamilyStyle ->
  -- | Type constructor
  LocatedN RdrName ->
  -- | Type patterns
  HsTyPats GhcPs ->
  -- | Lexical fixity
  LexicalFixity ->
  -- | Data definition
  HsDataDefn GhcPs ->
  R ()
p_dataDecl :: FamilyStyle
-> LocatedN RdrName
-> HsTyPats GhcPs
-> LexicalFixity
-> HsDataDefn GhcPs
-> R ()
p_dataDecl FamilyStyle
style LocatedN RdrName
name HsTyPats GhcPs
tpats LexicalFixity
fixity HsDataDefn {HsDeriving GhcPs
[LConDecl GhcPs]
Maybe (LHsContext GhcPs)
Maybe (XRec GhcPs (HsType GhcPs))
Maybe (XRec GhcPs CType)
NewOrData
XCHsDataDefn GhcPs
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs :: HsDeriving GhcPs
dd_cons :: [LConDecl GhcPs]
dd_kindSig :: Maybe (XRec GhcPs (HsType GhcPs))
dd_cType :: Maybe (XRec GhcPs CType)
dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ND :: NewOrData
dd_ext :: XCHsDataDefn GhcPs
..} = do
  Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case NewOrData
dd_ND of
    NewOrData
NewType -> Text
"newtype"
    NewOrData
DataType -> Text
"data"
  Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case FamilyStyle
style of
    FamilyStyle
Associated -> forall a. Monoid a => a
mempty
    FamilyStyle
Free -> Text
" instance"
  case forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (XRec GhcPs CType)
dd_cType of
    Maybe CType
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (CType SourceText
prag Maybe Header
header (SourceText
type_, FastString
_)) -> do
      SourceText -> R ()
p_sourceText SourceText
prag
      case Maybe Header
header of
        Maybe Header
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (Header SourceText
h FastString
_) -> R ()
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SourceText -> R ()
p_sourceText SourceText
h
      SourceText -> R ()
p_sourceText SourceText
type_
      Text -> R ()
txt Text
" #-}"
  let constructorSpans :: [SrcSpan]
constructorSpans = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN RdrName
name forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan HsTyPats GhcPs
tpats
      sigSpans :: [SrcSpan]
sigSpans = forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall a b. (a -> b) -> a -> b
$ Maybe (XRec GhcPs (HsType GhcPs))
dd_kindSig
      declHeaderSpans :: [SrcSpan]
declHeaderSpans = [SrcSpan]
constructorSpans forall a. [a] -> [a] -> [a]
++ [SrcSpan]
sigSpans
  [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
declHeaderSpans forall a b. (a -> b) -> a -> b
$ do
    R ()
breakpoint
    R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
      [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
constructorSpans forall a b. (a -> b) -> a -> b
$
        Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
          (LexicalFixity -> Bool
isInfix LexicalFixity
fixity)
          Bool
True
          (LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
name)
          (LHsTypeArg GhcPs -> R ()
p_lhsTypeArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTyPats GhcPs
tpats)
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (XRec GhcPs (HsType GhcPs))
dd_kindSig forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (HsType GhcPs)
k -> do
        R ()
space
        Text -> R ()
txt Text
"::"
        R ()
breakpoint
        R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
k HsType GhcPs -> R ()
p_hsType
  let gadt :: Bool
gadt = forall a. Maybe a -> Bool
isJust Maybe (XRec GhcPs (HsType GhcPs))
dd_kindSig Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ConDecl GhcPs -> Bool
isGadt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LConDecl GhcPs]
dd_cons
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LConDecl GhcPs]
dd_cons) forall a b. (a -> b) -> a -> b
$
    if Bool
gadt
      then R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
        [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
declHeaderSpans forall a b. (a -> b) -> a -> b
$ do
          R ()
breakpoint
          Text -> R ()
txt Text
"where"
        R ()
breakpoint
        forall a. (a -> R ()) -> [a] -> R ()
sepSemi (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' (Bool -> ConDecl GhcPs -> R ()
p_conDecl Bool
False)) [LConDecl GhcPs]
dd_cons
      else [SrcSpan] -> R () -> R ()
switchLayout (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN RdrName
name forall a. a -> [a] -> [a]
: (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LConDecl GhcPs]
dd_cons)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
        let singleConstRec :: Bool
singleConstRec = [LConDecl GhcPs] -> Bool
isSingleConstRec [LConDecl GhcPs]
dd_cons
        if [LConDecl GhcPs] -> Bool
hasHaddocks [LConDecl GhcPs]
dd_cons
          then R ()
newline
          else
            if Bool
singleConstRec
              then R ()
space
              else R ()
breakpoint
        R ()
equals
        R ()
space
        Layout
layout <- R Layout
getLayout
        let s :: R ()
s =
              if Layout
layout forall a. Eq a => a -> a -> Bool
== Layout
MultiLine Bool -> Bool -> Bool
|| [LConDecl GhcPs] -> Bool
hasHaddocks [LConDecl GhcPs]
dd_cons
                then R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"|" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
                else R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"|" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
            sitcc' :: R () -> R ()
sitcc' =
              if [LConDecl GhcPs] -> Bool
hasHaddocks [LConDecl GhcPs]
dd_cons Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
singleConstRec
                then R () -> R ()
sitcc
                else forall a. a -> a
id
        forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
s (R () -> R ()
sitcc' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' (Bool -> ConDecl GhcPs -> R ()
p_conDecl Bool
singleConstRec)) [LConDecl GhcPs]
dd_cons
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsDeriving GhcPs
dd_derivs) R ()
breakpoint
  R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsDerivingClause GhcPs -> R ()
p_hsDerivingClause) HsDeriving GhcPs
dd_derivs

p_conDecl ::
  Bool ->
  ConDecl GhcPs ->
  R ()
p_conDecl :: Bool -> ConDecl GhcPs -> R ()
p_conDecl Bool
singleConstRec = \case
  ConDeclGADT {[LIdP GhcPs]
Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
HsConDeclGADTDetails GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
XRec GhcPs (HsType GhcPs)
XConDeclGADT GhcPs
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_doc :: Maybe (LHsDoc GhcPs)
con_res_ty :: XRec GhcPs (HsType GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_names :: [LIdP GhcPs]
con_g_ext :: XConDeclGADT GhcPs
..} -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc HaddockStyle
Pipe Bool
True) Maybe (LHsDoc GhcPs)
con_doc
    let conDeclSpn :: [SrcSpan]
conDeclSpn =
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [LIdP GhcPs]
con_names
            forall a. Semigroup a => a -> a -> a
<> [forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs]
            forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA Maybe (LHsContext GhcPs)
con_mb_cxt)
            forall a. Semigroup a => a -> a -> a
<> [SrcSpan]
conArgsSpans
          where
            conArgsSpans :: [SrcSpan]
conArgsSpans = case HsConDeclGADTDetails GhcPs
con_g_args of
              PrefixConGADT [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs -> forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
hsScaledThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs
              RecConGADT XRec GhcPs [LConDeclField GhcPs]
x LHsUniToken "->" "\8594" GhcPs
_ -> [forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA XRec GhcPs [LConDeclField GhcPs]
x]
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
conDeclSpn forall a b. (a -> b) -> a -> b
$ do
      case [LIdP GhcPs]
con_names of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (LIdP GhcPs
c : [LIdP GhcPs]
cs) -> do
          LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
c
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LIdP GhcPs]
cs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
            R ()
commaDel
            forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel LocatedN RdrName -> R ()
p_rdrName [LIdP GhcPs]
cs
      R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
        let conTy :: GenLocated SrcSpanAnnA (HsType GhcPs)
conTy = case HsConDeclGADTDetails GhcPs
con_g_args of
              PrefixConGADT [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs ->
                let go :: HsScaled pass (GenLocated (SrcSpanAnn' a1) (HsType pass))
-> GenLocated (SrcSpanAnn' a1) (HsType pass)
-> GenLocated (SrcAnn ann) (HsType pass)
go (HsScaled HsArrow pass
a GenLocated (SrcSpanAnn' a1) (HsType pass)
b) GenLocated (SrcSpanAnn' a1) (HsType pass)
t = forall a1 e1 a2 e2 e3 ann.
GenLocated (SrcSpanAnn' a1) e1
-> GenLocated (SrcSpanAnn' a2) e2
-> e3
-> GenLocated (SrcAnn ann) e3
addCLocAA GenLocated (SrcSpanAnn' a1) (HsType pass)
t GenLocated (SrcSpanAnn' a1) (HsType pass)
b (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall ann. EpAnn ann
EpAnnNotUsed HsArrow pass
a GenLocated (SrcSpanAnn' a1) (HsType pass)
b GenLocated (SrcSpanAnn' a1) (HsType pass)
t)
                 in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {pass} {ann} {a1} {ann}.
(XFunTy pass ~ EpAnn ann,
 XRec pass (HsType pass)
 ~ GenLocated (SrcSpanAnn' a1) (HsType pass)) =>
HsScaled pass (GenLocated (SrcSpanAnn' a1) (HsType pass))
-> GenLocated (SrcSpanAnn' a1) (HsType pass)
-> GenLocated (SrcAnn ann) (HsType pass)
go XRec GhcPs (HsType GhcPs)
con_res_ty [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs
              RecConGADT XRec GhcPs [LConDeclField GhcPs]
r LHsUniToken "->" "\8594" GhcPs
_ ->
                forall a1 e1 a2 e2 e3 ann.
GenLocated (SrcSpanAnn' a1) e1
-> GenLocated (SrcSpanAnn' a2) e2
-> e3
-> GenLocated (SrcAnn ann) e3
addCLocAA XRec GhcPs [LConDeclField GhcPs]
r XRec GhcPs (HsType GhcPs)
con_res_ty forall a b. (a -> b) -> a -> b
$
                  forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy
                    forall ann. EpAnn ann
EpAnnNotUsed
                    (forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok)
                    (forall ann1 a2 ann2. LocatedAn ann1 a2 -> LocatedAn ann2 a2
la2la forall a b. (a -> b) -> a -> b
$ forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy forall ann. EpAnn ann
EpAnnNotUsed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XRec GhcPs [LConDeclField GhcPs]
r)
                    XRec GhcPs (HsType GhcPs)
con_res_ty
            qualTy :: GenLocated SrcSpanAnnA (HsType GhcPs)
qualTy = case Maybe (LHsContext GhcPs)
con_mb_cxt of
              Maybe (LHsContext GhcPs)
Nothing -> GenLocated SrcSpanAnnA (HsType GhcPs)
conTy
              Just LHsContext GhcPs
qs ->
                forall a1 e1 a2 e2 e3 ann.
GenLocated (SrcSpanAnn' a1) e1
-> GenLocated (SrcSpanAnn' a2) e2
-> e3
-> GenLocated (SrcAnn ann) e3
addCLocAA LHsContext GhcPs
qs GenLocated SrcSpanAnnA (HsType GhcPs)
conTy forall a b. (a -> b) -> a -> b
$
                  forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
NoExtField LHsContext GhcPs
qs GenLocated SrcSpanAnnA (HsType GhcPs)
conTy
            quantifiedTy :: GenLocated (SrcAnn Any) (HsType GhcPs)
quantifiedTy =
              forall a1 e1 a2 e2 e3 ann.
GenLocated (SrcSpanAnn' a1) e1
-> GenLocated (SrcSpanAnn' a2) e2
-> e3
-> GenLocated (SrcAnn ann) e3
addCLocAA XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs GenLocated SrcSpanAnnA (HsType GhcPs)
qualTy forall a b. (a -> b) -> a -> b
$
                HsOuterSigTyVarBndrs GhcPs
-> XRec GhcPs (HsType GhcPs) -> HsType GhcPs
hsOuterTyVarBndrsToHsType (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs) GenLocated SrcSpanAnnA (HsType GhcPs)
qualTy
        R ()
space
        Text -> R ()
txt Text
"::"
        if HsType GhcPs -> Bool
hasDocStrings (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsType GhcPs)
con_res_ty)
          then R ()
newline
          else R ()
breakpoint
        forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated (SrcAnn Any) (HsType GhcPs)
quantifiedTy HsType GhcPs -> R ()
p_hsType
  ConDeclH98 {Bool
[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
HsConDeclH98Details GhcPs
LIdP GhcPs
XConDeclH98 GhcPs
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_doc :: Maybe (LHsDoc GhcPs)
con_args :: HsConDeclH98Details GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_forall :: Bool
con_name :: LIdP GhcPs
con_ext :: XConDeclH98 GhcPs
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
..} -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc HaddockStyle
Pipe Bool
True) Maybe (LHsDoc GhcPs)
con_doc
    let conDeclWithContextSpn :: [SrcSpan]
conDeclWithContextSpn =
          [ RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
real forall a. Maybe a
Strict.Nothing
            | Just (EpaSpan RealSrcSpan
real) <- AnnKeywordId -> AddEpAnn -> Maybe EpaLocation
matchAddEpAnn AnnKeywordId
AnnForall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpAnn [AddEpAnn] -> [AddEpAnn]
epAnnAnns XConDeclH98 GhcPs
con_ext
          ]
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs
            forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA Maybe (LHsContext GhcPs)
con_mb_cxt)
            forall a. Semigroup a => a -> a -> a
<> [SrcSpan]
conDeclSpn
        conDeclSpn :: [SrcSpan]
conDeclSpn = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
con_name forall a. a -> [a] -> [a]
: [SrcSpan]
conArgsSpans
          where
            conArgsSpans :: [SrcSpan]
conArgsSpans = case HsConDeclH98Details GhcPs
con_args of
              PrefixCon [] [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs -> forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
hsScaledThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs
              PrefixCon (Void
v : [Void]
_) [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
_ -> forall a. Void -> a
absurd Void
v
              RecCon XRec GhcPs [LConDeclField GhcPs]
l -> [forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA XRec GhcPs [LConDeclField GhcPs]
l]
              InfixCon HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
x HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
y -> forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
hsScaledThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
x, HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
y]
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
conDeclWithContextSpn forall a b. (a -> b) -> a -> b
$ do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
con_forall forall a b. (a -> b) -> a -> b
$ do
        forall l a.
HasSrcSpan l =>
ForAllVisibility -> (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs
        R ()
breakpoint
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LHsContext GhcPs)
con_mb_cxt LHsContext GhcPs -> R ()
p_lhsContext
      [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
conDeclSpn forall a b. (a -> b) -> a -> b
$ case HsConDeclH98Details GhcPs
con_args of
        PrefixCon [] [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs -> do
          LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
con_name
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs) R ()
breakpoint
          R () -> R ()
inci forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsType GhcPs -> R ()
p_hsTypePostDoc) (forall pass a. HsScaled pass a -> a
hsScaledThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
xs)
        PrefixCon (Void
v : [Void]
_) [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
_ -> forall a. Void -> a
absurd Void
v
        RecCon XRec GhcPs [LConDeclField GhcPs]
l -> do
          LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
con_name
          R ()
breakpoint
          Bool -> R () -> R ()
inciIf (Bool -> Bool
not Bool
singleConstRec) (forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs [LConDeclField GhcPs]
l [LConDeclField GhcPs] -> R ()
p_conDeclFields)
        InfixCon (HsScaled HsArrow GhcPs
_ XRec GhcPs (HsType GhcPs)
x) (HsScaled HsArrow GhcPs
_ XRec GhcPs (HsType GhcPs)
y) -> do
          forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs (HsType GhcPs)
x HsType GhcPs -> R ()
p_hsType
          R ()
breakpoint
          R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
            LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
con_name
            R ()
space
            forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs (HsType GhcPs)
y HsType GhcPs -> R ()
p_hsType

p_lhsContext ::
  LHsContext GhcPs ->
  R ()
p_lhsContext :: LHsContext GhcPs -> R ()
p_lhsContext = \case
  L SrcSpanAnnC
_ [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LHsContext GhcPs
ctx -> do
    forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsContext GhcPs
ctx HsContext GhcPs -> R ()
p_hsContext
    R ()
space
    Text -> R ()
txt Text
"=>"
    R ()
breakpoint

isGadt :: ConDecl GhcPs -> Bool
isGadt :: ConDecl GhcPs -> Bool
isGadt = \case
  ConDeclGADT {} -> Bool
True
  ConDeclH98 {} -> Bool
False

p_hsDerivingClause ::
  HsDerivingClause GhcPs ->
  R ()
p_hsDerivingClause :: HsDerivingClause GhcPs -> R ()
p_hsDerivingClause HsDerivingClause {Maybe (LDerivStrategy GhcPs)
LDerivClauseTys GhcPs
XCHsDerivingClause GhcPs
deriv_clause_ext :: forall pass. HsDerivingClause pass -> XCHsDerivingClause pass
deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys :: LDerivClauseTys GhcPs
deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_ext :: XCHsDerivingClause GhcPs
..} = do
  Text -> R ()
txt Text
"deriving"
  let derivingWhat :: R ()
derivingWhat = forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LDerivClauseTys GhcPs
deriv_clause_tys forall a b. (a -> b) -> a -> b
$ \case
        DctSingle NoExtField
XDctSingle GhcPs
NoExtField LHsSigType GhcPs
sigTy -> BracketStyle -> R () -> R ()
parens BracketStyle
N forall a b. (a -> b) -> a -> b
$ forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsSigType GhcPs
sigTy HsSigType GhcPs -> R ()
p_hsSigType
        DctMulti NoExtField
XDctMulti GhcPs
NoExtField [LHsSigType GhcPs]
sigTys ->
          BracketStyle -> R () -> R ()
parens BracketStyle
N forall a b. (a -> b) -> a -> b
$
            forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
              R ()
commaDel
              (R () -> R ()
sitcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsSigType GhcPs -> R ()
p_hsSigType)
              [LHsSigType GhcPs]
sigTys
  R ()
space
  case Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy of
    Maybe (LDerivStrategy GhcPs)
Nothing -> do
      R ()
breakpoint
      R () -> R ()
inci R ()
derivingWhat
    Just (L SrcAnn NoEpAnns
_ DerivStrategy GhcPs
a) -> case DerivStrategy GhcPs
a of
      StockStrategy XStockStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"stock"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      AnyclassStrategy XAnyClassStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"anyclass"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      NewtypeStrategy XNewtypeStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"newtype"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      ViaStrategy (XViaStrategyPs EpAnn [AddEpAnn]
_ LHsSigType GhcPs
sigTy) -> do
        R ()
breakpoint
        R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
          R ()
derivingWhat
          R ()
breakpoint
          Text -> R ()
txt Text
"via"
          R ()
space
          forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsSigType GhcPs
sigTy HsSigType GhcPs -> R ()
p_hsSigType

----------------------------------------------------------------------------
-- Helpers

isInfix :: LexicalFixity -> Bool
isInfix :: LexicalFixity -> Bool
isInfix = \case
  LexicalFixity
Infix -> Bool
True
  LexicalFixity
Prefix -> Bool
False

isSingleConstRec :: [LConDecl GhcPs] -> Bool
isSingleConstRec :: [LConDecl GhcPs] -> Bool
isSingleConstRec [(L SrcSpanAnnA
_ ConDeclH98 {Bool
[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
HsConDeclH98Details GhcPs
LIdP GhcPs
XConDeclH98 GhcPs
con_doc :: Maybe (LHsDoc GhcPs)
con_args :: HsConDeclH98Details GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_forall :: Bool
con_name :: LIdP GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
..})] =
  case HsConDeclH98Details GhcPs
con_args of
    RecCon XRec GhcPs [LConDeclField GhcPs]
_ -> Bool
True
    HsConDeclH98Details GhcPs
_ -> Bool
False
isSingleConstRec [LConDecl GhcPs]
_ = Bool
False

hasHaddocks :: [LConDecl GhcPs] -> Bool
hasHaddocks :: [LConDecl GhcPs] -> Bool
hasHaddocks = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall pass. ConDecl pass -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
  where
    f :: ConDecl pass -> Bool
f ConDeclH98 {Bool
[LHsTyVarBndr Specificity pass]
Maybe (LHsContext pass)
Maybe (LHsDoc pass)
HsConDeclH98Details pass
LIdP pass
XConDeclH98 pass
con_doc :: Maybe (LHsDoc pass)
con_args :: HsConDeclH98Details pass
con_mb_cxt :: Maybe (LHsContext pass)
con_ex_tvs :: [LHsTyVarBndr Specificity pass]
con_forall :: Bool
con_name :: LIdP pass
con_ext :: XConDeclH98 pass
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
..} = forall a. Maybe a -> Bool
isJust Maybe (LHsDoc pass)
con_doc
    f ConDecl pass
_ = Bool
False