{-# 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 GHC.Hs.Decls
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Parser.Annotation
import GHC.Types.Basic
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

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

p_conDecl ::
  Bool ->
  ConDecl GhcPs ->
  R ()
p_conDecl :: Bool -> ConDecl GhcPs -> R ()
p_conDecl Bool
singleConstRec = \case
  ConDeclGADT {[LHsTyVarBndr Specificity GhcPs]
[Located (IdP GhcPs)]
Maybe (LHsContext GhcPs)
Maybe LHsDocString
HsConDeclDetails GhcPs
XConDeclGADT GhcPs
Located Bool
LHsKind GhcPs
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_forall :: forall pass. ConDecl pass -> Located Bool
con_qvars :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_doc :: Maybe LHsDocString
con_res_ty :: LHsKind GhcPs
con_args :: HsConDeclDetails GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_qvars :: [LHsTyVarBndr Specificity GhcPs]
con_forall :: Located Bool
con_names :: [Located (IdP GhcPs)]
con_g_ext :: XConDeclGADT GhcPs
..} -> do
    (LHsDocString -> R ()) -> Maybe LHsDocString -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True) Maybe LHsDocString
con_doc
    let conDeclSpn :: [SrcSpan]
conDeclSpn =
          (Located RdrName -> SrcSpan) -> [Located RdrName] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [Located (IdP GhcPs)]
