{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.Instance
( p_clsInstDecl,
p_tyFamInstDecl,
p_dataFamInstDecl,
p_standaloneDerivDecl,
)
where
import BasicTypes
import Control.Arrow
import Control.Monad
import Data.Foldable
import Data.List (sortOn)
import GHC
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
import Ormolu.Utils
p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
p_standaloneDerivDecl DerivDecl {..} = do
let typesAfterInstance :: R ()
typesAfterInstance = Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Data 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 toIndent :: Bool
toIndent = R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt "instance"
R ()
breakpoint
Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode Maybe (Located OverlapMode)
deriv_overlap_mode R ()
breakpoint
if Bool
toIndent
then R () -> R ()
inci R ()
typesAfterInstance
else R ()
typesAfterInstance
Text -> R ()
txt "deriving"
R ()
space
case Maybe (LDerivStrategy GhcPs)
deriv_strategy of
Nothing ->
Bool -> R ()
instTypes Bool
False
Just (L _ a :: DerivStrategy GhcPs
a) -> case DerivStrategy GhcPs
a of
StockStrategy -> do
Text -> R ()
txt "stock "
Bool -> R ()
instTypes Bool
False
AnyclassStrategy -> do
Text -> R ()
txt "anyclass "
Bool -> R ()
instTypes Bool
False
NewtypeStrategy -> do
Text -> R ()
txt "newtype "
Bool -> R ()
instTypes Bool
False
ViaStrategy HsIB {..} -> do
Text -> R ()
txt "via"
R ()
breakpoint
R () -> R ()
inci (Located (HsType GhcPs) -> (HsType GhcPs -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located Located (HsType GhcPs)
hsib_body HsType GhcPs -> R ()
p_hsType)
R ()
breakpoint
Bool -> R ()
instTypes Bool
True
ViaStrategy (XHsImplicitBndrs NoExt) ->
String -> R ()
forall a. String -> a
notImplemented "XHsImplicitBndrs"
p_standaloneDerivDecl (XDerivDecl _) = String -> R ()
forall a. String -> a
notImplemented "XDerivDecl"
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
p_clsInstDecl = \case
ClsInstDecl {..} -> do
Text -> R ()
txt "instance"
case HsImplicitBndrs GhcPs (Located (HsType GhcPs))
cid_poly_ty of
HsIB {..} -> do
let sigs :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
sigs = (LSig GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
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 NoExt
XSigD GhcPs
NoExt)) (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 a. HasSrcSpan a => a -> SrcSpan
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 NoExt
XValD GhcPs
NoExt)) (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 a. HasSrcSpan a => a -> SrcSpan
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 NoExt
XInstD GhcPs
NoExt (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 NoExt
XTyFamInstD GhcPs
NoExt)
)
(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 a. HasSrcSpan a => a -> SrcSpan
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 NoExt
XInstD GhcPs
NoExt (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 NoExt
XDataFamInstD GhcPs
NoExt)
)
(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)
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (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. Data 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
$ \x :: 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 "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 ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
inci
(R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
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
XHsImplicitBndrs NoExt -> String -> R ()
forall a. String -> a
notImplemented "XHsImplicitBndrs"
XClsInstDecl NoExt -> String -> R ()
forall a. String -> a
notImplemented "XClsInstDecl"
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl style :: FamilyStyle
style = \case
TyFamInstDecl {..} -> do
Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ case FamilyStyle
style of
Associated -> "type"
Free -> "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 style :: FamilyStyle
style = \case
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 {..}}} ->
FamilyStyle
-> Located RdrName
-> [Located (HsType GhcPs)]
-> LexicalFixity
-> HsDataDefn GhcPs
-> R ()
p_dataDecl FamilyStyle
style Located (IdP GhcPs)
Located RdrName
feqn_tycon ((LHsTypeArg GhcPs -> Located (HsType GhcPs))
-> HsTyPats GhcPs -> [Located (HsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> Located (HsType GhcPs)
forall p. LHsTypeArg p -> LHsType p
typeArgToType HsTyPats GhcPs
feqn_pats) LexicalFixity
feqn_fixity HsDataDefn GhcPs
feqn_rhs
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 = XFamEqn {}}} ->
String -> R ()
forall a. String -> a
notImplemented "XFamEqn"
DataFamInstDecl {dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = XHsImplicitBndrs {}} ->
String -> R ()
forall a. String -> a
notImplemented "XHsImplicitBndrs"
match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
match_overlap_mode overlap_mode :: Maybe (Located OverlapMode)
overlap_mode layoutStrategy :: R ()
layoutStrategy =
case Located OverlapMode -> OverlapMode
forall a. HasSrcSpan a => a -> SrcSpanLess a
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 "{-# OVERLAPPABLE #-}"
R ()
layoutStrategy
Just Overlapping {} -> do
Text -> R ()
txt "{-# OVERLAPPING #-}"
R ()
layoutStrategy
Just Overlaps {} -> do
Text -> R ()
txt "{-# OVERLAPS #-}"
R ()
layoutStrategy
Just Incoherent {} -> do
Text -> R ()
txt "{-# INCOHERENT #-}"
R ()
layoutStrategy
_ -> () -> R ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()