{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.Data
( p_dataDecl,
)
where
import Control.Monad
import Data.Maybe (isJust, maybeToList)
import qualified Data.Text as Text
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.Config
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
p_dataDecl ::
FamilyStyle ->
Located RdrName ->
HsTyPats GhcPs ->
LexicalFixity ->
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"
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
Int
indent <- (forall (f :: * -> *). PrinterOpts f -> f Int) -> R Int
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Int
poIndentation
R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout (() -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (R () -> R ()) -> (Text -> R ()) -> Text -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.replicate (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Text
" "
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
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