{-# 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.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 {-# 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 (Located 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 (Located OverlapMode)
deriv_overlap_mode :: Maybe (Located OverlapMode)
deriv_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_type :: LHsSigWcType GhcPs
deriv_ext :: XCDerivDecl GhcPs
..} = do
  let typesAfterInstance :: R ()
typesAfterInstance = Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located (HsImplicitBndrs GhcPs (Located (HsType GhcPs))
-> Located (HsType GhcPs)
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body (LHsSigWcType GhcPs
-> HsImplicitBndrs GhcPs (Located (HsType GhcPs))
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcPs
deriv_type)) HsType GhcPs -> R ()
p_hsType
      instTypes :: Bool -> R ()
instTypes Bool
toIndent = R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> R ()
txt Text
"instance"
        R ()
breakpoint
        Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (Located 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
      DerivStrategy GhcPs
StockStrategy -> do
        Text -> R ()
txt Text
"stock "
        Bool -> R ()
instTypes Bool
False
      DerivStrategy GhcPs
AnyclassStrategy -> do
        Text -> R ()
txt Text
"anyclass "
        Bool -> R ()
instTypes Bool
False
      DerivStrategy GhcPs
NewtypeStrategy -> do
        Text -> R ()
txt Text
"newtype "
        Bool -> R ()
instTypes Bool
False
      ViaStrategy HsIB {..} -> do
        Text -> R ()
txt Text
"via"
        R ()
breakpoint
        R () -> R ()
inci (Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (HsType GhcPs)
hsib_body HsType GhcPs -> R ()
p_hsType)
        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 (Located OverlapMode)
HsImplicitBndrs GhcPs (Located (HsType 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 (Located OverlapMode)
cid_overlap_mode :: Maybe (Located OverlapMode)
cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_sigs :: [LSig GhcPs]
cid_binds :: LHsBinds GhcPs
cid_poly_ty :: HsImplicitBndrs GhcPs (Located (HsType GhcPs))
cid_ext :: XCClsInstDecl GhcPs
..} = do
  Text -> R ()
txt Text
"instance"
  let HsIB {XHsIB GhcPs (Located (HsType GhcPs))
Located (HsType GhcPs)
hsib_body :: Located (HsType GhcPs)
hsib_ext :: XHsIB GhcPs (Located (HsType GhcPs))
hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
..} = HsImplicitBndrs GhcPs (Located (HsType GhcPs))
cid_poly_ty
  -- 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 SrcSpan (HsDecl GhcPs))]
sigs = (LSig GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LSig GhcPs -> SrcSpan)
-> (LSig GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LSig GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Sig GhcPs -> HsDecl GhcPs)
-> LSig GhcPs -> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
XSigD GhcPs
NoExtField)) (LSig GhcPs -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LSig GhcPs] -> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LSig GhcPs]
cid_sigs
      vals :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
vals = (GenLocated SrcSpan (HsBind GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (GenLocated SrcSpan (HsBind GhcPs) -> SrcSpan)
-> (GenLocated SrcSpan (HsBind GhcPs)
    -> GenLocated SrcSpan (HsDecl GhcPs))
-> GenLocated SrcSpan (HsBind GhcPs)
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (HsBind GhcPs -> HsDecl GhcPs)
-> GenLocated SrcSpan (HsBind GhcPs)
-> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
NoExtField)) (GenLocated SrcSpan (HsBind GhcPs)
 -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [GenLocated SrcSpan (HsBind GhcPs)]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsBinds GhcPs -> [GenLocated SrcSpan (HsBind GhcPs)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LHsBinds GhcPs
cid_binds
      tyFamInsts :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
tyFamInsts =
        ( LTyFamInstDecl GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LTyFamInstDecl GhcPs -> SrcSpan)
-> (LTyFamInstDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LTyFamInstDecl GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (TyFamInstDecl GhcPs -> HsDecl GhcPs)
-> LTyFamInstDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
XInstD GhcPs
NoExtField (InstDecl GhcPs -> HsDecl GhcPs)
-> (TyFamInstDecl GhcPs -> InstDecl GhcPs)
-> TyFamInstDecl GhcPs
-> HsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
XTyFamInstD GhcPs
NoExtField)
        )
          (LTyFamInstDecl GhcPs
 -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LTyFamInstDecl GhcPs]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LTyFamInstDecl GhcPs]
