@@ -0,0 +1,198 @@
1+-- | Helpers for formatting of comments.
2+
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+
6+module Ormolu.Printer.Comments
7+ ( -- * Types
8+ Decoration (..)
9+ , Decorator (..)
10+ , Position (..)
11+ , CommentMode (..)
12+ -- * Functions for working with comments
13+ , spitComments
14+ , partitionDPs
15+ , addDecoration
16+ )
17+where
18+
19+import ApiAnnotation (AnnKeywordId (AnnModule))
20+import Control.Monad
21+import Data.Bifunctor
22+import Data.List (isPrefixOf)
23+import Data.Maybe (mapMaybe)
24+import Language.Haskell.GHC.ExactPrint.Types
25+import Ormolu.Printer.Internal
26+import SrcLoc
27+import qualified Data.Text as T
28+
29+-- | Placement instructions for comments.
30+
31+data Decoration
32+ = Decoration Decorator Decorator
33+ deriving (Eq, Show)
34+
35+-- | Decorator in this context is a thing to put before\/after a comment.
36+
37+data Decorator
38+ = NoDec -- ^ Output nothing
39+ | SpaceDec -- ^ Output single space
40+ | NewlineDec -- ^ Output single newline
41+ deriving (Eq, Show)
42+
43+-- | Position: before vs after.
44+
45+data Position
46+ = Before -- ^ Before
47+ | After -- ^ After
48+ deriving (Eq, Show)
49+
50+-- | For which type of AST leaf we're preparing the comments.
51+
52+data CommentMode
53+ = Module -- ^ Module
54+ | Other -- ^ Other element
55+ deriving (Eq, Show)
56+
57+-- | Output a bunch of 'Comment's. 'DeltaPos'es are used to insert extra
58+-- space between the comments when necessary.
59+
60+spitComments :: [(Comment, Decoration)] -> R ()
61+spitComments = mapM_ $ \(comment, (Decoration d0 d1)) -> do
62+ let spitDecorator = \case
63+ NoDec -> return ()
64+ SpaceDec -> spit " "
65+ NewlineDec -> newline
66+ spitDecorator d0
67+ spitComment comment
68+ spitDecorator d1
69+
70+-- | Output a 'Comment'.
71+
72+spitComment :: Comment -> R ()
73+spitComment (Comment str _ _) =
74+ if isMultiline str
75+ then if isPragma str
76+ then handleOne (normalizePragma str)
77+ else forM_ (normalizeIndent str) handleOne
78+ else handleOne str
79+ where
80+ handleOne x = do
81+ ensureIndent
82+ spit (T.pack x)
83+ isMultiline x = not ("--" `isPrefixOf` x)
84+ isPragma x = "{-#" `isPrefixOf` x
85+ normalizeIndent = fmap (dropWhile (== ' ')) . lines
86+ normalizePragma = unwords . words
87+
88+-- | Partition annotations to get a collection of 'Comment's preceding a
89+-- definition and following it. Every 'Comment' has corresponding
90+-- 'Decoration' which is used to understand how to decorate it.
91+
92+partitionDPs
93+ :: CommentMode -- ^ For which type of element we prepare comments
94+ -> SrcSpan -- ^ Span of element the comments are attached to
95+ -> [(KeywordId, DeltaPos)] -- ^ Annotations
96+ -> ([(Comment, Decoration)], [(Comment, Decoration)])
97+partitionDPs cmode refSpan anns =
98+ case cmode of
99+ Module -> partitionDPsModule refSpan anns
100+ Other -> partitionDPsOther refSpan anns
101+
102+-- | Try to partition comments as if for a module.
103+
104+partitionDPsModule
105+ :: SrcSpan -- ^ Span of element the comments are attached to
106+ -> [(KeywordId, DeltaPos)] -- ^ Annotations
107+ -> ([(Comment, Decoration)], [(Comment, Decoration)])
108+partitionDPsModule refSpan
109+ = bimap (takeComments Before) (takeComments After)
110+ . break ((== G AnnModule) . fst)
111+ where
112+ takeComments pos = mapMaybe $ \(keywordId, dpos) -> do
113+ c <- annComment keywordId
114+ return (c, getDecoration Module pos refSpan (c, dpos))
115+
116+-- | Partition comments according to their spans (works for everything but
117+-- modules).
118+
119+partitionDPsOther
120+ :: SrcSpan -- ^ Span of element the comments are attached to
121+ -> [(KeywordId, DeltaPos)] -- ^ Annotations
122+ -> ([(Comment, Decoration)], [(Comment, Decoration)])
123+partitionDPsOther refSpan
124+ = bimap (fmap (addDecoration Other Before refSpan))
125+ (fixupLastDec . fmap (addDecoration Other After refSpan))
126+ . break (followedBySpan refSpan . commentIdentifier . fst)
127+ . mapMaybe annComment'
128+ where
129+ annComment' :: (KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos)
130+ annComment' (keywordId, dpos) = do
131+ c <- annComment keywordId
132+ return (c, dpos)
133+ followedBySpan :: SrcSpan -> SrcSpan -> Bool
134+ followedBySpan spn0 spn1 =
135+ if srcSpanEnd spn0 < srcSpanStart spn1
136+ then True
137+ else False
138+
139+-- | Last following comment cannot be standalone because in that case we get
140+-- redundant newlines.
141+
142+fixupLastDec :: [(Comment, Decoration)] -> [(Comment, Decoration)]
143+fixupLastDec [] = []
144+fixupLastDec [(c, Decoration d0 _)] = [(c, Decoration d0 NoDec)]
145+fixupLastDec (c:cs) = c : fixupLastDec cs
146+
147+-- | If 'KeywordId' is a comment, extract it.
148+
149+annComment :: KeywordId -> Maybe Comment
150+annComment (AnnComment x) = Just x
151+annComment _ = Nothing
152+
153+-- | Replace 'DeltaPos' with 'Decoration'.
154+
155+addDecoration
156+ :: CommentMode -- ^ For which type of element we prepare comments
157+ -> Position -- ^ Is this for comments before or after?
158+ -> SrcSpan -- ^ Span of element the comments are attached to
159+ -> (Comment, DeltaPos) -- ^ Thing to decorate
160+ -> (Comment, Decoration)
161+addDecoration cmode pos refSpan (comment, dpos) =
162+ ( comment
163+ , getDecoration cmode pos refSpan (comment, dpos)
164+ )
165+
166+-- | Calculate decoration for a comment.
167+
168+getDecoration
169+ :: CommentMode -- ^ For which type of element we prepare comments
170+ -> Position -- ^ Is this for comment before or after?
171+ -> SrcSpan -- ^ Span of element the comments are attached to
172+ -> (Comment, DeltaPos) -- ^ Thing to decorate
173+ -> Decoration
174+getDecoration cmode pos refSpan (c, (DP (r, _))) =
175+ Decoration preceedingDec followingDec
176+ where
177+ preceedingDec =
178+ if sameLine
179+ then case pos of
180+ Before -> NoDec
181+ After -> SpaceDec
182+ else if r > 1
183+ then NewlineDec
184+ else NoDec
185+ followingDec =
186+ if sameLine
187+ then case pos of
188+ Before -> SpaceDec
189+ After -> NewlineDec
190+ else NewlineDec
191+ sameLine =
192+ case cmode of
193+ Module -> False
194+ Other ->
195+ case (refSpan, commentIdentifier c) of
196+ (RealSrcSpan spn0, RealSrcSpan spn1) ->
197+ srcSpanStartLine spn0 == srcSpanStartLine spn1
198+ (_, _) -> False