{-# 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.Decls
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Types.Basic
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
XCFamilyDecl GhcPs
LexicalFixity
LFamilyResultSig GhcPs
Located (IdP GhcPs)
fdExt :: forall pass. FamilyDecl pass -> XCFamilyDecl pass
fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdLName :: forall pass. FamilyDecl pass -> Located (IdP 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 :: Located (IdP GhcPs)
fdInfo :: FamilyInfo GhcPs
fdExt :: XCFamilyDecl GhcPs
..} = do
  Maybe (Maybe [LTyFamInstEqn GhcPs])
mmeqs <- case FamilyInfo GhcPs
fdInfo of
    FamilyInfo GhcPs
DataFamily -> Maybe (Maybe [LTyFamInstEqn GhcPs])
forall a. Maybe a
Nothing Maybe (Maybe [LTyFamInstEqn GhcPs])
-> R () -> R (Maybe (Maybe [LTyFamInstEqn GhcPs]))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"data"
    FamilyInfo GhcPs
OpenTypeFamily -> Maybe (Maybe [LTyFamInstEqn GhcPs])
forall a. Maybe a
Nothing Maybe (Maybe [LTyFamInstEqn GhcPs])
-> R () -> R (Maybe (Maybe [LTyFamInstEqn GhcPs]))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> R ()
txt Text
"type"
    ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
eqs -> Maybe [LTyFamInstEqn GhcPs] -> Maybe (Maybe [LTyFamInstEqn GhcPs])
forall a. a -> Maybe a
Just Maybe [LTyFamInstEqn GhcPs]
eqs Maybe (Maybe [LTyFamInstEqn GhcPs])
-> R () -> R (Maybe (Maybe [LTyFamInstEqn 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"
  R ()
breakpoint
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    [SrcSpan] -> R () -> R ()
switchLayout (GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (IdP GhcPs)
GenLocated SrcSpan RdrName
fdLName SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (LHsTyVarBndr () GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsTyVarBndr () GhcPs -> SrcSpan)
-> [LHsTyVarBndr () GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
hsq_explicit)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
      Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
        (LexicalFixity -> Bool
isInfix LexicalFixity
fdFixity)
        Bool
True
        (GenLocated SrcSpan RdrName -> R ()
p_rdrName Located (IdP GhcPs)
GenLocated SrcSpan RdrName
fdLName)
        ((HsTyVarBndr () GhcPs -> R ()) -> LHsTyVarBndr () GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr (LHsTyVarBndr () GhcPs -> R ())
-> [LHsTyVarBndr () GhcPs] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
hsq_explicit)
    let resultSig :: Maybe (R ())
resultSig = LFamilyResultSig GhcPs -> Maybe (R ())
p_familyResultSigL LFamilyResultSig 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 (LInjectivityAnn GhcPs) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (LInjectivityAnn 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 (LInjectivityAnn GhcPs)
-> (LInjectivityAnn GhcPs -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn ((InjectivityAnn GhcPs -> R ()) -> LInjectivityAnn GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' InjectivityAnn GhcPs -> R ()
p_injectivityAnn)
  case Maybe (Maybe [LTyFamInstEqn GhcPs])
mmeqs of
    Maybe (Maybe [LTyFamInstEqn GhcPs])
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Maybe [LTyFamInstEqn GhcPs]
meqs -> do
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        Text -> R ()
txt Text
"where"
      case Maybe [LTyFamInstEqn GhcPs]
meqs of
        Maybe [LTyFamInstEqn GhcPs]
Nothing -> do
          R ()
space
          Text -> R ()
txt Text
".."
        Just [LTyFamInstEqn GhcPs]
eqs -> do
          R ()
newline
          R ()
-> (LTyFamInstEqn GhcPs -> R ()) -> [LTyFamInstEqn GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline ((TyFamInstEqn GhcPs -> R ()) -> LTyFamInstEqn GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' (R () -> R ()
inci (R () -> R ())
-> (TyFamInstEqn GhcPs -> R ()) -> TyFamInstEqn GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn)) [LTyFamInstEqn GhcPs]
eqs

p_familyResultSigL ::
  Located (FamilyResultSig GhcPs) ->
  Maybe (R ())
p_familyResultSigL :: LFamilyResultSig 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
    LHsKind GhcPs -> (HsKind GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsKind GhcPs
k HsKind 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
    LHsTyVarBndr () GhcPs -> (HsTyVarBndr () GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsTyVarBndr () 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 Located (IdP GhcPs)
a [Located (IdP GhcPs)]
bs) = do
  Text -> R ()
txt Text
"|"
  R ()
space
  GenLocated SrcSpan RdrName -> R ()
p_rdrName Located (IdP GhcPs)
GenLocated SrcSpan RdrName
a
  R ()
space
  Text -> R ()
txt Text
"->"
  R ()
space
  R ()
-> (GenLocated SrcSpan RdrName -> R ())
-> [GenLocated SrcSpan RdrName]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space GenLocated SrcSpan RdrName -> R ()
p_rdrName [Located (IdP GhcPs)]
[GenLocated SrcSpan RdrName]
bs

p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn HsIB {hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn {HsTyPats GhcPs
Maybe [LHsTyVarBndr () GhcPs]
XCFamEqn GhcPs (LHsKind GhcPs)
LexicalFixity
LHsKind GhcPs
Located (IdP GhcPs)
feqn_ext :: forall pass rhs. FamEqn pass rhs -> XCFamEqn pass rhs
feqn_tycon :: forall pass rhs. FamEqn pass rhs -> Located (IdP pass)
feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> Maybe [LHsTyVarBndr () 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 :: Maybe [LHsTyVarBndr () GhcPs]
feqn_tycon :: Located (IdP GhcPs)
feqn_ext :: XCFamEqn GhcPs (LHsKind GhcPs)
..}} = do
  case Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs of
    Maybe [LHsTyVarBndr () GhcPs]
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [LHsTyVarBndr () GhcPs]
bndrs -> do
      ForAllVisibility
-> (HsTyVarBndr () GhcPs -> R ())
-> [LHsTyVarBndr () GhcPs]
-> R ()
forall a.
Data a =>
ForAllVisibility -> (a -> R ()) -> [Located a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [LHsTyVarBndr () GhcPs]
bndrs
      R ()
breakpoint
  Bool -> R () -> R ()
inciIf (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr () GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    let famLhsSpn :: [SrcSpan]
famLhsSpn = GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (IdP GhcPs)
GenLocated SrcSpan RdrName
feqn_tycon 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
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 SrcSpan RdrName -> R ()
p_rdrName Located (IdP GhcPs)
GenLocated SrcSpan RdrName
feqn_tycon)
        (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
feqn_pats)
    R ()
space
    R ()
equals
    R ()
breakpoint
    R () -> R ()
inci (LHsKind GhcPs -> (HsKind GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsKind GhcPs
feqn_rhs HsKind GhcPs -> R ()
p_hsType)

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

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