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

-- | Rendering of declarations.
module Ormolu.Printer.Meat.Declaration
  ( p_hsDecls,
    p_hsDeclsRespectGrouping,
  )
where

import Data.List (sort)
import Data.List.NonEmpty ((<|), NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import GHC hiding (InlinePragma)
import OccName (occNameFS)
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Annotation
import Ormolu.Printer.Meat.Declaration.Class
import Ormolu.Printer.Meat.Declaration.Data
import Ormolu.Printer.Meat.Declaration.Default
import Ormolu.Printer.Meat.Declaration.Foreign
import Ormolu.Printer.Meat.Declaration.Instance
import Ormolu.Printer.Meat.Declaration.RoleAnnotation
import Ormolu.Printer.Meat.Declaration.Rule
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Printer.Meat.Declaration.Splice
import Ormolu.Printer.Meat.Declaration.Type
import Ormolu.Printer.Meat.Declaration.TypeFamily
import Ormolu.Printer.Meat.Declaration.Value
import Ormolu.Printer.Meat.Declaration.Warning
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
import RdrName (rdrNameOcc)

data UserGrouping
  = -- | Always put newlines where we think they should be
    Disregard
  | -- | Respect user preferences regarding grouping
    Respect
  deriving (UserGrouping -> UserGrouping -> Bool
(UserGrouping -> UserGrouping -> Bool)
-> (UserGrouping -> UserGrouping -> Bool) -> Eq UserGrouping
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserGrouping -> UserGrouping -> Bool
$c/= :: UserGrouping -> UserGrouping -> Bool
== :: UserGrouping -> UserGrouping -> Bool
$c== :: UserGrouping -> UserGrouping -> Bool
Eq, Int -> UserGrouping -> ShowS
[UserGrouping] -> ShowS
UserGrouping -> String
(Int -> UserGrouping -> ShowS)
-> (UserGrouping -> String)
-> ([UserGrouping] -> ShowS)
-> Show UserGrouping
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserGrouping] -> ShowS
$cshowList :: [UserGrouping] -> ShowS
show :: UserGrouping -> String
$cshow :: UserGrouping -> String
showsPrec :: Int -> UserGrouping -> ShowS
$cshowsPrec :: Int -> UserGrouping -> ShowS
Show)

p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls = UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls' UserGrouping
Disregard

-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the
-- user omits newlines between declarations, we also omit them in most
-- cases, except when said declarations have associated Haddocks.
--
-- Does some normalization (compress subsequent newlines into a single one)
p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDeclsRespectGrouping = UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls' UserGrouping
Respect

