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

-- | Rendering of data\/type families.
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 (HsBndrVis GhcPs) GhcPs]
XHsQTvs GhcPs
hsq_ext :: XHsQTvs GhcPs
hsq_explicit :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
hsq_explicit :: forall pass.
LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
..}, Maybe (LInjectivityAnn GhcPs)
LexicalFixity
FamilyInfo GhcPs
XCFamilyDecl GhcPs
LFamilyResultSig GhcPs
LIdP GhcPs
TopLevelFlag
fdExt :: XCFamilyDecl GhcPs
fdInfo :: FamilyInfo GhcPs
fdTopLevel :: TopLevelFlag
fdLName :: LIdP GhcPs
fdFixity :: LexicalFixity
fdResultSig :: LFamilyResultSig GhcPs
fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdExt :: forall pass. FamilyDecl pass -> XCFamilyDecl pass
fdFixity :: forall pass. FamilyDecl pass -> LexicalFixity
fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdTopLevel :: forall pass. FamilyDecl pass -> TopLevelFlag
..} = do
  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 a b. a -> R b -> R a
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 a b. a -> R b -> R a
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
  [GenLocated
     SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
Maybe [LTyFamInstEqn 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 a b. a -> R b -> R a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"type"
  txt $ case style of
    FamilyStyle
Associated -> Text
forall a. Monoid a => a
mempty
    FamilyStyle
Free -> Text
" family"
  let headerSpns = GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
fdLName SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
 -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
[LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
hsq_explicit)
      headerAndSigSpns = GenLocated EpAnnCO (FamilyResultSig GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated EpAnnCO (FamilyResultSig GhcPs)
LFamilyResultSig GhcPs
fdResultSig SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
headerSpns
  inci . switchLayout headerAndSigSpns $ do
    breakpoint
    switchLayout headerSpns $ do
      p_infixDefHelper
        (isInfix fdFixity)
        True
        (p_rdrName fdLName)
        (located' p_hsTyVarBndr <$> hsq_explicit)
    let resultSig = LFamilyResultSig GhcPs -> Maybe (R ())
p_familyResultSigL LFamilyResultSig GhcPs
fdResultSig
    unless (isNothing resultSig && isNothing fdInjectivityAnn) space
    inci $ do
      sequence_ resultSig
      space
      forM_ fdInjectivityAnn (located' p_injectivityAnn)
  case mmeqs of
    Maybe
  (Maybe
     [GenLocated
        SrcSpanAnnA
        (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))])
Nothing -> () -> R ()
forall a. a -> R a
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 () -> R ()
inci (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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> R ()
TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn) [GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqs)

p_familyResultSigL ::
  LFamilyResultSig GhcPs ->
  Maybe (R ())
p_familyResultSigL :: LFamilyResultSig GhcPs -> Maybe (R ())
p_familyResultSigL (L EpAnnCO
_ FamilyResultSig GhcPs
a) = case FamilyResultSig GhcPs
a of
  NoSig NoExtField
XNoSig GhcPs
NoExtField -> Maybe (R ())
forall a. Maybe a
Nothing
  KindSig NoExtField
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. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsKind GhcPs
k HsType GhcPs -> R ()
p_hsType
  TyVarSig NoExtField
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. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
LHsTyVarBndr () GhcPs
bndr HsTyVarBndr () GhcPs -> R ()
forall flag. IsTyVarBndrFlag 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 SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
a
  R ()
space
  Text -> R ()
txt Text
"->"
  R ()
space
  R ()
-> (GenLocated SrcSpanAnnN RdrName -> R ())
-> [GenLocated SrcSpanAnnN RdrName]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space GenLocated SrcSpanAnnN RdrName -> R ()
p_rdrName [GenLocated SrcSpanAnnN RdrName]
[LIdP GhcPs]
bs

p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn FamEqn {HsFamEqnPats GhcPs
LexicalFixity
XCFamEqn GhcPs (LHsKind GhcPs)
LHsKind GhcPs
LIdP GhcPs
HsOuterFamEqnTyVarBndrs GhcPs
feqn_ext :: XCFamEqn GhcPs (LHsKind GhcPs)
feqn_tycon :: LIdP GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_pats :: HsFamEqnPats GhcPs
feqn_fixity :: LexicalFixity
feqn_rhs :: LHsKind GhcPs
feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_ext :: forall pass rhs. FamEqn pass rhs -> XCFamEqn pass rhs
feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsFamEqnPats pass
feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
..} = do
  case HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs of
    HsOuterImplicit NoExtField
XHsOuterImplicit GhcPs
NoExtField -> () -> R ()
forall a. a -> R a
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 l a.
HasLoc l =>
ForAllVisibility -> (a -> R ()) -> [GenLocated l a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr () GhcPs -> R ()
forall flag. IsTyVarBndrFlag flag => HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () (NoGhcTc GhcPs)]
bndrs
      R ()
breakpoint
  let atLeastOneBndr :: Bool
atLeastOneBndr = case HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs of
        HsOuterImplicit NoExtField
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () (NoGhcTc 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 SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
feqn_tycon SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> SrcSpan)
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> SrcSpan
LHsTypeArg GhcPs -> SrcSpan
lhsTypeArgSrcSpan [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsFamEqnPats 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 SrcSpanAnnN RdrName -> R ()
p_rdrName GenLocated SrcSpanAnnN RdrName
LIdP GhcPs
feqn_tycon)
        (HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> R ()
LHsTypeArg GhcPs -> R ()
p_lhsTypeArg (HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> R ())
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsFamEqnPats GhcPs
feqn_pats)
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      R ()
space
      R ()
equals
      R ()
breakpoint
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> (HsType GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (HsType GhcPs)
LHsKind GhcPs
feqn_rhs HsType GhcPs -> R ()
p_hsType

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

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