git.iko.soy/ormolu
on 2dfd181 help sign in
ormolu/src/Ormolu/CommentStream.hs
96 lines 3.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE LambdaCase #-}
5-- | Functions for working with comment stream.
7module Ormolu.CommentStream
8 ( CommentStream (..)
9 , Comment (..)
10 , mkCommentStream
11 , isPrevHaddock
12 )
13where
15import Data.Data (Data)
16import Data.List (isPrefixOf, sortOn)
17import Data.List.NonEmpty (NonEmpty (..))
18import Data.Maybe (mapMaybe)
19import SrcLoc
20import qualified Data.List.NonEmpty as NE
21import qualified GHC
22import qualified Lexer as GHC
24-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
25-- beginning of corresponding spans.
27newtype CommentStream = CommentStream [RealLocated Comment]
28 deriving (Eq, Data, Semigroup, Monoid)
30-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
31-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
33newtype Comment = Comment (NonEmpty String)
34 deriving (Eq, Show, Data)
36-- | Create 'CommentStream' from 'GHC.PState'.
38mkCommentStream
39 :: [Located String] -- ^ Extra comments to include
40 -> GHC.PState -- ^ Parser state to use for comment extraction
41 -> CommentStream
42mkCommentStream extraComments pstate
43 = CommentStream
44 -- NOTE It's easier to normalize pragmas right when we construct comment
45 -- streams. Because this way we need to do it only once and when we
46 -- perform checking later they'll automatically match.
47 . fmap (fmap (Comment . normalizeComment . normalizePragma))
48 . sortOn startOfSpan
49 . mapMaybe toRealSpan $
50 extraComments ++
51 (fmap unAnnotationComment <$> GHC.comment_q pstate) ++
52 concatMap (fmap (fmap unAnnotationComment) . snd)
53 (GHC.annotations_comments pstate)
54 where
55 startOfSpan (L l _) = realSrcSpanStart l
56 toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
57 toRealSpan _ = Nothing
59-- | Test whether a 'Comment' looks like a Haddock following a definition,
60-- i.e. something starting with @-- ^@.
62isPrevHaddock :: Comment -> Bool
63isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
65----------------------------------------------------------------------------
66-- Helpers
68-- | Normalize pragmas by deleting extra white space.
70normalizePragma :: String -> String
71normalizePragma x =
72 if "{-#" `isPrefixOf` x
73 then unwords (words x)
74 else x
76-- | Normalize comment string. Sometimes one multi-line comment is turned
77-- into several lines for subsequent outputting with correct indentation for
78-- each line.
80normalizeComment :: String -> NonEmpty String
81normalizeComment s =
82 case NE.nonEmpty (lines s) of
83 Nothing -> s :| []
84 Just xs -> dropWhile (== ' ') <$> xs
86-- | Get a 'String' from 'GHC.AnnotationComment'.
88unAnnotationComment :: GHC.AnnotationComment -> String
89unAnnotationComment = \case
90 GHC.AnnDocCommentNext s -> s
91 GHC.AnnDocCommentPrev s -> s
92 GHC.AnnDocCommentNamed s -> s
93 GHC.AnnDocSection _ s -> s
94 GHC.AnnDocOptions s -> s
95 GHC.AnnLineComment s -> s
96 GHC.AnnBlockComment s -> s