c364a30 · ormolu · git.iko.soy

git.iko.soy/ormolu

on master help sign in

Preserve grouping of TH splices

c364a30Mark Karpov7 years ago

data/examples/declaration/splice/grouped-splices-out.hsnew file+3

compare with master

unifiedsplit

@@ -0,0 +1,3 @@

1+$(deriveJSON fieldLabelMod ''A)

2+$(deriveJSON fieldLabelMod ''B)

3+$(deriveJSON fieldLabelMod ''C)

data/examples/declaration/splice/grouped-splices.hsnew file+3

@@ -0,0 +1,3 @@

1+$(deriveJSON fieldLabelMod ''A)

2+$(deriveJSON fieldLabelMod ''B)

3+$(deriveJSON fieldLabelMod ''C)

data/examples/declaration/splice/splice-decl.hs−1

@@ -15,4 +15,3 @@ foo bar

15-- TemplateHaskell allows Q () at the top level

16do

17 pure []

18−

data/examples/declaration/value/function/let-single-line-out.hs−1

@@ -5,7 +5,6 @@ foo x = let x = z where { z = 2 }; a = 3 in x

5foo x = let g :: Int -> Int; g = id in ()

7let a = b; c = do { foo; bar }; d = baz in b

8−

9let a = case True of { True -> foo; False -> bar }; b = foo a in b

8let a = case True of { True -> foo; False -> bar }; b = foo a in b

11foo x = let ?g = id; ?f = g in x

10foo x = let ?g = id; ?f = g in x

src/Ormolu/Printer/Meat/Declaration.hs+50−43

@@ -65,14 +65,15 @@ p_hsDecls' grouping style decls = sepSemi id $

65 renderGroupWithPrev prev curr =

66 -- We can omit a blank line when the user didn't add one, but we must

67 -- ensure we always add blank lines around documented declarations

68− if or

68+ case grouping of

69− [ grouping == Disregard,

69+ Disregard ->

70+ breakpoint : renderGroup curr

71+ Respect ->

70− separatedByBlank getLoc prev curr,

72+ if separatedByBlankNE getLoc prev curr

71− isDocumented prev,

73+ || isDocumented prev

72− isDocumented curr

74+ || isDocumented curr

73− ]

74− then breakpoint : renderGroup curr

75+ then breakpoint : renderGroup curr

75− else renderGroup curr

76+ else renderGroup curr

77-- | Is a declaration group documented?

78-- | Is a declaration group documented?

78isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

79isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

@@ -85,7 +86,7 @@ isDocumented = any (isHaddock . unLoc)

85-- | Group relevant declarations together.

86-- | Group relevant declarations together.

86--

87--

87-- Add a declaration to a group iff it is relevant to either the first or

88-- Add a declaration to a group iff it is relevant to either the first or

88−-- the last declaration of the group.

89+-- the preceding declaration in the group.

89groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

90groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

90groupDecls [] = []

91groupDecls [] = []

91groupDecls (l@(L _ DocNext) : xs) =

92groupDecls (l@(L _ DocNext) : xs) =

@@ -94,18 +95,12 @@ groupDecls (l@(L _ DocNext) : xs) =

94 case groupDecls xs of

95 case groupDecls xs of

95 [] -> [l :| []]

96 [] -> [l :| []]

