1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE PatternSynonyms #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE ViewPatterns #-}
6
7-- | Rendering of declarations.
8module Ormolu.Printer.Meat.Declaration
9  ( p_hsDecls,
10    p_hsDeclsRespectGrouping,
11  )
12where
13
14import Data.List (sort)
15import Data.List.NonEmpty (NonEmpty (..), (<|))
16import qualified Data.List.NonEmpty as NE
17import GHC.Hs
18import GHC.Types.Name.Occurrence (occNameFS)
19import GHC.Types.Name.Reader
20import GHC.Types.SrcLoc
21import Ormolu.Config (SourceType (SignatureSource))
22import Ormolu.Printer.Combinators
23import Ormolu.Printer.Internal (askSourceType)
24import Ormolu.Printer.Meat.Common
25import Ormolu.Printer.Meat.Declaration.Annotation
26import Ormolu.Printer.Meat.Declaration.Class
27import Ormolu.Printer.Meat.Declaration.Data
28import Ormolu.Printer.Meat.Declaration.Default
29import Ormolu.Printer.Meat.Declaration.Foreign
30import Ormolu.Printer.Meat.Declaration.Instance
31import Ormolu.Printer.Meat.Declaration.RoleAnnotation
32import Ormolu.Printer.Meat.Declaration.Rule
33import Ormolu.Printer.Meat.Declaration.Signature
34import Ormolu.Printer.Meat.Declaration.Splice
35import Ormolu.Printer.Meat.Declaration.Type
36import Ormolu.Printer.Meat.Declaration.TypeFamily
37import Ormolu.Printer.Meat.Declaration.Value
38import Ormolu.Printer.Meat.Declaration.Warning
39import Ormolu.Printer.Meat.Type
40import Ormolu.Utils
41
42data UserGrouping
43  = -- | Always put newlines where we think they should be
44    Disregard
45  | -- | Respect user preferences regarding grouping
46    Respect
47  deriving (Eq, Show)
48
49p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
50p_hsDecls = p_hsDecls' Disregard
51
52-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the
53-- user omits newlines between declarations, we also omit them in most
54-- cases, except when said declarations have associated Haddocks.
55--
56-- Does some normalization (compress subsequent newlines into a single one)
57p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
58p_hsDeclsRespectGrouping = p_hsDecls' Respect
59
60p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
61p_hsDecls' grouping style decls = do
62  isSig <- (== SignatureSource) <$> askSourceType
63  sepSemi id $
64    -- Return a list of rendered declarations, adding a newline to separate
65    -- groups.
66    case groupDecls isSig decls of
67      [] -> []
68      (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
69  where
70    renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
71    renderGroupWithPrev prev curr =
72      -- We can omit a blank line when the user didn't add one, but we must
73      -- ensure we always add blank lines around documented declarations
74      case grouping of
75        Disregard ->
76          breakpoint : renderGroup curr
77        Respect ->
78          if separatedByBlankNE getLocA prev curr
79            || isDocumented prev
80            || isDocumented curr
81            then breakpoint : renderGroup curr
82            else renderGroup curr
83
84-- | Is a declaration group documented?
85isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
86isDocumented = any (isHaddock . unLoc)
87  where
88    isHaddock DocNext = True
89    isHaddock DocPrev = True
90    isHaddock _ = False
91
92-- | Group relevant declarations together.
93groupDecls ::
94  -- | Is the source a signature file?
95  Bool ->
96  -- | List of declarations
97  [LHsDecl GhcPs] ->
98  [NonEmpty (LHsDecl GhcPs)]
99groupDecls _ [] = []
100groupDecls isSig (l@(L _ DocNext) : xs) =
101  -- If the first element is a doc string for next element, just include it
102  -- in the next block:
103  case groupDecls isSig xs of
104    [] -> [l :| []]
105    (x : xs') -> (l <| x) : xs'
106groupDecls isSig (header : xs) =
107  let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->
108        let relevantToHdr = groupedDecls header current
109            relevantToPrev = groupedDecls previous current
110            isDeclSeries = not isSig && declSeries previous current
111         in isDeclSeries || relevantToHdr || relevantToPrev
112   in (header :| map snd grp) : groupDecls isSig (map snd rest)
113
114p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
115p_hsDecl style = \case
116  TyClD _ x -> p_tyClDecl style x
117  ValD _ x -> p_valDecl x
118  SigD _ x -> p_sigDecl x
119  InstD _ x -> p_instDecl style x
120  DerivD _ x -> p_standaloneDerivDecl x
121  DefD _ x -> p_defaultDecl x
122  ForD _ x -> p_foreignDecl x
123  WarningD _ x -> p_warnDecls x
124  AnnD _ x -> p_annDecl x
125  RuleD _ x -> p_ruleDecls x
126  SpliceD _ x -> p_spliceDecl x
127  DocD _ docDecl ->
128    case docDecl of
129      DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
130      DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
131      DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
132      DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
133  RoleAnnotD _ x -> p_roleAnnot x
134  KindSigD _ s -> p_standaloneKindSig s
135
136p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
137p_tyClDecl style = \case
138  FamDecl _ x -> p_famDecl style x
139  SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
140  DataDecl {..} ->
141    p_dataDecl
142      Associated
143      tcdLName
144      (tyVarsToTyPats tcdTyVars)
145      tcdFixity
146      tcdDataDefn
147  ClassDecl {..} ->
148    p_classDecl
149      tcdCtxt
150      tcdLName
151      tcdTyVars
152      tcdFixity
153      tcdFDs
154      tcdSigs
155      tcdMeths
156      tcdATs
157      tcdATDefs
158      tcdDocs
159
160p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
161p_instDecl style = \case
162  ClsInstD _ x -> p_clsInstDecl x
163  TyFamInstD _ x -> p_tyFamInstDecl style x
164  DataFamInstD _ x -> p_dataFamInstDecl style x
165
166-- | Determine if these declarations should be grouped together.
167groupedDecls ::
168  LHsDecl GhcPs ->
169  LHsDecl GhcPs ->
170  Bool
171groupedDecls (L (locA -> l_x) x') (L (locA -> l_y) y') =
172  case (x', y') of
173    (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'
174    (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'
175    (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'
176    (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'
177    (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'
178    (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
179    (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns
180    (DataDeclaration n, x)
181      | Just ns <- isPragma x ->
182          let f = occNameFS . rdrNameOcc in f n `elem` map f ns
183    (x, y)
184      | Just ns <- isPragma x,
185        Just ns' <- isPragma y ->
186          ns `intersects` ns'
187    (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'
188    (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
189    (PatternSignature ns, Pattern n) -> n `elem` ns
190    (KindSignature n, DataDeclaration n') -> n == n'
191    (KindSignature n, ClassDeclaration n') -> n == n'
192    (KindSignature n, FamilyDeclaration n') -> n == n'
193    (KindSignature n, TypeSynonym n') -> n == n'
194    -- Special case for TH splices, we look at locations
195    (Splice, Splice) -> not (separatedByBlank id l_x l_y)
196    -- This looks only at Haddocks, normal comments are handled elsewhere
197    (DocNext, _) -> True
198    (_, DocPrev) -> True
199    _ -> False
200
201-- | Detect declaration series that should not have blanks between them.
202declSeries ::
203  LHsDecl GhcPs ->
204  LHsDecl GhcPs ->
205  Bool
206declSeries (L _ x) (L _ y) =
207  case (x, y) of
208    ( SigD _ (TypeSig _ _ _),
209      SigD _ (TypeSig _ _ _)
210      ) -> True
211    _ -> False
212
213intersects :: Ord a => [a] -> [a] -> Bool
214intersects a b = go (sort a) (sort b)
215  where
216    go :: Ord a => [a] -> [a] -> Bool
217    go _ [] = False
218    go [] _ = False
219    go (x : xs) (y : ys)
220      | x < y = go xs (y : ys)
221      | x > y = go (x : xs) ys
222      | otherwise = True
223
224isPragma ::
225  HsDecl GhcPs ->
226  Maybe [RdrName]
227isPragma = \case
228  InlinePragma n -> Just [n]
229  SpecializePragma n -> Just [n]
230  SCCPragma n -> Just [n]
231  AnnTypePragma n -> Just [n]
232  AnnValuePragma n -> Just [n]
233  WarningPragma n -> Just n
234  _ -> Nothing
235
236-- Declarations that do not refer to names
237
238pattern Splice :: HsDecl GhcPs
239pattern Splice <- SpliceD _ (SpliceDecl _ _ _)
240
241-- Declarations referring to a single name
242
243pattern
244  InlinePragma,
245  SpecializePragma,
246  SCCPragma,
247  AnnTypePragma,
248  AnnValuePragma,
249  Pattern,
250  DataDeclaration,
251  ClassDeclaration,
252  KindSignature,
253  FamilyDeclaration,
254  TypeSynonym ::
255    RdrName -> HsDecl GhcPs
256pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _)
257pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _)
258pattern SCCPragma n <- SigD _ (SCCFunSig _ _ (L _ n) _)
259pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ _ (TypeAnnProvenance (L _ n)) _)
260pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ _ (ValueAnnProvenance (L _ n)) _)
261pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _))
262pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _)
263pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _)
264pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _)
265pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _))
266pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _)
267
268-- Declarations which can refer to multiple names
269
270pattern
271  TypeSignature,
272  DefaultSignature,
273  FunctionBody,
274  PatternSignature,
275  WarningPragma ::
276    [RdrName] -> HsDecl GhcPs
277pattern TypeSignature n <- (sigRdrNames -> Just n)
278pattern DefaultSignature n <- (defSigRdrNames -> Just n)
279pattern FunctionBody n <- (funRdrNames -> Just n)
280pattern PatternSignature n <- (patSigRdrNames -> Just n)
281pattern WarningPragma n <- (warnSigRdrNames -> Just n)
282
283pattern DocNext, DocPrev :: HsDecl GhcPs
284pattern DocNext <- (DocD _ (DocCommentNext _))
285pattern DocPrev <- (DocD _ (DocCommentPrev _))
286
287sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
288sigRdrNames (SigD _ (TypeSig _ ns _)) = Just $ map unLoc ns
289sigRdrNames (SigD _ (ClassOpSig _ _ ns _)) = Just $ map unLoc ns
290sigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns
291sigRdrNames _ = Nothing
292
293defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
294defSigRdrNames (SigD _ (ClassOpSig _ True ns _)) = Just $ map unLoc ns
295defSigRdrNames _ = Nothing
296
297funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
298funRdrNames (ValD _ (FunBind _ (L _ n) _ _)) = Just [n]
299funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n
300funRdrNames _ = Nothing
301
302patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
303patSigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns
304patSigRdrNames _ = Nothing
305
306warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
307warnSigRdrNames (WarningD _ (Warnings _ _ ws)) = Just $
308  flip concatMap ws $ \(L _ (Warning _ ns _)) -> map unLoc ns
309warnSigRdrNames _ = Nothing
310
311patBindNames :: Pat GhcPs -> [RdrName]
312patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps
313patBindNames (VarPat _ (L _ n)) = [n]
314patBindNames (WildPat _) = []
315patBindNames (LazyPat _ (L _ p)) = patBindNames p
316patBindNames (BangPat _ (L _ p)) = patBindNames p
317patBindNames (ParPat _ (L _ p)) = patBindNames p
318patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps
319patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p
320patBindNames (SumPat _ (L _ p) _ _) = patBindNames p
321patBindNames (ViewPat _ _ (L _ p)) = patBindNames p
322patBindNames (SplicePat _ _) = []
323patBindNames (LitPat _ _) = []
324patBindNames (SigPat _ (L _ p) _) = patBindNames p
325patBindNames (NPat _ _ _ _) = []
326patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n]
327patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
328