p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls' grouping :: UserGrouping
grouping style :: FamilyStyle
style decls :: [LHsDecl GhcPs]
decls = (R () -> R ()) -> [R ()] -> R ()
forall a. (a -> R ()) -> [a] -> R ()
sepSemi R () -> R ()
forall a. a -> a
id ([R ()] -> R ()) -> [R ()] -> R ()
forall a b. (a -> b) -> a -> b
$
  -- Return a list of rendered declarations, adding a newline to separate
  -- groups.
  case [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls [LHsDecl GhcPs]
decls of
    [] -> []
    (x :: NonEmpty (LHsDecl GhcPs)
x : xs :: [NonEmpty (LHsDecl GhcPs)]
xs) -> NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroup NonEmpty (LHsDecl GhcPs)
x [R ()] -> [R ()] -> [R ()]
forall a. [a] -> [a] -> [a]
++ [[R ()]] -> [R ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((NonEmpty (LHsDecl GhcPs) -> NonEmpty (LHsDecl GhcPs) -> [R ()])
-> [NonEmpty (LHsDecl GhcPs)]
-> [NonEmpty (LHsDecl GhcPs)]
-> [[R ()]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NonEmpty (LHsDecl GhcPs) -> NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroupWithPrev (NonEmpty (LHsDecl GhcPs)
x NonEmpty (LHsDecl GhcPs)
-> [NonEmpty (LHsDecl GhcPs)] -> [NonEmpty (LHsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [NonEmpty (LHsDecl GhcPs)]
xs) [NonEmpty (LHsDecl GhcPs)]
xs)
  where
    renderGroup :: NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroup = NonEmpty (R ()) -> [R ()]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (R ()) -> [R ()])
-> (NonEmpty (LHsDecl GhcPs) -> NonEmpty (R ()))
-> NonEmpty (LHsDecl GhcPs)
-> [R ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsDecl GhcPs -> R ())
-> NonEmpty (LHsDecl GhcPs) -> NonEmpty (R ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsDecl GhcPs -> R ()) -> LHsDecl GhcPs -> R ()
forall a. Data a => (a -> R ()) -> Located a -> R ()
located' ((HsDecl GhcPs -> R ()) -> LHsDecl GhcPs -> R ())
-> (HsDecl GhcPs -> R ()) -> LHsDecl GhcPs -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
dontUseBraces (R () -> R ()) -> (HsDecl GhcPs -> R ()) -> HsDecl GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyStyle -> HsDecl GhcPs -> R ()
p_hsDecl FamilyStyle
style)
    renderGroupWithPrev :: NonEmpty (LHsDecl GhcPs) -> NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroupWithPrev prev :: NonEmpty (LHsDecl GhcPs)
prev curr :: NonEmpty (LHsDecl GhcPs)
curr =
      -- We can omit a blank line when the user didn't add one, but we must
      -- ensure we always add blank lines around documented declarations
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ UserGrouping
grouping UserGrouping -> UserGrouping -> Bool
forall a. Eq a => a -> a -> Bool
== UserGrouping
Disregard,
          (LHsDecl GhcPs -> SrcSpan)
-> NonEmpty (LHsDecl GhcPs) -> NonEmpty (LHsDecl GhcPs) -> Bool
forall a. (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlank LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc NonEmpty (LHsDecl GhcPs)
prev NonEmpty (LHsDecl GhcPs)
curr,
          NonEmpty (LHsDecl GhcPs) -> Bool
isDocumented NonEmpty (LHsDecl GhcPs)
prev,
          NonEmpty (LHsDecl GhcPs) -> Bool
isDocumented NonEmpty (LHsDecl GhcPs)
curr
        ]
        then R ()
breakpoint R () -> [R ()] -> [R ()]
forall a. a -> [a] -> [a]
: NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroup NonEmpty (LHsDecl GhcPs)
curr
        else NonEmpty (LHsDecl GhcPs) -> [R ()]
renderGroup NonEmpty (LHsDecl GhcPs)
curr

-- | Is a declaration group documented?
isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
isDocumented = (LHsDecl GhcPs -> Bool) -> NonEmpty (LHsDecl GhcPs) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsDecl GhcPs -> Bool
isHaddock (HsDecl GhcPs -> Bool)
-> (LHsDecl GhcPs -> HsDecl GhcPs) -> LHsDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDecl GhcPs -> HsDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
  where
    isHaddock :: HsDecl GhcPs -> Bool
isHaddock DocNext = Bool
True
    isHaddock DocPrev = Bool
True
    isHaddock _ = Bool
False

-- | Group relevant declarations together.
--
-- Add a declaration to a group iff it is relevant to either the first or
-- the last declaration of the group.
groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls [] = []
groupDecls (l :: LHsDecl GhcPs
l@(L _ DocNext) : xs :: [LHsDecl GhcPs]
xs) =
  -- If the first element is a doc string for next element, just include it
  -- in the next block:
  case [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls [LHsDecl GhcPs]
xs of
    [] -> [LHsDecl GhcPs
l LHsDecl GhcPs -> [LHsDecl GhcPs] -> NonEmpty (LHsDecl GhcPs)
forall a. a -> [a] -> NonEmpty a
:| []]
    (x :: NonEmpty (LHsDecl GhcPs)
x : xs' :: [NonEmpty (LHsDecl GhcPs)]
xs') -> (LHsDecl GhcPs
l LHsDecl GhcPs
-> NonEmpty (LHsDecl GhcPs) -> NonEmpty (LHsDecl GhcPs)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (LHsDecl GhcPs)
x) NonEmpty (LHsDecl GhcPs)
-> [NonEmpty (LHsDecl GhcPs)] -> [NonEmpty (LHsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [NonEmpty (LHsDecl GhcPs)]
xs'
groupDecls (lhdr :: LHsDecl GhcPs
lhdr : xs :: [LHsDecl GhcPs]
xs) =
  let -- Pick the first decl as the group header
      hdr :: SrcSpanLess (LHsDecl GhcPs)
hdr = LHsDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsDecl GhcPs
lhdr
      -- Zip rest of the decls with their previous decl
      zipped :: [(LHsDecl GhcPs, LHsDecl GhcPs)]
zipped = [LHsDecl GhcPs]
-> [LHsDecl GhcPs] -> [(LHsDecl GhcPs, LHsDecl GhcPs)]
forall a b. [a] -> [b] -> [(a, b)]
zip (LHsDecl GhcPs
lhdr LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
xs) [LHsDecl GhcPs]
xs
      -- Pick decls from the tail if they are relevant to the group header
      -- or the previous decl.
      (grp :: [(LHsDecl GhcPs, LHsDecl GhcPs)]
grp, rest :: [(LHsDecl GhcPs, LHsDecl GhcPs)]
rest) = (((LHsDecl GhcPs, LHsDecl GhcPs) -> Bool)
 -> [(LHsDecl GhcPs, LHsDecl GhcPs)]
 -> ([(LHsDecl GhcPs, LHsDecl GhcPs)],
     [(LHsDecl GhcPs, LHsDecl GhcPs)]))
-> [(LHsDecl GhcPs, LHsDecl GhcPs)]
-> ((LHsDecl GhcPs, LHsDecl GhcPs) -> Bool)
-> ([(LHsDecl GhcPs, LHsDecl GhcPs)],
    [(LHsDecl GhcPs, LHsDecl GhcPs)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((LHsDecl GhcPs, LHsDecl GhcPs) -> Bool)
-> [(LHsDecl GhcPs, LHsDecl GhcPs)]
-> ([(LHsDecl GhcPs, LHsDecl GhcPs)],
    [(LHsDecl GhcPs, LHsDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span [(LHsDecl GhcPs, LHsDecl GhcPs)]
zipped (((LHsDecl GhcPs, LHsDecl GhcPs) -> Bool)
 -> ([(LHsDecl GhcPs, LHsDecl GhcPs)],
     [(LHsDecl GhcPs, LHsDecl GhcPs)]))
-> ((LHsDecl GhcPs, LHsDecl GhcPs) -> Bool)
-> ([(LHsDecl GhcPs, LHsDecl GhcPs)],
    [(LHsDecl GhcPs, LHsDecl GhcPs)])
forall a b. (a -> b) -> a -> b
$ \(L _ prev :: HsDecl GhcPs
prev, L _ cur :: HsDecl GhcPs
cur) ->
        let relevantToHdr :: Bool
relevantToHdr = HsDecl GhcPs -> HsDecl GhcPs -> Bool
groupedDecls HsDecl GhcPs
hdr HsDecl GhcPs
cur
            relevantToPrev :: Bool
relevantToPrev = HsDecl GhcPs -> HsDecl GhcPs -> Bool
groupedDecls HsDecl GhcPs
prev HsDecl GhcPs
cur
         in Bool
relevantToHdr Bool -> Bool -> Bool
|| Bool
relevantToPrev
   in (LHsDecl GhcPs
lhdr LHsDecl GhcPs -> [LHsDecl GhcPs] -> NonEmpty (LHsDecl GhcPs)
forall a. a -> [a] -> NonEmpty a
:| ((LHsDecl GhcPs, LHsDecl GhcPs) -> LHsDecl GhcPs)
-> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (LHsDecl GhcPs, LHsDecl GhcPs) -> LHsDecl GhcPs
forall a b. (a, b) -> b
snd [(LHsDecl GhcPs, LHsDecl GhcPs)]
grp) NonEmpty (LHsDecl GhcPs)
-> [NonEmpty (LHsDecl GhcPs)] -> [NonEmpty (LHsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls (((LHsDecl GhcPs, LHsDecl GhcPs) -> LHsDecl GhcPs)
-> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (LHsDecl GhcPs, LHsDecl GhcPs) -> LHsDecl GhcPs
forall a b. (a, b) -> b
snd [(LHsDecl GhcPs, LHsDecl GhcPs)]
rest)

p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
p_hsDecl style :: FamilyStyle
style = \case
  TyClD NoExt x :: TyClDecl GhcPs
x -> FamilyStyle -> TyClDecl GhcPs -> R ()
p_tyClDecl FamilyStyle
style TyClDecl GhcPs
x
  ValD NoExt x :: HsBind GhcPs
x -> HsBind GhcPs -> R ()
p_valDecl HsBind GhcPs
x
  SigD NoExt x :: Sig GhcPs
x -> Sig GhcPs -> R ()
p_sigDecl Sig GhcPs
x
  InstD NoExt x :: InstDecl GhcPs
x -> FamilyStyle -> InstDecl GhcPs -> R ()
p_instDecl FamilyStyle
style InstDecl GhcPs
x
  DerivD NoExt x :: DerivDecl GhcPs
x -> DerivDecl GhcPs -> R ()
p_derivDecl DerivDecl GhcPs
x
  DefD NoExt x :: DefaultDecl GhcPs
x -> DefaultDecl GhcPs -> R ()
p_defaultDecl DefaultDecl GhcPs
x
  ForD NoExt x :: ForeignDecl GhcPs
x -> ForeignDecl GhcPs -> R ()
p_foreignDecl ForeignDecl GhcPs
x
  WarningD NoExt x :: WarnDecls GhcPs
x -> WarnDecls GhcPs -> R ()
p_warnDecls WarnDecls GhcPs
x
  AnnD NoExt x :: AnnDecl GhcPs
x -> AnnDecl GhcPs -> R ()
p_annDecl AnnDecl GhcPs
x
  RuleD NoExt x :: RuleDecls GhcPs
x -> RuleDecls GhcPs -> R ()
p_ruleDecls RuleDecls GhcPs
x
  SpliceD NoExt x :: SpliceDecl GhcPs
x -> SpliceDecl GhcPs -> R ()
p_spliceDecl SpliceDecl GhcPs
x
  DocD NoExt docDecl :: DocDecl
docDecl ->
    case DocDecl
docDecl of
      DocCommentNext str :: HsDocString
str -> HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
      DocCommentPrev str :: HsDocString
str -> HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Caret Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
      DocCommentNamed name :: String
name str :: HsDocString
str -> HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString (String -> HaddockStyle
Named String
name) Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
      DocGroup n :: Int
n str :: HsDocString
str -> HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString (Int -> HaddockStyle
Asterisk Int
n) Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
  RoleAnnotD NoExt x :: RoleAnnotDecl GhcPs
x -> RoleAnnotDecl GhcPs -> R ()
p_roleAnnot RoleAnnotDecl GhcPs
x
  XHsDecl _ -> String -> R ()
forall a. String -> a
notImplemented "XHsDecl"

p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
p_tyClDecl style :: FamilyStyle
style = \case
  FamDecl NoExt x :: FamilyDecl GhcPs
x -> FamilyStyle -> FamilyDecl GhcPs -> R ()
p_famDecl FamilyStyle
style FamilyDecl GhcPs
x
  SynDecl {..} -> Located RdrName
-> LexicalFixity -> LHsQTyVars GhcPs -> LHsType GhcPs -> R ()
p_synDecl Located (IdP GhcPs)
Located RdrName
tcdLName LexicalFixity
tcdFixity LHsQTyVars GhcPs
tcdTyVars LHsType GhcPs
tcdRhs
  DataDecl {..} ->
    FamilyStyle
-> Located RdrName
-> [LHsType GhcPs]
-> LexicalFixity
-> HsDataDefn GhcPs
-> R ()
p_dataDecl
      FamilyStyle
Associated
      Located (IdP GhcPs)
Located RdrName
tcdLName
      (LHsQTyVars GhcPs -> [LHsType GhcPs]
tyVarsToTypes LHsQTyVars GhcPs
tcdTyVars)
      LexicalFixity
tcdFixity
      HsDataDefn GhcPs
tcdDataDefn
  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
tcdCtxt
      Located (IdP GhcPs)
Located RdrName
tcdLName
      LHsQTyVars GhcPs
tcdTyVars
      LexicalFixity
tcdFixity
      [LHsFunDep GhcPs]
[Located (FunDep (Located RdrName))]
tcdFDs
      [LSig GhcPs]
tcdSigs
      LHsBinds GhcPs
tcdMeths
      [LFamilyDecl GhcPs]
tcdATs
      [LTyFamDefltEqn GhcPs]
tcdATDefs
      [LDocDecl]
tcdDocs
  XTyClDecl {} -> String -> R ()
forall a. String -> a
notImplemented "XTyClDecl"

p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
p_instDecl style :: FamilyStyle
style = \case
  ClsInstD NoExt x :: ClsInstDecl GhcPs
x -> ClsInstDecl GhcPs -> R ()
p_clsInstDecl ClsInstDecl GhcPs
x
  TyFamInstD NoExt x :: TyFamInstDecl GhcPs
x -> FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl FamilyStyle
style TyFamInstDecl GhcPs
x
  DataFamInstD NoExt x :: DataFamInstDecl GhcPs
x -> FamilyStyle -> DataFamInstDecl GhcPs -> R ()
p_dataFamInstDecl FamilyStyle
style DataFamInstDecl GhcPs
x
  XInstDecl _ -> String -> R ()
forall a. String -> a
notImplemented "XInstDecl"

p_derivDecl :: DerivDecl GhcPs -> R ()
p_derivDecl :: DerivDecl GhcPs -> R ()
p_derivDecl = \case
  d :: DerivDecl GhcPs
d@DerivDecl {..} -> DerivDecl GhcPs -> R ()
p_standaloneDerivDecl DerivDecl GhcPs
d
  XDerivDecl _ -> String -> R ()
forall a. String -> a
notImplemented "XDerivDecl standalone deriving"

-- | Determine if these declarations should be grouped together.
groupedDecls ::
  HsDecl GhcPs ->
  HsDecl GhcPs ->
  Bool
groupedDecls :: HsDecl GhcPs -> HsDecl GhcPs -> Bool
groupedDecls (TypeSignature ns :: [RdrName]
ns) (FunctionBody ns' :: [RdrName]
ns') = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (TypeSignature ns :: [RdrName]
ns) (DefaultSignature ns' :: [RdrName]
ns') = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (DefaultSignature ns :: [RdrName]
ns) (TypeSignature ns' :: [RdrName]
ns') = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (DefaultSignature ns :: [RdrName]
ns) (FunctionBody ns' :: [RdrName]
ns') = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls x :: HsDecl GhcPs
x (FunctionBody ns :: [RdrName]
ns) | Just ns' :: [RdrName]
ns' <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (FunctionBody ns :: [RdrName]
ns) x :: HsDecl GhcPs
x | Just ns' :: [RdrName]
ns' <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls x :: HsDecl GhcPs
x (DataDeclaration n :: RdrName
n) | Just ns :: [RdrName]
ns <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x = RdrName
n RdrName -> [RdrName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RdrName]
ns
groupedDecls (DataDeclaration n :: RdrName
n) x :: HsDecl GhcPs
x
  | Just ns :: [RdrName]
ns <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x =
    let f :: RdrName -> FastString
f = OccName -> FastString
occNameFS (OccName -> FastString)
-> (RdrName -> OccName) -> RdrName -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc in RdrName -> FastString
f RdrName
n FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (RdrName -> FastString) -> [RdrName] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> FastString
f [RdrName]
ns
groupedDecls x :: HsDecl GhcPs
x y :: HsDecl GhcPs
y | Just ns :: [RdrName]
ns <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x, Just ns' :: [RdrName]
ns' <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
y = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls x :: HsDecl GhcPs
x (TypeSignature ns :: [RdrName]
ns) | Just ns' :: [RdrName]
ns' <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (TypeSignature ns :: [RdrName]
ns) x :: HsDecl GhcPs
x | Just ns' :: [RdrName]
ns' <- HsDecl GhcPs -> Maybe [RdrName]
isPragma HsDecl GhcPs
x = [RdrName]
ns [RdrName] -> [RdrName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`intersects` [RdrName]
ns'
groupedDecls (PatternSignature ns :: [RdrName]
ns) (Pattern n :: RdrName
n) = RdrName
n RdrName -> [RdrName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RdrName]
ns
-- This looks only at Haddocks, normal comments are handled elsewhere
groupedDecls DocNext _ = Bool
True
groupedDecls _ DocPrev = Bool
True
groupedDecls _ _ = Bool
False

intersects :: Ord a => [a] -> [a] -> Bool
intersects :: [a] -> [a] -> Bool
intersects a :: [a]
a b :: [a]
b = [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
go ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
a) ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
b)
  where
    go :: Ord a => [a] -> [a] -> Bool
    go :: [a] -> [a] -> Bool
go _ [] = Bool
False
    go [] _ = Bool
False
    go (x :: a
x : xs :: [a]
xs) (y :: a
y : ys :: [a]
ys)
      | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
go [a]
xs (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)
      | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y = [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
go (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [a]
ys
      | Bool
otherwise = Bool
True

isPragma ::
  HsDecl GhcPs ->
  Maybe [RdrName]
isPragma :: HsDecl GhcPs -> Maybe [RdrName]
isPragma = \case
  InlinePragma n :: RdrName
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName
n]
  SpecializePragma n :: RdrName
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName
n]
  SCCPragma n :: RdrName
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName
n]
  AnnTypePragma n :: RdrName
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName
n]
  AnnValuePragma n :: RdrName
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName
n]
  WarningPragma n :: [RdrName]
n -> [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [RdrName]
n
  _ -> Maybe [RdrName]
forall a. Maybe a
Nothing

-- Declarations referring to a single name

pattern
  InlinePragma,
  SpecializePragma,
  SCCPragma,
  AnnTypePragma,
  AnnValuePragma,
  Pattern,
  DataDeclaration ::
    RdrName -> HsDecl GhcPs
pattern $mInlinePragma :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
pattern $mSpecializePragma :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
pattern $mSCCPragma :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
pattern $mAnnTypePragma :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
pattern $mAnnValuePragma :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
pattern $mPattern :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
pattern $mDataDeclaration :: forall r. HsDecl GhcPs -> (RdrName -> r) -> (Void# -> r) -> r
DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)

-- Declarations which can refer to multiple names

pattern
  TypeSignature,
  DefaultSignature,
  FunctionBody,
  PatternSignature,
  WarningPragma ::
    [RdrName] -> HsDecl GhcPs
pattern $mTypeSignature :: forall r. HsDecl GhcPs -> ([RdrName] -> r) -> (Void# -> r) -> r
TypeSignature n <- (sigRdrNames -> Just n)
pattern $mDefaultSignature :: forall r. HsDecl GhcPs -> ([RdrName] -> r) -> (Void# -> r) -> r
DefaultSignature n <- (defSigRdrNames -> Just n)
pattern $mFunctionBody :: forall r. HsDecl GhcPs -> ([RdrName] -> r) -> (Void# -> r) -> r
FunctionBody n <- (funRdrNames -> Just n)
pattern $mPatternSignature :: forall r. HsDecl GhcPs -> ([RdrName] -> r) -> (Void# -> r) -> r
PatternSignature n <- (patSigRdrNames -> Just n)
pattern $mWarningPragma :: forall r. HsDecl GhcPs -> ([RdrName] -> r) -> (Void# -> r) -> r
WarningPragma n <- (warnSigRdrNames -> Just n)

pattern DocNext, DocPrev :: HsDecl GhcPs
pattern $mDocNext :: forall r. HsDecl GhcPs -> (Void# -> r) -> (Void# -> r) -> r
DocNext <- (DocD NoExt (DocCommentNext _))
pattern $mDocPrev :: forall r. HsDecl GhcPs -> (Void# -> r) -> (Void# -> r) -> r
DocPrev <- (DocD NoExt (DocCommentPrev _))

sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
sigRdrNames (SigD NoExt (TypeSig NoExt ns :: [Located (IdP GhcPs)]
ns _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns :: [Located (IdP GhcPs)]
ns _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
sigRdrNames (SigD NoExt (PatSynSig NoExt ns :: [Located (IdP GhcPs)]
ns _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
sigRdrNames _ = Maybe [RdrName]
forall a. Maybe a
Nothing

defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
defSigRdrNames (SigD NoExt (ClassOpSig NoExt True ns :: [Located (IdP GhcPs)]
ns _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
defSigRdrNames _ = Maybe [RdrName]
forall a. Maybe a
Nothing

funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
funRdrNames (ValD NoExt (FunBind NoExt (L _ n :: IdP GhcPs
n) _ _ _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just [IdP GhcPs
RdrName
n]
funRdrNames (ValD NoExt (PatBind NoExt n :: LPat GhcPs
n _ _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
n
funRdrNames _ = Maybe [RdrName]
forall a. Maybe a
Nothing

patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
patSigRdrNames (SigD NoExt (PatSynSig NoExt ns :: [Located (IdP GhcPs)]
ns _)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
patSigRdrNames _ = Maybe [RdrName]
forall a. Maybe a
Nothing

warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws :: [LWarnDecl GhcPs]
ws)) = [RdrName] -> Maybe [RdrName]
forall a. a -> Maybe a
Just ([RdrName] -> Maybe [RdrName]) -> [RdrName] -> Maybe [RdrName]
forall a b. (a -> b) -> a -> b
$ ((LWarnDecl GhcPs -> [RdrName]) -> [LWarnDecl GhcPs] -> [RdrName])
-> [LWarnDecl GhcPs] -> (LWarnDecl GhcPs -> [RdrName]) -> [RdrName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LWarnDecl GhcPs -> [RdrName]) -> [LWarnDecl GhcPs] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [LWarnDecl GhcPs]
ws ((LWarnDecl GhcPs -> [RdrName]) -> [RdrName])
-> (LWarnDecl GhcPs -> [RdrName]) -> [RdrName]
forall a b. (a -> b) -> a -> b
$ \case
  L _ (Warning NoExt ns :: [Located (IdP GhcPs)]
ns _) -> (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (IdP GhcPs)]
[Located RdrName]
ns
  L _ (XWarnDecl NoExt) -> []
warnSigRdrNames _ = Maybe [RdrName]
forall a. Maybe a
Nothing

patBindNames :: Pat GhcPs -> [RdrName]
patBindNames :: LPat GhcPs -> [RdrName]
patBindNames (TuplePat NoExt ps :: [LPat GhcPs]
ps _) = (LPat GhcPs -> [RdrName]) -> [LPat GhcPs] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LPat GhcPs -> [RdrName]
patBindNames (LPat GhcPs -> [RdrName])
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> LPat GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LPat GhcPs]
ps
patBindNames (VarPat NoExt (L _ n :: IdP GhcPs
n)) = [IdP GhcPs
RdrName
n]
patBindNames (WildPat NoExt) = []
patBindNames (LazyPat NoExt p :: LPat GhcPs
p) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (BangPat NoExt p :: LPat GhcPs
p) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (ParPat NoExt p :: LPat GhcPs
p) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (ListPat NoExt ps :: [LPat GhcPs]
ps) = (LPat GhcPs -> [RdrName]) -> [LPat GhcPs] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LPat GhcPs -> [RdrName]
patBindNames (LPat GhcPs -> [RdrName])
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> LPat GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LPat GhcPs]
ps
patBindNames (AsPat NoExt (L _ n :: IdP GhcPs
n) p :: LPat GhcPs
p) = IdP GhcPs
RdrName
n RdrName -> [RdrName] -> [RdrName]
forall a. a -> [a] -> [a]
: LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (SumPat NoExt p :: LPat GhcPs
p _ _) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (ViewPat NoExt _ p :: LPat GhcPs
p) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (SplicePat NoExt _) = []
patBindNames (LitPat NoExt _) = []
patBindNames (SigPat _ p :: LPat GhcPs
p _) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (NPat NoExt _ _ _) = []
patBindNames (NPlusKPat NoExt (L _ n :: IdP GhcPs
n) _ _ _ _) = [IdP GhcPs
RdrName
n]
patBindNames (ConPatIn _ d :: HsConPatDetails GhcPs
d) = (LPat GhcPs -> [RdrName]) -> [LPat GhcPs] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LPat GhcPs -> [RdrName]
patBindNames (LPat GhcPs -> [RdrName])
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> LPat GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (HsConPatDetails GhcPs -> [LPat GhcPs]
forall p. HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails GhcPs
d)
patBindNames ConPatOut {} = String -> [RdrName]
forall a. String -> a
notImplemented "ConPatOut" -- created by renamer
patBindNames (CoPat NoExt _ p :: LPat GhcPs
p _) = LPat GhcPs -> [RdrName]
patBindNames LPat GhcPs
p
patBindNames (XPat p :: XXPat GhcPs
p) = LPat GhcPs -> [RdrName]
patBindNames (Located (LPat GhcPs) -> SrcSpanLess (Located (LPat GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc XXPat GhcPs
Located (LPat GhcPs)
p)