[Located RdrName]
con_names
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> [Located Bool -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Bool
con_forall]
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> (LHsTyVarBndr Specificity GhcPs -> SrcSpan)
-> [LHsTyVarBndr Specificity GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsTyVarBndr Specificity GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [LHsTyVarBndr Specificity GhcPs]
con_qvars
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> Maybe SrcSpan -> [SrcSpan]
forall a. Maybe a -> [a]
maybeToList ((LHsContext GhcPs -> SrcSpan)
-> Maybe (LHsContext GhcPs) -> Maybe SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsContext GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Maybe (LHsContext GhcPs)
con_mb_cxt)
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> HsConDeclDetails GhcPs -> [SrcSpan]
conArgsSpans HsConDeclDetails GhcPs
con_args
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
conDeclSpn (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      case [Located (IdP GhcPs)]
con_names of
        [] -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Located (IdP GhcPs)
c : [Located (IdP GhcPs)]
cs) -> do
          Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
c
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Located RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (IdP GhcPs)]
[Located RdrName]
cs) (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
$ do
            R ()
commaDel
            R () -> (Located RdrName -> R ()) -> [Located RdrName] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel Located RdrName -> R ()
p_rdrName [Located (IdP GhcPs)]
[Located RdrName]
cs
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R ()
space
        Text -> R ()
txt Text
"::"
        let interArgBreak :: R ()
interArgBreak =
              if HsKind GhcPs -> Bool
hasDocStrings (LHsKind GhcPs -> HsKind GhcPs
forall l e. GenLocated l e -> e
unLoc LHsKind GhcPs
con_res_ty)
                then R ()
newline
                else R ()
breakpoint
        R ()
interArgBreak
        LHsKind GhcPs
conTy <- case HsConDeclDetails GhcPs
con_args of
          PrefixCon [HsScaled GhcPs (LHsKind GhcPs)]
xs ->
            let go :: HsScaled pass (Located (HsType pass))
-> Located (HsType pass) -> Located (HsType pass)
go (HsScaled HsArrow pass
a Located (HsType pass)
b) Located (HsType pass)
t = SrcSpan -> HsType pass -> Located (HsType pass)
forall l e. l -> e -> GenLocated l e
L (Located (HsType pass) -> Located (HsType pass) -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located (HsType pass)
t Located (HsType pass)
b) (XFunTy pass
-> HsArrow pass
-> Located (HsType pass)
-> Located (HsType pass)
-> HsType pass
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy pass
NoExtField HsArrow pass
a Located (HsType pass)
b Located (HsType pass)
t)
             in LHsKind GhcPs -> R (LHsKind GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsKind GhcPs -> R (LHsKind GhcPs))
-> LHsKind GhcPs -> R (LHsKind GhcPs)
forall a b. (a -> b) -> a -> b
$ (HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs -> LHsKind GhcPs)
-> LHsKind GhcPs
-> [HsScaled GhcPs (LHsKind GhcPs)]
-> LHsKind GhcPs
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs -> LHsKind GhcPs
forall pass.
(XFunTy pass ~ NoExtField) =>
HsScaled pass (Located (HsType pass))
-> Located (HsType pass) -> Located (HsType pass)
go LHsKind GhcPs
con_res_ty [HsScaled GhcPs (LHsKind GhcPs)]
xs
          RecCon r :: Located [LConDeclField GhcPs]
r@(L SrcSpan
l [LConDeclField GhcPs]
rs) ->
            LHsKind GhcPs -> R (LHsKind GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (LHsKind GhcPs -> R (LHsKind GhcPs))
-> (HsKind GhcPs -> LHsKind GhcPs)
-> HsKind GhcPs
-> R (LHsKind GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsKind GhcPs -> LHsKind GhcPs
forall l e. l -> e -> GenLocated l e
L (Located [LConDeclField GhcPs] -> LHsKind GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located [LConDeclField GhcPs]
r LHsKind GhcPs
con_res_ty)
              (HsKind GhcPs -> R (LHsKind GhcPs))
-> HsKind GhcPs -> R (LHsKind GhcPs)
forall a b. (a -> b) -> a -> b
$ XFunTy GhcPs
-> HsArrow GhcPs -> LHsKind GhcPs -> LHsKind GhcPs -> HsKind GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy
                NoExtField
XFunTy GhcPs
NoExtField
                (IsUnicodeSyntax -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax)
                (SrcSpan -> HsKind GhcPs -> LHsKind GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsKind GhcPs -> LHsKind GhcPs) -> HsKind GhcPs -> LHsKind GhcPs
forall a b. (a -> b) -> a -> b
$ XRecTy GhcPs -> [LConDeclField GhcPs] -> HsKind GhcPs
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy NoExtField
XRecTy GhcPs
NoExtField [LConDeclField GhcPs]
rs)
                LHsKind GhcPs
con_res_ty
          InfixCon HsScaled GhcPs (LHsKind GhcPs)
_ HsScaled GhcPs (LHsKind GhcPs)
_ -> String -> R (LHsKind GhcPs)
forall a. String -> a
notImplemented String
"InfixCon" -- NOTE(amesgen) should be unreachable
        let qualTy :: LHsKind GhcPs
qualTy = case Maybe (LHsContext GhcPs)
con_mb_cxt of
              Maybe (LHsContext GhcPs)
Nothing -> LHsKind GhcPs
conTy
              Just LHsContext GhcPs
qs ->
                SrcSpan -> HsKind GhcPs -> LHsKind GhcPs
forall l e. l -> e -> GenLocated l e
L (LHsContext GhcPs -> LHsKind GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs LHsContext GhcPs
qs LHsKind GhcPs
conTy) (HsKind GhcPs -> LHsKind GhcPs) -> HsKind GhcPs -> LHsKind GhcPs
forall a b. (a -> b) -> a -> b
$
                  XQualTy GhcPs -> LHsContext GhcPs -> LHsKind GhcPs -> HsKind GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
NoExtField LHsContext GhcPs
qs LHsKind GhcPs
conTy
        let quantifiedTy :: LHsKind GhcPs
quantifiedTy =
              if Located Bool -> Bool
forall l e. GenLocated l e -> e
unLoc Located Bool
con_forall
                then
                  SrcSpan -> HsKind GhcPs -> LHsKind GhcPs
forall l e. l -> e -> GenLocated l e
L (Located Bool -> LHsKind GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located Bool
con_forall LHsKind GhcPs
qualTy) (HsKind GhcPs -> LHsKind GhcPs) -> HsKind GhcPs -> LHsKind GhcPs
forall a b. (a -> b) -> a -> b
$
                    XForAllTy GhcPs
-> HsForAllTelescope GhcPs -> LHsKind GhcPs -> HsKind GhcPs
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy NoExtField
XForAllTy GhcPs
NoExtField ([LHsTyVarBndr Specificity GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
[LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele [LHsTyVarBndr Specificity GhcPs]
con_qvars) LHsKind GhcPs
qualTy
                else LHsKind GhcPs
qualTy
        HsKind GhcPs -> R ()
p_hsType (LHsKind GhcPs -> HsKind GhcPs
forall l e. GenLocated l e -> e
unLoc LHsKind GhcPs
quantifiedTy)
  ConDeclH98 {[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
Maybe LHsDocString
HsConDeclDetails GhcPs
XConDeclH98 GhcPs
Located Bool
Located (IdP GhcPs)
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_doc :: Maybe LHsDocString
con_args :: HsConDeclDetails GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_forall :: Located Bool
con_name :: Located (IdP GhcPs)
con_ext :: XConDeclH98 GhcPs
con_forall :: forall pass. ConDecl pass -> Located Bool
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
..} -> do
    (LHsDocString -> R ()) -> Maybe LHsDocString -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True) Maybe LHsDocString
con_doc
    let conDeclWithContextSpn :: [SrcSpan]
conDeclWithContextSpn =
          [Located Bool -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Bool
con_forall]
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> (LHsTyVarBndr Specificity GhcPs -> SrcSpan)
-> [LHsTyVarBndr Specificity GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsTyVarBndr Specificity GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> Maybe SrcSpan -> [SrcSpan]
forall a. Maybe a -> [a]
maybeToList ((LHsContext GhcPs -> SrcSpan)
-> Maybe (LHsContext GhcPs) -> Maybe SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsContext GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Maybe (LHsContext GhcPs)
con_mb_cxt)
            [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> [SrcSpan]
conDeclSpn
        conDeclSpn :: [SrcSpan]
conDeclSpn =
          Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (IdP GhcPs)
Located RdrName
con_name SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: HsConDeclDetails GhcPs -> [SrcSpan]
conArgsSpans HsConDeclDetails GhcPs
con_args
    [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
conDeclWithContextSpn (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Located Bool -> Bool
forall l e. GenLocated l e -> e
unLoc Located Bool
con_forall) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        ForAllVisibility
-> (HsTyVarBndr Specificity GhcPs -> R ())
-> [LHsTyVarBndr Specificity GhcPs]
-> R ()
forall a.
Data a =>
ForAllVisibility -> (a -> R ()) -> [Located a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr Specificity GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs
        R ()
breakpoint
      Maybe (LHsContext GhcPs) -> (LHsContext GhcPs -> R ()) -> R ()
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 (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ case HsConDeclDetails GhcPs
con_args of
        PrefixCon [HsScaled GhcPs (LHsKind GhcPs)]
xs -> do
          Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
con_name
          Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([HsScaled GhcPs (LHsKind GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsScaled GhcPs (LHsKind GhcPs)]
xs) R ()
breakpoint
          R () -> R ()
inci (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
$ R () -> (LHsKind GhcPs -> R ()) -> [LHsKind GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc (R () -> R ()) -> (LHsKind GhcPs -> R ()) -> LHsKind GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsKind GhcPs -> R ()) -> LHsKind GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' HsKind GhcPs -> R ()
p_hsTypePostDoc) (HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs
forall pass a. HsScaled pass a -> a
hsScaledThing (HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs)
-> [HsScaled GhcPs (LHsKind GhcPs)] -> [LHsKind GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (LHsKind GhcPs)]
xs)
        RecCon Located [LConDeclField GhcPs]
l -> do
          Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
con_name
          R ()
breakpoint
          Bool -> R () -> R ()
inciIf (Bool -> Bool
not Bool
singleConstRec) (Located [LConDeclField GhcPs]
-> ([LConDeclField GhcPs] -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located [LConDeclField GhcPs]
l [LConDeclField GhcPs] -> R ()
p_conDeclFields)
        InfixCon (HsScaled HsArrow GhcPs
_ LHsKind GhcPs
x) (HsScaled HsArrow GhcPs
_ LHsKind GhcPs
y) -> do
          LHsKind GhcPs -> (HsKind GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsKind GhcPs
x HsKind GhcPs -> R ()
p_hsType
          R ()
breakpoint
          R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
            Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
con_name
            R ()
space
            LHsKind GhcPs -> (HsKind GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsKind GhcPs
y HsKind GhcPs -> R ()
p_hsType

conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
conArgsSpans = \case
  PrefixCon [HsScaled GhcPs (LHsKind GhcPs)]
xs ->
    LHsKind GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsKind GhcPs -> SrcSpan)
-> (HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs)
-> HsScaled GhcPs (LHsKind GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs
forall pass a. HsScaled pass a -> a
hsScaledThing (HsScaled GhcPs (LHsKind GhcPs) -> SrcSpan)
-> [HsScaled GhcPs (LHsKind GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (LHsKind GhcPs)]
xs
  RecCon Located [LConDeclField GhcPs]
l ->
    [Located [LConDeclField GhcPs] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [LConDeclField GhcPs]
l]
  InfixCon HsScaled GhcPs (LHsKind GhcPs)
x HsScaled GhcPs (LHsKind GhcPs)
y ->
    LHsKind GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsKind GhcPs -> SrcSpan)
-> (HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs)
-> HsScaled GhcPs (LHsKind GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsScaled GhcPs (LHsKind GhcPs) -> LHsKind GhcPs
forall pass a. HsScaled pass a -> a
hsScaledThing (HsScaled GhcPs (LHsKind GhcPs) -> SrcSpan)
-> [HsScaled GhcPs (LHsKind GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (LHsKind GhcPs)
x, HsScaled GhcPs (LHsKind GhcPs)
y]

p_lhsContext ::
  LHsContext GhcPs ->
  R ()
p_lhsContext :: LHsContext GhcPs -> R ()
p_lhsContext = \case
  L SrcSpan
_ [] -> () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LHsContext GhcPs
ctx -> do
    LHsContext GhcPs -> ([LHsKind GhcPs] -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsContext GhcPs
ctx [LHsKind 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
Located [LHsSigType 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 -> Located [LHsSigType pass]
deriv_clause_tys :: Located [LHsSigType GhcPs]
deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_ext :: XCHsDerivingClause GhcPs
..} = do
  Text -> R ()
txt Text
"deriving"
  let derivingWhat :: R ()
derivingWhat = Located [LHsSigType GhcPs] -> ([LHsSigType GhcPs] -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located [LHsSigType GhcPs]
deriv_clause_tys (([LHsSigType GhcPs] -> R ()) -> R ())
-> ([LHsSigType GhcPs] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \case
        [] -> Text -> R ()
txt Text
"()"
        [LHsSigType GhcPs]
xs ->
          BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
            R () -> (LHsSigType GhcPs -> R ()) -> [LHsSigType GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
              R ()
commaDel
              (R () -> R ()
sitcc (R () -> R ())
-> (LHsSigType GhcPs -> R ()) -> LHsSigType GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsKind GhcPs -> R ()) -> LHsKind GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' HsKind GhcPs -> R ()
p_hsType (LHsKind GhcPs -> R ())
-> (LHsSigType GhcPs -> LHsKind GhcPs) -> LHsSigType GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsSigType GhcPs -> LHsKind GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body)
              [LHsSigType GhcPs]
xs
  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
      DerivStrategy GhcPs
StockStrategy -> do
        Text -> R ()
txt Text
"stock"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      DerivStrategy GhcPs
AnyclassStrategy -> do
        Text -> R ()
txt Text
"anyclass"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      DerivStrategy GhcPs
NewtypeStrategy -> do
        Text -> R ()
txt Text
"newtype"
        R ()
breakpoint
        R () -> R ()
inci R ()
derivingWhat
      ViaStrategy HsIB {..} -> do
        R ()
breakpoint
        R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          R ()
derivingWhat
          R ()
breakpoint
          Text -> R ()
txt Text
"via"
          R ()
space
          LHsKind GhcPs -> (HsKind GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsKind GhcPs
hsib_body HsKind GhcPs -> R ()
p_hsType

----------------------------------------------------------------------------
-- 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 SrcSpan
_ ConDeclH98 {[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
Maybe LHsDocString
HsConDeclDetails GhcPs
XConDeclH98 GhcPs
Located Bool
Located (IdP GhcPs)
con_doc :: Maybe LHsDocString
con_args :: HsConDeclDetails GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_forall :: Located Bool
con_name :: Located (IdP GhcPs)
con_ext :: XConDeclH98 GhcPs
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_forall :: forall pass. ConDecl pass -> Located Bool
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
..})] =
  case HsConDeclDetails GhcPs
con_args of
    RecCon Located [LConDeclField GhcPs]
_ -> Bool
True
    HsConDeclDetails GhcPs
_ -> Bool
False
isSingleConstRec [LConDecl GhcPs]
_ = Bool
False

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