{-# 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 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

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 {[LConDecl GhcPs]
HsDeriving GhcPs
Maybe (LHsContext GhcPs)
Maybe (XRec GhcPs (HsType GhcPs))
Maybe (XRec GhcPs CType)
NewOrData
XCHsDataDefn GhcPs
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_ND :: forall pass. HsDataDefn pass -> NewOrData
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 LHsDocString
Maybe (LHsContext GhcPs)
HsConDeclGADTDetails GhcPs
XConDeclGADT GhcPs
XRec GhcPs (HsType GhcPs)
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_doc :: Maybe LHsDocString
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 -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True) Maybe LHsDocString
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 -> [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
        R ()
space
        Text -> R ()
txt Text
"::"
        let interArgBreak :: R ()
interArgBreak =
              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
        R ()
interArgBreak
        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 ->
                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. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax)
                    (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
-> Maybe (LHsContext pass) -> LHsType pass -> HsType pass
HsQualTy NoExtField
NoExtField (forall a. a -> Maybe a
Just 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
        HsType GhcPs -> R ()
p_hsType (forall l e. GenLocated l e -> e
unLoc GenLocated (SrcAnn Any) (HsType GhcPs)
quantifiedTy)
  ConDeclH98 {Bool
[LHsTyVarBndr Specificity GhcPs]
Maybe LHsDocString
Maybe (LHsContext GhcPs)
XConDeclH98 GhcPs
LIdP GhcPs
HsConDeclH98Details GhcPs
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_doc :: Maybe LHsDocString
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 LHsDocString
..} -> do
    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
con_doc
    let conDeclWithContextSpn :: [SrcSpan]
conDeclWithContextSpn =
          [RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
real forall a. Maybe a
Nothing | AddEpAnn AnnKeywordId
AnnForall (EpaSpan RealSrcSpan
real) <- 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 a. ForAllVisibility -> (a -> R ()) -> [LocatedA 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)
XCHsDerivingClause GhcPs
LDerivClauseTys GhcPs
deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_ext :: forall pass. HsDerivingClause pass -> XCHsDerivingClause 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 SrcSpan
_ 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 LHsDocString
Maybe (LHsContext GhcPs)
XConDeclH98 GhcPs
LIdP GhcPs
HsConDeclH98Details GhcPs
con_doc :: Maybe LHsDocString
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_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
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 LHsDocString
..})] =
  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 LHsDocString
Maybe (LHsContext pass)
XConDeclH98 pass
LIdP pass
HsConDeclH98Details pass
con_doc :: Maybe LHsDocString
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_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
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 LHsDocString
..} = forall a. Maybe a -> Bool
isJust Maybe LHsDocString
con_doc
    f ConDecl pass
_ = Bool
False