cid_tyfam_insts
      dataFamInsts :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
dataFamInsts =
        ( LDataFamInstDecl GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LDataFamInstDecl GhcPs -> SrcSpan)
-> (LDataFamInstDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LDataFamInstDecl GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (DataFamInstDecl GhcPs -> HsDecl GhcPs)
-> LDataFamInstDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
XInstD GhcPs
NoExtField (InstDecl GhcPs -> HsDecl GhcPs)
-> (DataFamInstDecl GhcPs -> InstDecl GhcPs)
-> DataFamInstDecl GhcPs
-> HsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD NoExtField
XDataFamInstD GhcPs
NoExtField)
        )
          (LDataFamInstDecl GhcPs
 -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LDataFamInstDecl GhcPs]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LDataFamInstDecl GhcPs]
cid_datafam_insts
      allDecls :: [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls =
        (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
-> GenLocated SrcSpan (HsDecl GhcPs)
forall a b. (a, b) -> b
snd ((SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
 -> GenLocated SrcSpan (HsDecl GhcPs))
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [GenLocated SrcSpan (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
 -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)) -> Ordering)
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> ((SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)) -> SrcSpan)
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)) -> SrcSpan
forall a b. (a, b) -> a
fst) ([(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
sigs [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
vals [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
tyFamInsts [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
dataFamInsts)
  Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (HsType GhcPs)
hsib_body ((HsType GhcPs -> R ()) -> R ()) -> (HsType GhcPs -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \HsType GhcPs
x -> do
    R ()
breakpoint
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (Located OverlapMode)
cid_overlap_mode R ()
breakpoint
      HsType GhcPs -> R ()
p_hsType HsType GhcPs
x
      Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpan (HsDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        Text -> R ()
txt Text
"where"
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpan (HsDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls) (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
    -- Ensure whitespace is added after where clause.
    R ()
breakpoint
    R () -> R ()
dontUseBraces (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ FamilyStyle -> [GenLocated SrcSpan (HsDecl GhcPs)] -> R ()
p_hsDeclsRespectGrouping FamilyStyle
Associated [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls

p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl FamilyStyle
style TyFamInstDecl {TyFamInstEqn GhcPs
tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn :: TyFamInstEqn GhcPs
..} = do
  Text -> R ()
txt (Text -> R ()) -> Text -> R ()
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 -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = HsIB {hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn {HsTyPats GhcPs
Maybe [LHsTyVarBndr () GhcPs]
HsDataDefn GhcPs
XCFamEqn GhcPs (HsDataDefn GhcPs)
LexicalFixity
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 :: HsDataDefn GhcPs
feqn_fixity :: LexicalFixity
feqn_pats :: HsTyPats GhcPs
feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs]
feqn_tycon :: Located (IdP GhcPs)
feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
..}}}) =
  FamilyStyle
-> Located RdrName
-> HsTyPats GhcPs
-> LexicalFixity
-> HsDataDefn GhcPs
-> R ()
p_dataDecl FamilyStyle
style Located (IdP GhcPs)
Located RdrName
feqn_tycon HsTyPats GhcPs
feqn_pats LexicalFixity
feqn_fixity HsDataDefn GhcPs
feqn_rhs

match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (Located OverlapMode)
overlap_mode R ()
layoutStrategy =
  case Located OverlapMode -> OverlapMode
forall l e. GenLocated l e -> e
unLoc (Located OverlapMode -> OverlapMode)
-> Maybe (Located OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located 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
_ -> () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()