{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.TypeFamily
( p_famDecl,
p_tyFamInstEqn,
)
where
import Control.Monad
import Data.Maybe (isNothing)
import GHC.Hs
import GHC.Types.Fixity
import GHC.Types.SrcLoc
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
p_famDecl FamilyStyle
style FamilyDecl {fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = HsQTvs {[LHsTyVarBndr () GhcPs]
XHsQTvs GhcPs
hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit :: [LHsTyVarBndr () GhcPs]
hsq_ext :: XHsQTvs GhcPs
..}, Maybe (LInjectivityAnn GhcPs)
FamilyInfo GhcPs
LFamilyResultSig GhcPs
LIdP GhcPs
XCFamilyDecl GhcPs
TopLevelFlag
LexicalFixity
fdExt :: forall pass. FamilyDecl pass -> XCFamilyDecl pass
fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdTopLevel :: forall pass. FamilyDecl pass -> TopLevelFlag
fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdFixity :: forall pass. FamilyDecl pass -> LexicalFixity
fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdResultSig :: LFamilyResultSig GhcPs
fdFixity :: LexicalFixity
fdLName :: LIdP GhcPs
fdTopLevel :: TopLevelFlag
fdInfo :: FamilyInfo GhcPs
fdExt :: XCFamilyDecl GhcPs
..} = do
Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
mmeqs <- case FamilyInfo GhcPs
fdInfo of
FamilyInfo GhcPs
DataFamily -> Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
forall a. Maybe a
Nothing Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
-> R ()
-> R (Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"data"
FamilyInfo GhcPs
OpenTypeFamily -> Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
forall a. Maybe a
Nothing Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
-> R ()
-> R (Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"type"
ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
eqs -> Maybe
[GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
-> Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
forall a. a -> Maybe a
Just Maybe [LTyFamInstEqn GhcPs]
Maybe
[GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqs Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
-> R ()
-> R (Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"type"
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
" family"
let headerSpns :: [SrcSpan]
headerSpns = GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
fdLName SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
hsq_explicit)
headerAndSigSpns :: [SrcSpan]
headerAndSigSpns = GenLocated SrcSpan (FamilyResultSig GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LFamilyResultSig GhcPs
GenLocated SrcSpan (FamilyResultSig GhcPs)
fdResultSig SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
headerSpns
R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
headerAndSigSpns (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
[SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
headerSpns (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
(LexicalFixity -> Bool
isInfix LexicalFixity
fdFixity)
Bool
True
(GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> R ()
p_rdrName LIdP GhcPs
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
fdLName)
((HsTyVarBndr () GhcPs -> R ())
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
hsq_explicit)
let resultSig :: Maybe (R ())
resultSig = GenLocated SrcSpan (FamilyResultSig GhcPs) -> Maybe (R ())
p_familyResultSigL LFamilyResultSig GhcPs
GenLocated SrcSpan (FamilyResultSig GhcPs)
fdResultSig
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (R ()) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (R ())
resultSig Bool -> Bool -> Bool
&& Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (LInjectivityAnn GhcPs)
Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
fdInjectivityAnn) R ()
space
R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Maybe (R ())
resultSig
R ()
space
Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
-> (GenLocated SrcSpan (InjectivityAnn GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LInjectivityAnn GhcPs)
Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
fdInjectivityAnn ((InjectivityAnn GhcPs -> R ())
-> GenLocated SrcSpan (InjectivityAnn GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' InjectivityAnn GhcPs -> R ()
p_injectivityAnn)
case Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
mmeqs of
Maybe
(Maybe
[GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Maybe
[GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
meqs -> do
R () -> R ()
inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
headerAndSigSpns (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
Text -> R ()
txt Text
"where"
case Maybe
[GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
meqs of
Maybe
[GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
Nothing -> do
R ()
space
Text -> R ()
txt Text
".."
Just [GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqs -> do
R ()
newline
R ()
-> (GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> R ())
-> [GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline ((FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> R ())
-> GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' (R () -> R ()
inci (R () -> R ())
-> (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> R ())
-> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyFamInstEqn GhcPs -> R ()
FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> R ()
p_tyFamInstEqn)) [GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqs
p_familyResultSigL ::
Located (FamilyResultSig GhcPs) ->
Maybe (R ())
p_familyResultSigL :: GenLocated SrcSpan (FamilyResultSig GhcPs) -> Maybe (R ())
p_familyResultSigL (L SrcSpan
_ FamilyResultSig GhcPs
a) = case FamilyResultSig GhcPs
a of
NoSig XNoSig GhcPs
NoExtField -> Maybe (R ())
forall a. Maybe a
Nothing
KindSig XCKindSig GhcPs
NoExtField LHsKind GhcPs
k -> R () -> Maybe (R ())
forall a. a -> Maybe a
Just (R () -> Maybe (R ())) -> R () -> Maybe (R ())
forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt Text
"::"
R ()
breakpoint
GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsKind GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
k HsType GhcPs -> R ()
p_hsType
TyVarSig XTyVarSig GhcPs
NoExtField LHsTyVarBndr () GhcPs
bndr -> R () -> Maybe (R ())
forall a. a -> Maybe a
Just (R () -> Maybe (R ())) -> R () -> Maybe (R ())
forall a b. (a -> b) -> a -> b
$ do
R ()
equals
R ()
breakpoint
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> (HsTyVarBndr () GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsTyVarBndr () GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
bndr HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr
p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
p_injectivityAnn (InjectivityAnn XCInjectivityAnn GhcPs
_ LIdP GhcPs
a [LIdP GhcPs]
bs) = do
Text -> R ()
txt Text
"|"
R ()
space
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> R ()
p_rdrName LIdP GhcPs
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
a
R ()
space
Text -> R ()
txt Text
"->"
R ()
space
R ()
-> (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> R ())
-> [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> R ()
p_rdrName [LIdP GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
bs
p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn FamEqn {HsTyPats GhcPs
HsOuterFamEqnTyVarBndrs GhcPs
LHsKind GhcPs
LIdP GhcPs
XCFamEqn GhcPs (LHsKind GhcPs)
LexicalFixity
feqn_ext :: forall pass rhs. FamEqn pass rhs -> XCFamEqn pass rhs
feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs :: LHsKind GhcPs
feqn_fixity :: LexicalFixity
feqn_pats :: HsTyPats GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_tycon :: LIdP GhcPs
feqn_ext :: XCFamEqn GhcPs (LHsKind GhcPs)
..} = do
case HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs of
HsOuterImplicit XHsOuterImplicit GhcPs
NoExtField -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
HsOuterExplicit XHsOuterExplicit GhcPs ()
_ [LHsTyVarBndr () (NoGhcTc GhcPs)]
bndrs -> do
ForAllVisibility
-> (HsTyVarBndr () GhcPs -> R ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
-> R ()
forall a. ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LHsTyVarBndr () (NoGhcTc GhcPs)]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
bndrs
R ()
breakpoint
let atLeastOneBndr :: Bool
atLeastOneBndr = case HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs of
HsOuterImplicit XHsOuterImplicit GhcPs
NoExtField -> Bool
False
HsOuterExplicit XHsOuterExplicit GhcPs ()
_ [LHsTyVarBndr () (NoGhcTc GhcPs)]
bndrs -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr () (NoGhcTc GhcPs)]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
bndrs
Bool -> R () -> R ()
inciIf Bool
atLeastOneBndr (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
let famLhsSpn :: [SrcSpan]
famLhsSpn = GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
feqn_tycon SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> SrcSpan)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> SrcSpan
forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan HsTyPats GhcPs
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
feqn_pats
[SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
famLhsSpn (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
(LexicalFixity -> Bool
isInfix LexicalFixity
feqn_fixity)
Bool
True
(GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> R ()
p_rdrName LIdP GhcPs
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
feqn_tycon)
(LHsTypeArg GhcPs -> R ()
HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> R ()
p_lhsTypeArg (HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> R ())
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTyPats GhcPs
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
feqn_pats)
R ()
space
R ()
equals
R ()
breakpoint
R () -> R ()
inci (GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsKind GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
feqn_rhs HsType GhcPs -> R ()
p_hsType)
isInfix :: LexicalFixity -> Bool
isInfix :: LexicalFixity -> Bool
isInfix = \case
LexicalFixity
Infix -> Bool
True
LexicalFixity
Prefix -> Bool
False