{-# 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 Data.Maybe
import GHC.Hs
import GHC.Types.Fixity
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 ::
  Maybe (LHsContext GhcPs) ->
  LocatedN RdrName ->
  LHsQTyVars GhcPs ->
  LexicalFixity ->
  [LHsFunDep GhcPs] ->
  [LSig GhcPs] ->
  LHsBinds GhcPs ->
  [LFamilyDecl GhcPs] ->
  [LTyFamDefltDecl GhcPs] ->
  [LDocDecl GhcPs] ->
  R ()
p_classDecl :: Maybe (LHsContext GhcPs)
-> LocatedN RdrName
-> LHsQTyVars GhcPs
-> LexicalFixity
-> [LHsFunDep GhcPs]
-> [LSig GhcPs]
-> LHsBinds GhcPs
-> [LFamilyDecl GhcPs]
-> [LTyFamDefltDecl GhcPs]
-> [LDocDecl GhcPs]
-> R ()
p_classDecl Maybe (LHsContext GhcPs)
ctx LocatedN 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 [LHsFunDep GhcPs]
fdeps [LSig GhcPs]
csigs LHsBinds GhcPs
cdefs [LFamilyDecl GhcPs]
cats [LTyFamDefltDecl GhcPs]
catdefs [LDocDecl GhcPs]
cdocs = do
  let variableSpans :: [SrcSpan]
variableSpans = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
hsq_explicit
      signatureSpans :: [SrcSpan]
signatureSpans = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN RdrName
name forall a. a -> [a] -> [a]
: [SrcSpan]
variableSpans
      dependencySpans :: [SrcSpan]
dependencySpans = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsFunDep GhcPs]
fdeps
      combinedSpans :: [SrcSpan]
combinedSpans = forall a. Maybe a -> [a]
maybeToList (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsContext GhcPs)
ctx) forall a. [a] -> [a] -> [a]
++ [SrcSpan]
signatureSpans 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 SrcSpanAnnA (HsDecl GhcPs))]
sigs = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LSig GhcPs]
csigs
      vals :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
vals = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LHsBinds GhcPs
cdefs
      tyFams :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFams = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
NoExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LFamilyDecl GhcPs]
cats
      docs :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
docs = (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XDocD p -> DocDecl p -> HsDecl p
DocD NoExtField
NoExtField)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LDocDecl GhcPs]
cdocs
      tyFamDefs :: [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFamDefs =
        ( forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
NoExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
NoExtField)
        )
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LTyFamDefltDecl GhcPs]
catdefs
      allDecls :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls =
        forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) ([(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
sigs forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
vals forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFams forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
tyFamDefs forall a. Semigroup a => a -> a -> a
<> [(SrcSpan, GenLocated SrcSpanAnnA (HsDecl GhcPs))]
docs)
  Text -> R ()
txt Text
"class"
  [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
combinedSpans forall a b. (a -> b) -> a -> b
$ do
    R ()
breakpoint
    R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (LHsContext GhcPs)
ctx LHsContext GhcPs -> R ()
p_classContext
      [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
signatureSpans forall a b. (a -> b) -> a -> b
$
        Bool -> Bool -> R () -> [R ()] -> R ()
p_infixDefHelper
          (LexicalFixity -> Bool
isInfix LexicalFixity
fixity)
          Bool
True
          (LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
name)
          (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
hsq_explicit)
      R () -> R ()
inci ([LHsFunDep GhcPs] -> R ()
p_classFundeps [LHsFunDep GhcPs]
fdeps)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls) forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        Text -> R ()
txt Text
"where"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls) forall a b. (a -> b) -> a -> b
$ do
    R ()
breakpoint -- Ensure whitespace is added after where clause.
    R () -> R ()
inci (FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDeclsRespectGrouping FamilyStyle
Associated [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
allDecls)

p_classContext :: LHsContext GhcPs -> R ()
p_classContext :: LHsContext GhcPs -> R ()
p_classContext LHsContext GhcPs
ctx = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall l e. GenLocated l e -> e
unLoc LHsContext GhcPs
ctx)) forall a b. (a -> b) -> a -> b
$ do
  forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsContext GhcPs
ctx HsContext GhcPs -> R ()
p_hsContext
  R ()
space
  Text -> R ()
txt Text
"=>"
  R ()
breakpoint

p_classFundeps :: [LHsFunDep GhcPs] -> R ()
p_classFundeps :: [LHsFunDep GhcPs] -> R ()
p_classFundeps [LHsFunDep GhcPs]
fdeps = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsFunDep GhcPs]
fdeps) forall a b. (a -> b) -> a -> b
$ do
  R ()
breakpoint
  Text -> R ()
txt Text
"|"
  R ()
space
  R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (R () -> R ()
sitcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' FunDep GhcPs -> R ()
p_funDep) [LHsFunDep GhcPs]
fdeps

p_funDep :: FunDep GhcPs -> R ()
p_funDep :: FunDep GhcPs -> R ()
p_funDep (FunDep XCFunDep GhcPs
_ [LIdP GhcPs]
before [LIdP GhcPs]
after) = do
  forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space LocatedN RdrName -> R ()
p_rdrName [LIdP GhcPs]
before
  R ()
space
  Text -> R ()
txt Text
"->"
  R ()
space
  forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
space LocatedN RdrName -> R ()
p_rdrName [LIdP GhcPs]
after

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

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