effb5cd · ormolu · git.iko.soy

git.iko.soy/ormolu

on master help sign in

Group declarations referring to multiple names

effb5cdUtku Demir7 years ago

data/examples/declaration/signature/type/multi-value-out.hs+4

compare with master

unifiedsplit

@@ -1,6 +1,10 @@

1foo, bar :: Int

2+foo = 1

3+bar = 2

3foo,

5foo,

4 bar,

6 bar,

5 baz

7 baz

6 :: Int

8 :: Int

9+bar = 2

10+baz = 3

data/examples/declaration/signature/type/multi-value.hs+4

@@ -1,5 +1,9 @@

1foo, bar :: Int

2+foo = 1

3+bar = 2

3foo,

5foo,

4 bar,

6 bar,

5 baz :: Int

7 baz :: Int

8+bar = 2

9+baz = 3

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

@@ -3,5 +3,4 @@ foo x = case x of x -> x

4foo :: IO ()

5foo = case [1] of [_] -> "singleton"; _ -> "not singleton"

6−

7foo = case [1] of { [] -> foo; _ -> bar } `finally` baz

6foo = case [1] of { [] -> foo; _ -> bar } `finally` baz

data/examples/declaration/value/function/pattern/n-plus-k-pattern-out.hs+3

@@ -8,3 +8,6 @@ multiline

8 ( n

9 + 1

10 ) = n

11+

12+n :: Int

13+(n + 1) = 3

data/examples/declaration/value/function/pattern/n-plus-k-pattern.hs+3

@@ -5,3 +5,6 @@ singleline (n + 1) = n

5multiline :: Int

6multiline(n

7 + 1) = n

9+n :: Int

10+(n + 1) = 3

data/examples/declaration/warning/warning-multiline-out.hs−1

@@ -5,6 +5,5 @@

5 "Really bad!"

6 ]

7 #-}

8−

9test :: IO ()

8test :: IO ()

10test = pure ()

9test = pure ()

data/examples/declaration/warning/warning-single-line-out.hs−1

@@ -1,5 +1,4 @@

1{-# DEPRECATED test, foo "This is a deprecation" #-}

2−

3{-# WARNING test "This is a warning" #-}

2{-# WARNING test "This is a warning" #-}

4test :: IO ()

3test :: IO ()

5test = pure ()

4test = pure ()

src/Ormolu/Printer/Meat/Declaration.hs+121−44

@@ -28,24 +28,47 @@ import Ormolu.Printer.Meat.Declaration.Signature

28import Ormolu.Printer.Meat.Declaration.Splice

29import Ormolu.Printer.Meat.Declaration.Type

30import Ormolu.Printer.Meat.Declaration.TypeFamily

31+import Data.List

31import Ormolu.Printer.Meat.Declaration.Value

32import Ormolu.Printer.Meat.Declaration.Value

32import Ormolu.Printer.Meat.Declaration.Warning

33import Ormolu.Printer.Meat.Declaration.Warning

33import Ormolu.Printer.Meat.Type

34import Ormolu.Printer.Meat.Type

34import Ormolu.Utils

35import Ormolu.Utils

35import RdrName (rdrNameOcc)

36import RdrName (rdrNameOcc)

37+import Data.List.NonEmpty (NonEmpty((:|)))

38+import qualified Data.List.NonEmpty as NE

37p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

40p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

38−p_hsDecls style decls = do

41+p_hsDecls style decls = sepSemi id $

39− sepSemi (\(x, r) -> located x pDecl >> r) (separated decls)

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

40 where

49 where

41− pDecl = dontUseBraces . p_hsDecl style

50+ renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style)

42−

51+ separateGroup (x :| xs) = (breakpoint' >> x) :| xs

43− separated [] = []

52+

44− separated [x] = [(x, return ())]

53+-- | Group relevant declarations together.

45− separated (x:y:xs) =

54+--

46− if separatedDecls (unLoc x) (unLoc y)

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

47− then (x, breakpoint') : separated (y:xs)

56+-- the last declaration of the group.

48− else (x, return ()) : separated (y:xs)

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)

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

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

51p_hsDecl style = \case

74p_hsDecl style = \case

@@ -100,66 +123,120 @@ p_derivDecl = \case

100 d@DerivDecl {..} -> p_standaloneDerivDecl d

123 d@DerivDecl {..} -> p_standaloneDerivDecl d

101 XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"

124 XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"

102

125

103−-- | Determine if these declarations should be separated by a blank line.

126+-- | Determine if these declarations should be grouped together.

104

127

105−separatedDecls

128+groupedDecls

106 :: HsDecl GhcPs

129 :: HsDecl GhcPs

107 -> HsDecl GhcPs

130 -> HsDecl GhcPs

108 -> Bool

131 -> Bool

109−separatedDecls (TypeSignature n) (FunctionBody n') = n /= n'

132+groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'

110−separatedDecls x (FunctionBody n) | Just n' <- isPragma x = n /= n'

133+groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'

111−separatedDecls (FunctionBody n) x | Just n' <- isPragma x = n /= n'

134+groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'

112−separatedDecls x (DataDeclaration n) | Just n' <- isPragma x = n /= n'

135+groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns

113−separatedDecls (DataDeclaration n) x | Just n' <- isPragma x =

136+groupedDecls (DataDeclaration n) x | Just ns <- isPragma x =

114− let f = occNameFS . rdrNameOcc in f n /= f n'

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

115−separatedDecls x y | Just n <- isPragma x, Just n' <- isPragma y = n /= n'

138+groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'

116−separatedDecls x (TypeSignature n') | Just n <- isPragma x = n /= n'

139+groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'

117−separatedDecls (PatternSignature n) (Pattern n') = n /= n'

140+groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns

118−separatedDecls _ _ = True

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

119

153

120-- | Checks if given list of declarations contain a pair which should

154-- | Checks if given list of declarations contain a pair which should

121-- be separated by a blank line.

155-- be separated by a blank line.

122

156

123−hasSeparatedDecls :: [HsDecl GhcPs] -> Bool

157+hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool

124−hasSeparatedDecls xs

158+hasSeparatedDecls xs = case groupDecls xs of

125− = any (uncurry separatedDecls) $ zip xs (tail xs)

159+ _:_:_ -> True

160+ _ -> False

126

161

127isPragma

162isPragma

128 :: HsDecl GhcPs

163 :: HsDecl GhcPs

129− -> (Maybe RdrName)

164+ -> Maybe [RdrName]

130isPragma = \case

165isPragma = \case

131− InlinePragma n -> Just n

166+ InlinePragma n -> Just [n]

132− SpecializePragma n -> Just n

167+ SpecializePragma n -> Just [n]

133− SCCPragma n -> Just n

168+ SCCPragma n -> Just [n]

134− AnnTypePragma n -> Just n

169+ AnnTypePragma n -> Just [n]

135− AnnValuePragma n -> Just n

170+ AnnValuePragma n -> Just [n]

136 WarningPragma n -> Just n

171 WarningPragma n -> Just n

137 _ -> Nothing

172 _ -> Nothing

138

173

139−pattern TypeSignature

174+-- Declarations referring to a single name

140− , FunctionBody

175+

141− , InlinePragma

176+pattern InlinePragma

142 , SpecializePragma

177 , SpecializePragma

143 , SCCPragma

178 , SCCPragma

144 , AnnTypePragma

179 , AnnTypePragma

145 , AnnValuePragma

180 , AnnValuePragma

146− , PatternSignature

147 , Pattern

181 , Pattern

148− , WarningPragma

149 , DataDeclaration :: RdrName -> HsDecl GhcPs

182 , DataDeclaration :: RdrName -> HsDecl GhcPs

150−pattern TypeSignature n <- (sigRdrName -> Just n)

151−pattern FunctionBody n <- ValD NoExt (FunBind NoExt (L _ n) _ _ _)

152pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)

183pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)

153pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)

184pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)

154pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)

185pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)

155pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)

186pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)

156pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)

187pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)

157−pattern PatternSignature n <- SigD NoExt (PatSynSig NoExt ((L _ n):_) _)

158pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))

188pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))

159−pattern WarningPragma n <- WarningD NoExt (Warnings NoExt _ [(L _ (Warning NoExt [(L _ n)] _))])

160pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)

189pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)

161

190

162−sigRdrName :: HsDecl GhcPs -> Maybe RdrName

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]

163−sigRdrName (SigD NoExt (TypeSig NoExt ((L _ n):_) _)) = Just n

203+sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns

164−sigRdrName (SigD NoExt (ClassOpSig NoExt _ ((L _ n):_) _)) = Just n

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

165−sigRdrName _ = Nothing

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"

src/Ormolu/Printer/Meat/Declaration.hs-boot+1−1

@@ -9,4 +9,4 @@ import Ormolu.Printer.Combinators

9import Ormolu.Printer.Meat.Common

11p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

12−hasSeparatedDecls :: [HsDecl GhcPs] -> Bool

12+hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool

src/Ormolu/Printer/Meat/Declaration/Class.hs+1−1

@@ -69,7 +69,7 @@ p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs = do

69 breakpoint -- Ensure whitespace is added after where clause.

70 -- Add newline before first declaration if the body contains separate

71 -- declarations

72− when (hasSeparatedDecls $ map unLoc allDecls) breakpoint'

72+ when (hasSeparatedDecls allDecls) breakpoint'

73 inci (p_hsDecls Associated allDecls)

75p_classContext :: LHsContext GhcPs -> R ()

src/Ormolu/Printer/Meat/Declaration/Instance.hs+1−1

@@ -97,7 +97,7 @@ p_clsInstDecl = \case

97 breakpoint

98 -- Add newline before first declaration if the body contains separate

99 -- declarations

100− when (hasSeparatedDecls $ map unLoc allDecls) breakpoint'

100+ when (hasSeparatedDecls allDecls) breakpoint'

101 dontUseBraces $ p_hsDecls Associated allDecls

102 XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"

103 XClsInstDecl NoExt -> notImplemented "XClsInstDecl"