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

-- | Type class, type family, and data family instance declarations.
module Ormolu.Printer.Meat.Declaration.Instance
  ( p_clsInstDecl,
    p_tyFamInstDecl,
    p_dataFamInstDecl,
    p_standaloneDerivDecl,
  )
where

import Control.Arrow
import Control.Monad
import Data.Foldable
import Data.Function (on)
import Data.List (sortBy)
import GHC.Hs
import GHC.Types.Basic
import GHC.Types.SrcLoc
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Declaration.Data
import Ormolu.Printer.Meat.Declaration.TypeFamily
import Ormolu.Printer.Meat.Type

p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
p_standaloneDerivDecl DerivDecl {Maybe (LDerivStrategy GhcPs)
Maybe (XRec GhcPs OverlapMode)
LHsSigWcType GhcPs
XCDerivDecl GhcPs
deriv_ext :: forall pass. DerivDecl pass -> XCDerivDecl pass
deriv_type :: forall pass. DerivDecl pass -> LHsSigWcType pass
deriv_strategy :: forall pass. DerivDecl pass -> Maybe (LDerivStrategy pass)
deriv_overlap_mode :: forall pass. DerivDecl pass -> Maybe (XRec pass OverlapMode)
deriv_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
deriv_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_type :: LHsSigWcType GhcPs
deriv_ext :: XCDerivDecl GhcPs
..} = do
  let typesAfterInstance :: R ()
typesAfterInstance = forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcPs
deriv_type) HsSigType GhcPs -> R ()
p_hsSigType
      instTypes :: Bool -> R ()
instTypes Bool
toIndent = R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
        Text -> R ()
txt Text
"instance"
        R ()
breakpoint
        Maybe (LocatedP OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (XRec GhcPs OverlapMode)
deriv_overlap_mode R ()
breakpoint
        Bool -> R () -> R ()
inciIf Bool
toIndent R ()
typesAfterInstance
  Text -> R ()
txt Text
"deriving"
  R ()
space
  case Maybe (LDerivStrategy GhcPs)
deriv_strategy of
    Maybe (LDerivStrategy GhcPs)
Nothing ->
      Bool -> R ()
instTypes Bool
False
    Just (L SrcSpan
_ DerivStrategy GhcPs
a) -> case DerivStrategy GhcPs
a of
      StockStrategy XStockStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"stock "
        Bool -> R ()
instTypes Bool
False
      AnyclassStrategy XAnyClassStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"anyclass "
        Bool -> R ()
instTypes Bool
False
      NewtypeStrategy XNewtypeStrategy GhcPs
_ -> do
        Text -> R ()
txt Text
"newtype "
        Bool -> R ()
instTypes Bool
False
      ViaStrategy (XViaStrategyPs EpAnn [AddEpAnn]
_ LHsSigType GhcPs
sigTy) -> do
        Text -> R ()
txt Text
"via"
        R ()
breakpoint
        R () -> R ()
inci (forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsSigType GhcPs
sigTy HsSigType GhcPs -> R ()
p_hsSigType)
        R ()
breakpoint
        Bool -> R ()
instTypes Bool
True

p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
p_clsInstDecl ClsInstDecl {[LTyFamInstDecl GhcPs]
[LDataFamInstDecl GhcPs]
[LSig GhcPs]
Maybe (XRec GhcPs OverlapMode)
LHsSigType GhcPs
XCClsInstDecl GhcPs
LHsBinds GhcPs
cid_ext :: forall pass. ClsInstDecl pass -> XCClsInstDecl pass
cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_sigs :: [LSig GhcPs]
cid_binds :: LHsBinds GhcPs
cid_poly_ty :: LHsSigType GhcPs
cid_ext :: XCClsInstDecl GhcPs
..} = do
  Text -> R ()
txt Text
"instance"
  -- GHC's AST does not necessarily store each kind of element in source
  -- location order. This happens because different declarations are stored in
  -- different lists. Consequently, to get all the declarations in proper
  -- order, they need to be manually sorted.
  let sigs :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
sigs = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LSig GhcPs]
cid_sigs
      vals :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
