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

-- | Rendering of type class declarations.
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

p_classDecl ::
  LHsContext GhcPs ->
  Located RdrName ->
  LHsQTyVars GhcPs ->
  LexicalFixity ->
  [Located (FunDep (Located RdrName))] ->
  [LSig GhcPs] ->
  LHsBinds GhcPs ->
  [LFamilyDecl GhcPs] ->
  [LTyFamDefltDecl GhcPs] ->
  [LDocDecl] ->
  R ()
p_classDecl :: LHsContext GhcPs
-> Located RdrName
-> LHsQTyVars GhcPs
-> LexicalFixity
-> [Located (FunDep (Located RdrName))]
-> [LSig GhcPs]
-> LHsBinds GhcPs
-> [LFamilyDecl GhcPs]
-> [LTyFamDefltDecl GhcPs]
-> [LDocDecl]
-> R ()
p_classDecl LHsContext GhcPs
ctx Located RdrName
name HsQTvs {[LHsTyVarBndr GhcPs]
XHsQTvs GhcPs
hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit :: [LHsTyVarBndr GhcPs]
hsq_ext :: XHsQTvs GhcPs
..} LexicalFixity
fixity [Located (FunDep (Located RdrName))]
fdeps [LSig GhcPs]
csigs LHsBinds GhcPs
cdefs [LFamilyDecl GhcPs]
cats [LTyFamDefltDecl GhcPs]
catdefs [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)
      -- 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.
      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 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]
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 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
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 NoExtField
XTyClD GhcPs
NoExtField (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 NoExtField
XFamDecl GhcPs
NoExtField)) (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 NoExtField
XDocD GhcPs
NoExtField)) (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 =
        ( LTyFamDefltDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LTyFamDefltDecl GhcPs -> SrcSpan)
-> (LTyFamDefltDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs))
-> LTyFamDefltDecl 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)
-> LTyFamDefltDecl 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)
        )
          (LTyFamDefltDecl GhcPs
 -> (SrcSpan, GenLocated SrcSpan (HsDecl GhcPs)))
-> [LTyFamDefltDecl GhcPs]
-> [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LTyFamDefltDecl 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)
  Text -> R ()
txt Text
"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. (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)
      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 ()
forall a b. (a -> b) -> a -> b
$ do
    R ()
breakpoint -- Ensure whitespace is added after where clause.
    R () -> R ()
inci (FamilyStyle -> [GenLocated SrcSpan (HsDecl GhcPs)] -> R ()
p_hsDeclsRespectGrouping FamilyStyle
Associated [GenLocated SrcSpan (HsDecl GhcPs)]
allDecls)
p_classDecl LHsContext GhcPs
_ Located RdrName
_ (XLHsQTyVars XXLHsQTyVars GhcPs
c) LexicalFixity
_ [Located (FunDep (Located RdrName))]
_ [LSig GhcPs]
_ LHsBinds GhcPs
_ [LFamilyDecl GhcPs]
_ [LTyFamDefltDecl GhcPs]
_ [LDocDecl]
_ = NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXLHsQTyVars GhcPs
c

p_classContext :: LHsContext GhcPs -> R ()
p_classContext :: LHsContext GhcPs -> R ()
p_classContext 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. Located a -> (a -> R ()) -> R ()
located LHsContext GhcPs
ctx [LHsType GhcPs] -> R ()
p_hsContext
  R ()
space
  Text -> R ()
txt Text
"=>"
  R ()
breakpoint

p_classFundeps :: [Located (FunDep (Located RdrName))] -> R ()
p_classFundeps :: [Located (FunDep (Located RdrName))] -> R ()
p_classFundeps [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 Text
"|"
  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. (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 ([Located RdrName]
before, [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 Text
"->"
  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

----------------------------------------------------------------------------
-- Helpers

isInfix :: LexicalFixity -> Bool
isInfix :: LexicalFixity -> Bool
isInfix = \case
  LexicalFixity
Infix -> Bool
True
  LexicalFixity
Prefix -> Bool
False