{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.Class
( p_classDecl,
)
where
import Class
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.Type
import Ormolu.Utils
import RdrName (RdrName (..))
p_classDecl ::
LHsContext GhcPs ->
Located RdrName ->
LHsQTyVars GhcPs ->
LexicalFixity ->
[Located (FunDep (Located RdrName))] ->
[LSig GhcPs] ->
LHsBinds GhcPs ->
[LFamilyDecl GhcPs] ->
[LTyFamDefltEqn GhcPs] ->
[LDocDecl] ->
R ()
p_classDecl :: LHsContext GhcPs
-> Located RdrName
-> LHsQTyVars GhcPs
-> LexicalFixity
-> [Located (FunDep (Located RdrName))]
-> [LSig GhcPs]
-> LHsBinds GhcPs
-> [LFamilyDecl GhcPs]
-> [LTyFamDefltEqn GhcPs]
-> [LDocDecl]
-> R ()
p_classDecl ctx :: LHsContext GhcPs
ctx name :: Located RdrName
name HsQTvs {..} fixity :: LexicalFixity
fixity fdeps :: [Located (FunDep (Located RdrName))]
fdeps csigs :: [LSig GhcPs]
csigs cdefs :: LHsBinds GhcPs
cdefs cats :: [LFamilyDecl GhcPs]
cats catdefs :: [LTyFamDefltEqn GhcPs]
catdefs cdocs :: [LDocDecl]
cdocs = do
let variableSpans :: [SrcSpan]
variableSpans = LHsTyVarBndr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsTyVarBndr GhcPs -> SrcSpan)
-> [LHsTyVarBndr GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr GhcPs]
hsq_explicit
signatureSpans :: [SrcSpan]
signatureSpans = Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located RdrName
name SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
variableSpans
dependencySpans :: [SrcSpan]
dependencySpans = Located (FunDep (Located RdrName)) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (Located (FunDep (Located RdrName)) -> SrcSpan)
-> [Located (FunDep (Located RdrName))] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (FunDep (Located RdrName))]
fdeps
combinedSpans :: [SrcSpan]
combinedSpans = LHsContext GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsContext GhcPs
ctx SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: ([SrcSpan]
signatureSpans [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
dependencySpans)
Text -> R ()
txt "class"
[SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
combinedSpans (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
LHsContext GhcPs -> R ()
p_classContext LHsContext GhcPs
ctx
[SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
signatureSpans (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
Bool -> (R () -> R ()) -> R () -> [R ()] -> R ()
p_infixDefHelper
(LexicalFixity -> Bool
isInfix LexicalFixity
fixity)
R () -> R ()
inci
(Located RdrName -> R ()
p_rdrName Located RdrName
name)
((HsTyVarBndr GhcPs -> R ()) -> LHsTyVarBndr GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' HsTyVarBndr 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)
R () -> R ()
inci ([Located (FunDep (Located RdrName))] -> R ()
p_classFundeps [Located (FunDep (Located RdrName))]
fdeps)
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]
csigs
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
cdefs
tyFams :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
tyFams = (LFamilyDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LFamilyDecl GhcPs -> SrcSpan)
-> (LFamilyDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LFamilyDecl GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (FamilyDecl GhcPs -> HsDecl GhcPs)
-> LFamilyDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExt
XTyClD GhcPs
NoExt (TyClDecl GhcPs -> HsDecl GhcPs)
-> (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs
-> HsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExt
XFamDecl GhcPs
NoExt)) (LFamilyDecl GhcPs -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LFamilyDecl GhcPs]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LFamilyDecl GhcPs]
cats
docs :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
docs = (LDocDecl -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LDocDecl -> SrcSpan)
-> (LDocDecl -> GenLocated SrcSpan (HsDecl GhcPs))
-> LDocDecl
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (DocDecl -> HsDecl GhcPs)
-> LDocDecl -> GenLocated SrcSpan (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XDocD GhcPs -> DocDecl -> HsDecl GhcPs
forall p. XDocD p -> DocDecl -> HsDecl p
DocD NoExt
XDocD GhcPs
NoExt)) (LDocDecl -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LDocDecl] -> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LDocDecl]
cdocs
tyFamDefs :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
tyFamDefs =
( LTyFamDefltEqn GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LTyFamDefltEqn GhcPs -> SrcSpan)
-> (LTyFamDefltEqn GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LTyFamDefltEqn GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (TyFamDefltEqn GhcPs -> HsDecl GhcPs)
-> LTyFamDefltEqn 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)
-> (TyFamDefltEqn GhcPs -> InstDecl GhcPs)
-> TyFamDefltEqn 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 (TyFamInstDecl GhcPs -> InstDecl GhcPs)
-> (TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs)
-> TyFamDefltEqn GhcPs
-> InstDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
defltEqnToInstDecl)
)
(LTyFamDefltEqn GhcPs
-> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LTyFamDefltEqn GhcPs]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LTyFamDefltEqn GhcPs]
catdefs
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))]
tyFams [(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))]
tyFamDefs [(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))]
docs)
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 ()
space
Text -> R ()
txt "where"
R ()
breakpoint
R () -> R ()
inci (FamilyStyle -> [GenLocated SrcSpan (HsDecl GhcPs)] -> R ()
p_hsDeclsRespectGrouping FamilyStyle
Associated [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls)
p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = String -> R ()
forall a. String -> a
notImplemented "XLHsQTyVars"
p_classContext :: LHsContext GhcPs -> R ()
p_classContext :: LHsContext GhcPs -> R ()
p_classContext ctx :: LHsContext GhcPs
ctx = Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LHsType GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LHsContext GhcPs -> SrcSpanLess (LHsContext GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsContext GhcPs
ctx)) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
LHsContext GhcPs -> ([LHsType GhcPs] -> R ()) -> R ()
forall a. Data a => Located a -> (a -> R ()) -> R ()
located LHsContext GhcPs
ctx [LHsType GhcPs] -> R ()
p_hsContext
R ()
space
Text -> R ()
txt "=>"
R ()
breakpoint
p_classFundeps :: [Located (FunDep (Located RdrName))] -> R ()
p_classFundeps :: [Located (FunDep (Located RdrName))] -> R ()
p_classFundeps fdeps :: [Located (FunDep (Located RdrName))]
fdeps = Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Located (FunDep (Located RdrName))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (FunDep (Located RdrName))]
fdeps) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
R ()
breakpoint
Text -> R ()
txt "|"
R ()
space
R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R ()
-> (Located (FunDep (Located RdrName)) -> R ())
-> [Located (FunDep (Located RdrName))]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint) (R () -> R ()
sitcc (R () -> R ())
-> (Located (FunDep (Located RdrName)) -> R ())
-> Located (FunDep (Located RdrName))
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FunDep (Located RdrName) -> R ())
-> Located (FunDep (Located RdrName)) -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' FunDep (Located RdrName) -> R ()
p_funDep) [Located (FunDep (Located RdrName))]
fdeps
p_funDep :: FunDep (Located RdrName) -> R ()
p_funDep :: FunDep (Located RdrName) -> R ()
p_funDep (before :: [Located RdrName]
before, after :: [Located RdrName]
after) = do
R () -> (Located RdrName -> R ()) -> [Located RdrName] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space Located RdrName -> R ()
p_rdrName [Located RdrName]
before
R ()
space
Text -> R ()
txt "->"
R ()
space
R () -> (Located RdrName -> R ()) -> [Located RdrName] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space Located RdrName -> R ()
p_rdrName [Located RdrName]
after
defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
defltEqnToInstDecl FamEqn {..} = TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl {..}
where
eqn :: FamEqn GhcPs [HsArg (LHsType GhcPs) ty] (LHsType GhcPs)
eqn = FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn {feqn_pats :: [HsArg (LHsType GhcPs) ty]
feqn_pats = (LHsType GhcPs -> HsArg (LHsType GhcPs) ty)
-> [LHsType GhcPs] -> [HsArg (LHsType GhcPs) ty]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsArg (LHsType GhcPs) ty
forall tm ty. tm -> HsArg tm ty
HsValArg (LHsQTyVars GhcPs -> [LHsType GhcPs]
tyVarsToTypes LHsQTyVars GhcPs
feqn_pats), ..}
tfid_eqn :: HsImplicitBndrs
GhcPs
(FamEqn
GhcPs [HsArg (LHsType GhcPs) (LHsType GhcPs)] (LHsType GhcPs))
tfid_eqn = HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB {hsib_ext :: XHsIB
GhcPs
(FamEqn
GhcPs [HsArg (LHsType GhcPs) (LHsType GhcPs)] (LHsType GhcPs))
hsib_ext = NoExt
XHsIB
GhcPs
(FamEqn
GhcPs [HsArg (LHsType GhcPs) (LHsType GhcPs)] (LHsType GhcPs))
NoExt, hsib_body :: FamEqn
GhcPs [HsArg (LHsType GhcPs) (LHsType GhcPs)] (LHsType GhcPs)
hsib_body = FamEqn
GhcPs [HsArg (LHsType GhcPs) (LHsType GhcPs)] (LHsType GhcPs)
forall ty. FamEqn GhcPs [HsArg (LHsType GhcPs) ty] (LHsType GhcPs)
eqn}
defltEqnToInstDecl XFamEqn {} = String -> TyFamInstDecl GhcPs
forall a. String -> a
notImplemented "XFamEqn"
isInfix :: LexicalFixity -> Bool
isInfix :: LexicalFixity -> Bool
isInfix = \case
Infix -> Bool
True
Prefix -> Bool
False