vals = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LHsBinds GhcPs
cid_binds
      tyFamInsts :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFamInsts =
        ( forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
NoExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
NoExtField)
        )
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LTyFamInstDecl GhcPs]
cid_tyfam_insts
      dataFamInsts :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
dataFamInsts =
        ( forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
NoExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD forall ann. EpAnn ann
EpAnnNotUsed)
        )
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LDataFamInstDecl GhcPs]
cid_datafam_insts
      allDecls :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls =
        forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) ([(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
sigs forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
vals forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFamInsts forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
dataFamInsts)
  forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsSigType GhcPs
cid_poly_ty forall a b. (a -> b) -> a -> b
$ \HsSigType GhcPs
sigTy -> do
    R ()
breakpoint
    R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
      Maybe (LocatedP OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (XRec GhcPs OverlapMode)
cid_overlap_mode R ()
breakpoint
      HsSigType GhcPs -> R ()
p_hsSigType HsSigType GhcPs
sigTy
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls) forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        Text -> R ()
txt Text
"where"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls) forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
    -- Ensure whitespace is added after where clause.
    R ()
breakpoint
    R () -> R ()
dontUseBraces forall a b. (a -> b) -> a -> b
$ FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDeclsRespectGrouping FamilyStyle
Associated [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls

p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl FamilyStyle
style TyFamInstDecl {TyFamInstEqn GhcPs
XCTyFamInstDecl GhcPs
tfid_xtn :: forall pass. TyFamInstDecl pass -> XCTyFamInstDecl pass
tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn :: TyFamInstEqn GhcPs
tfid_xtn :: XCTyFamInstDecl GhcPs
..} = do
  Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case FamilyStyle
style of
    FamilyStyle
Associated -> Text
"type"
    FamilyStyle
Free -> Text
"type instance"
  R ()
breakpoint
  R () -> R ()
inci (TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn TyFamInstEqn GhcPs
tfid_eqn)

p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()
p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()
p_dataFamInstDecl FamilyStyle
style (DataFamInstDecl {dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn = FamEqn {HsTyPats GhcPs
HsDataDefn GhcPs
HsOuterFamEqnTyVarBndrs GhcPs
LIdP GhcPs
XCFamEqn GhcPs (HsDataDefn 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 :: HsDataDefn GhcPs
feqn_fixity :: LexicalFixity
feqn_pats :: HsTyPats GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_tycon :: LIdP GhcPs
feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
..}}) =
  FamilyStyle
-> LocatedN RdrName
-> HsTyPats GhcPs
-> LexicalFixity
-> HsDataDefn GhcPs
-> R ()
p_dataDecl FamilyStyle
style LIdP GhcPs
feqn_tycon HsTyPats GhcPs
feqn_pats LexicalFixity
feqn_fixity HsDataDefn GhcPs
feqn_rhs

match_overlap_mode :: Maybe (LocatedP OverlapMode) -> R () -> R ()
match_overlap_mode :: Maybe (LocatedP OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (LocatedP OverlapMode)
overlap_mode R ()
layoutStrategy =
  case forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LocatedP OverlapMode)
overlap_mode of
    Just Overlappable {} -> do
      Text -> R ()
txt Text
"{-# OVERLAPPABLE #-}"
      R ()
layoutStrategy
    Just Overlapping {} -> do
      Text -> R ()
txt Text
"{-# OVERLAPPING #-}"
      R ()
layoutStrategy
    Just Overlaps {} -> do
      Text -> R ()
txt Text
"{-# OVERLAPS #-}"
      R ()
layoutStrategy
    Just Incoherent {} -> do
      Text -> R ()
txt Text
"{-# INCOHERENT #-}"
      R ()
layoutStrategy
    Maybe OverlapMode
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()