96 (x : xs') -> (l <| x) : xs'

97 (x : xs') -> (l <| x) : xs'

97−groupDecls (lhdr : xs) =

98+groupDecls (header : xs) =

98− let -- Pick the first decl as the group header

99+ let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->

99− hdr = unLoc lhdr

100− -- Zip rest of the decls with their previous decl

101− zipped = zip (lhdr : xs) xs

102− -- Pick decls from the tail if they are relevant to the group header

103− -- or the previous decl.

104− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->

105− let relevantToHdr = groupedDecls hdr cur

100+ let relevantToHdr = groupedDecls header current

106− relevantToPrev = groupedDecls prev cur

101+ relevantToPrev = groupedDecls previous current

107 in relevantToHdr || relevantToPrev

102 in relevantToHdr || relevantToPrev

108− in (lhdr :| map snd grp) : groupDecls (map snd rest)

103+ in (header :| map snd grp) : groupDecls (map snd rest)

109

104

110p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

105p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

111p_hsDecl style = \case

106p_hsDecl style = \case

@@ -169,30 +164,37 @@ p_derivDecl = \case

169

164

170-- | Determine if these declarations should be grouped together.

165-- | Determine if these declarations should be grouped together.

171groupedDecls ::

166groupedDecls ::

172− HsDecl GhcPs ->

167+ LHsDecl GhcPs ->

173− HsDecl GhcPs ->

168+ LHsDecl GhcPs ->

174 Bool

169 Bool

175−groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'

170+groupedDecls (L l_x x') (L l_y y') =

176−groupedDecls (TypeSignature ns) (DefaultSignature ns') = ns `intersects` ns'

171+ case (x', y') of

177−groupedDecls (DefaultSignature ns) (TypeSignature ns') = ns `intersects` ns'

172+ (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'

178−groupedDecls (DefaultSignature ns) (FunctionBody ns') = ns `intersects` ns'

173+ (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'

179−groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'

174+ (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'

180−groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'

175+ (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'

181−groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns

176+ (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'

182−groupedDecls (DataDeclaration n) x

183− | Just ns <- isPragma x =

177+ (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

178+ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns

179+ (DataDeclaration n, x)

180+ | Just ns <- isPragma x ->

184− let f = occNameFS . rdrNameOcc in f n `elem` map f ns

181+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns

182+ (x, y)

185−groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'

183+ | Just ns <- isPragma x,

184+ Just ns' <- isPragma y ->

185+ ns `intersects` ns'

186−groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'

186+ (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'

187−groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'

187+ (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

188−groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns

188+ (PatternSignature ns, Pattern n) -> n `elem` ns

189−groupedDecls (KindSignature n) (DataDeclaration n') = n == n'

189+ (KindSignature n, DataDeclaration n') -> n == n'

190−groupedDecls (KindSignature n) (ClassDeclaration n') = n == n'

190+ (KindSignature n, ClassDeclaration n') -> n == n'

191−groupedDecls (KindSignature n) (FamilyDeclaration n') = n == n'

191+ (KindSignature n, FamilyDeclaration n') -> n == n'

192+ -- Special case for TH splices, we look at locations

193+ (Splice, Splice) -> not (separatedByBlank id l_x l_y)

192−-- This looks only at Haddocks, normal comments are handled elsewhere

194+ -- This looks only at Haddocks, normal comments are handled elsewhere

193−groupedDecls DocNext _ = True

195+ (DocNext, _) -> True

194−groupedDecls _ DocPrev = True

196+ (_, DocPrev) -> True

195−groupedDecls _ _ = False

197+ _ -> False

196

198

197intersects :: Ord a => [a] -> [a] -> Bool

199intersects :: Ord a => [a] -> [a] -> Bool

198intersects a b = go (sort a) (sort b)

200intersects a b = go (sort a) (sort b)

@@ -217,6 +219,11 @@ isPragma = \case

217 WarningPragma n -> Just n

219 WarningPragma n -> Just n

218 _ -> Nothing

220 _ -> Nothing

219

221

222+-- Declarations that do not refer to names

223+

224+pattern Splice :: HsDecl GhcPs

225+pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)

226+

220-- Declarations referring to a single name

227-- Declarations referring to a single name

221

228

222pattern

229pattern

src/Ormolu/Utils.hs+9−4

@@ -11,6 +11,7 @@ module Ormolu.Utils

11 typeArgToType,

12 unSrcSpan,

13 separatedByBlank,

14+ separatedByBlankNE,

14 )

15 )

15where

16where

@@ -88,10 +89,14 @@ unSrcSpan :: SrcSpan -> Maybe RealSrcSpan

88unSrcSpan (RealSrcSpan r) = Just r

89unSrcSpan (RealSrcSpan r) = Just r

89unSrcSpan (UnhelpfulSpan _) = Nothing

90unSrcSpan (UnhelpfulSpan _) = Nothing

91−-- | Do two declaration groups have a blank between them?

92+-- | Do two declarations have a blank between them?

92−separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool

93+separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool

93separatedByBlank loc a b =

94separatedByBlank loc a b =

94 fromMaybe False $ do

95 fromMaybe False $ do

95− endA <- srcSpanEndLine <$> unSrcSpan (loc $ NE.last a)

96+ endA <- srcSpanEndLine <$> unSrcSpan (loc a)

96− startB <- srcSpanStartLine <$> unSrcSpan (loc $ NE.head b)

97+ startB <- srcSpanStartLine <$> unSrcSpan (loc b)

97 pure (startB - endA >= 2)

98 pure (startB - endA >= 2)

99+

100+-- | Do two declaration groups have a blank between them?

101+separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool

102+separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)