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

-- | Rendering of type class declarations.
module Ormolu.Printer.Meat.Declaration.Class
  ( p_classDecl,
  )
where

import Control.Arrow
import Control.Monad
import Data.Foldable
import Data.Function (on)
import Data.List (sortBy)
import GHC.Core.Class
import GHC.Hs.Binds
import GHC.Hs.Decls
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Types.Basic
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
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 l e. GenLocated l e -> l
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 l e. GenLocated l e -> l
getLoc Located RdrName
name SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: [SrcSpan]
variableSpans
      dependencySpans :: [SrcSpan]
dependencySpans = Located (FunDep (Located RdrName)) -> SrcSpan
forall l e. GenLocated l e -> l
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 l e. GenLocated l e -> l
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 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]
csigs
      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
cdefs
      tyFams :: [(SrcSpan, GenLocated SrcSpan (HsDecl GhcPs))]
tyFams = (LFamilyDecl GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
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 l e. GenLocated l e -> l
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 l e. GenLocated l e -> l
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, 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))]
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 -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
          (LexicalFixity -> Bool
isInfix LexicalFixity
fixity)
          Bool
True
          (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 ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag 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_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 -> [LHsType GhcPs]
forall l e. GenLocated l e -> e
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 ()
inci (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 ()
commaDel (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