{-# 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 ()