@@ -28,24 +28,47 @@ import Ormolu.Printer.Meat.Declaration.Signature
2828import Ormolu.Printer.Meat.Declaration.Splice
2929import Ormolu.Printer.Meat.Declaration.Type
3030import Ormolu.Printer.Meat.Declaration.TypeFamily
31+import Data.List
3132import Ormolu.Printer.Meat.Declaration.Value
3233import Ormolu.Printer.Meat.Declaration.Warning
3334import Ormolu.Printer.Meat.Type
3435import Ormolu.Utils
3536import RdrName (rdrNameOcc)
37+import Data.List.NonEmpty (NonEmpty((:|)))
38+import qualified Data.List.NonEmpty as NE
3639
3740p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
38−p_hsDecls style decls = do
39− sepSemi (\(x, r) -> located x pDecl >> r) (separated decls)
41+p_hsDecls style decls = sepSemi id $
42+ -- Return a list of rendered declarations, adding a newline to separate
43+ -- groups.
44+ case groupDecls decls of
45+ [] -> []
46+ (x:xs) ->
47+ NE.toList (renderGroup x)
48+ ++ concatMap (NE.toList . separateGroup . renderGroup) xs
4049 where
41− pDecl = dontUseBraces . p_hsDecl style
42−
43− separated [] = []
44− separated [x] = [(x, return ())]
45− separated (x:y:xs) =
46− if separatedDecls (unLoc x) (unLoc y)
47− then (x, breakpoint') : separated (y:xs)
48− else (x, return ()) : separated (y:xs)
50+ renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style)
51+ separateGroup (x :| xs) = (breakpoint' >> x) :| xs
52+
53+-- | Group relevant declarations together.
54+--
55+-- Add a declaration to a group iff it is relevant to either the first or
56+-- the last declaration of the group.
57+
58+groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
59+groupDecls [] = []
60+groupDecls (lhdr:xs) =
61+ let -- Pick the first decl as the group header
62+ hdr = unLoc lhdr
63+ -- Zip rest of the decls with their previous decl
64+ zipped = zip (lhdr:xs) xs
65+ -- Pick decls from the tail if they are relevant to the group header
66+ -- or the previous decl.
67+ (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
68+ let relevantToHdr = groupedDecls hdr cur
69+ relevantToPrev = groupedDecls prev cur
70+ in relevantToHdr || relevantToPrev
71+ in (lhdr :| map snd grp) : groupDecls (map snd rest)
4972
5073p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
5174p_hsDecl style = \case
@@ -100,66 +123,120 @@ p_derivDecl = \case
100123 d@DerivDecl {..} -> p_standaloneDerivDecl d
101124 XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
102125
103−-- | Determine if these declarations should be separated by a blank line.
126+-- | Determine if these declarations should be grouped together.
104127
105−separatedDecls
128+groupedDecls
106129 :: HsDecl GhcPs
107130 -> HsDecl GhcPs
108131 -> Bool
109−separatedDecls (TypeSignature n) (FunctionBody n') = n /= n'
110−separatedDecls x (FunctionBody n) | Just n' <- isPragma x = n /= n'
111−separatedDecls (FunctionBody n) x | Just n' <- isPragma x = n /= n'
112−separatedDecls x (DataDeclaration n) | Just n' <- isPragma x = n /= n'
113−separatedDecls (DataDeclaration n) x | Just n' <- isPragma x =
114− let f = occNameFS . rdrNameOcc in f n /= f n'
115−separatedDecls x y | Just n <- isPragma x, Just n' <- isPragma y = n /= n'
116−separatedDecls x (TypeSignature n') | Just n <- isPragma x = n /= n'
117−separatedDecls (PatternSignature n) (Pattern n') = n /= n'
118−separatedDecls _ _ = True
132+groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
133+groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
134+groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
135+groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
136+groupedDecls (DataDeclaration n) x | Just ns <- isPragma x =
137+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns
138+groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
139+groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
140+groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns
141+groupedDecls _ _ = False
142+
143+intersects :: Ord a => [a] -> [a] -> Bool
144+intersects a b = go (sort a) (sort b)
145+ where
146+ go :: Ord a => [a] -> [a] -> Bool
147+ go _ [] = False
148+ go [] _ = False
149+ go (x:xs) (y:ys)
150+ | x < y = go xs (y:ys)
151+ | x > y = go (x:xs) ys
152+ | otherwise = True
119153
120154-- | Checks if given list of declarations contain a pair which should
121155-- be separated by a blank line.
122156
123−hasSeparatedDecls :: [HsDecl GhcPs] -> Bool
124−hasSeparatedDecls xs
125− = any (uncurry separatedDecls) $ zip xs (tail xs)
157+hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
158+hasSeparatedDecls xs = case groupDecls xs of
159+ _:_:_ -> True
160+ _ -> False
126161
127162isPragma
128163 :: HsDecl GhcPs
129− -> (Maybe RdrName)
164+ -> Maybe [RdrName]
130165isPragma = \case
131− InlinePragma n -> Just n
132− SpecializePragma n -> Just n
133− SCCPragma n -> Just n
134− AnnTypePragma n -> Just n
135− AnnValuePragma n -> Just n
166+ InlinePragma n -> Just [n]
167+ SpecializePragma n -> Just [n]
168+ SCCPragma n -> Just [n]
169+ AnnTypePragma n -> Just [n]
170+ AnnValuePragma n -> Just [n]
136171 WarningPragma n -> Just n
137172 _ -> Nothing
138173
139−pattern TypeSignature
140− , FunctionBody
141− , InlinePragma
174+-- Declarations referring to a single name
175+
176+pattern InlinePragma
142177 , SpecializePragma
143178 , SCCPragma
144179 , AnnTypePragma
145180 , AnnValuePragma
146− , PatternSignature
147181 , Pattern
148− , WarningPragma
149182 , DataDeclaration :: RdrName -> HsDecl GhcPs
150−pattern TypeSignature n <- (sigRdrName -> Just n)
151−pattern FunctionBody n <- ValD NoExt (FunBind NoExt (L _ n) _ _ _)
152183pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
153184pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
154185pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
155186pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
156187pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
157−pattern PatternSignature n <- SigD NoExt (PatSynSig NoExt ((L _ n):_) _)
158188pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
159−pattern WarningPragma n <- WarningD NoExt (Warnings NoExt _ [(L _ (Warning NoExt [(L _ n)] _))])
160189pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
161190
162−sigRdrName :: HsDecl GhcPs -> Maybe RdrName
163−sigRdrName (SigD NoExt (TypeSig NoExt ((L _ n):_) _)) = Just n
164−sigRdrName (SigD NoExt (ClassOpSig NoExt _ ((L _ n):_) _)) = Just n
165−sigRdrName _ = Nothing
191+-- Declarations which can refer to multiple names
192+
193+pattern TypeSignature
194+ , FunctionBody
195+ , PatternSignature
196+ , WarningPragma :: [RdrName] -> HsDecl GhcPs
197+pattern TypeSignature n <- (sigRdrNames -> Just n)
198+pattern FunctionBody n <- (funRdrNames -> Just n)
199+pattern PatternSignature n <- (patSigRdrNames -> Just n)
200+pattern WarningPragma n <- (warnSigRdrNames -> Just n)
201+
202+sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
203+sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns
204+sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns
205+sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
206+sigRdrNames _ = Nothing
207+
208+funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
209+funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
210+funRdrNames (ValD NoExt (PatBind NoExt (L _ n) _ _)) = Just $ patBindNames n
211+funRdrNames _ = Nothing
212+
213+patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
214+patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
215+patSigRdrNames _ = Nothing
216+
217+warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
218+warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
219+ L _ (Warning NoExt ns _) -> map unLoc ns
220+ L _ (XWarnDecl NoExt) -> []
221+warnSigRdrNames _ = Nothing
222+
223+patBindNames :: Pat GhcPs -> [RdrName]
224+patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps
225+patBindNames (VarPat NoExt (L _ n)) = [n]
226+patBindNames (WildPat NoExt) = []
227+patBindNames (LazyPat NoExt (L _ p)) = patBindNames p
228+patBindNames (BangPat NoExt (L _ p)) = patBindNames p
229+patBindNames (ParPat NoExt (L _ p)) = patBindNames p
230+patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
231+patBindNames (AsPat NoExt (L _ n) (L _ p)) = n : patBindNames p
232+patBindNames (SumPat NoExt (L _ p) _ _) = patBindNames p
233+patBindNames (ViewPat NoExt _ (L _ p)) = patBindNames p
234+patBindNames (SplicePat NoExt _) = []
235+patBindNames (LitPat NoExt _) = []
236+patBindNames (SigPat _ (L _ p)) = patBindNames p
237+patBindNames (NPat NoExt _ _ _) = []
238+patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]
239+patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
240+patBindNames (ConPatOut _ _ _ _ _ _ _) = notImplemented "ConPatOut" -- created by renamer
241+patBindNames (CoPat NoExt _ p _) = patBindNames p
242+patBindNames (XPat NoExt) = notImplemented "XPat"