git.iko.soy/ormolu
on 625f239 help sign in
ormolu/src/Ormolu/Parser/CommentStream.hs
131 lines 4.4 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE TupleSections #-}
7-- | Functions for working with comment stream.
9module Ormolu.Parser.CommentStream
10 ( CommentStream (..)
11 , Comment (..)
12 , mkCommentStream
13 , isPrevHaddock
14 , showCommentStream
15 )
16where
18import Data.Char (isSpace)
19import Data.Data (Data)
20import Data.Either (partitionEithers)
21import Data.List (isPrefixOf, sortOn, dropWhileEnd)
22import Data.List.NonEmpty (NonEmpty (..))
23import Data.Maybe (mapMaybe)
24import Ormolu.Parser.Pragma
25import Ormolu.Utils (showOutputable)
26import SrcLoc
27import qualified Data.List.NonEmpty as NE
28import qualified GHC
29import qualified Lexer as GHC
31-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
32-- beginning of corresponding spans.
34newtype CommentStream = CommentStream [RealLocated Comment]
35 deriving (Eq, Data, Semigroup, Monoid)
37-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
38-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
40newtype Comment = Comment (NonEmpty String)
41 deriving (Eq, Show, Data)
43-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
44-- extensions here, which is not sorted in any way. The pragma comment are
45-- removed from the 'CommentStream'.
47mkCommentStream
48 :: [Located String] -- ^ Extra comments to include
49 -> GHC.PState -- ^ Parser state to use for comment extraction
50 -> (CommentStream, [Pragma])
51 -- ^ Comment stream and a set of extracted pragmas
52mkCommentStream extraComments pstate =
53 ( CommentStream $
54 -- NOTE It's easier to normalize pragmas right when we construct comment
55 -- streams. Because this way we need to do it only once and when we
56 -- perform checking later they'll automatically match.
57 mkComment <$> sortOn (realSrcSpanStart . getLoc) comments
58 , pragmas
59 )
60 where
61 (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
62 rawComments = mapMaybe toRealSpan $
63 extraComments ++
64 (fmap unAnnotationComment <$> GHC.comment_q pstate) ++
65 concatMap (fmap (fmap unAnnotationComment) . snd)
66 (GHC.annotations_comments pstate)
68-- | Test whether a 'Comment' looks like a Haddock following a definition,
69-- i.e. something starting with @-- ^@.
71isPrevHaddock :: Comment -> Bool
72isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
74-- | Pretty-print a 'CommentStream'.
76showCommentStream :: CommentStream -> String
77showCommentStream (CommentStream xs) = unlines $
78 showComment <$> xs
79 where
80 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
82----------------------------------------------------------------------------
83-- Helpers
85-- | Normalize comment string. Sometimes one multi-line comment is turned
86-- into several lines for subsequent outputting with correct indentation for
87-- each line.
89mkComment :: RealLocated String -> RealLocated Comment
90mkComment (L l s) = L l . Comment . fmap dropTrailing $
91 if "{-" `isPrefixOf` s
92 then case NE.nonEmpty (lines s) of
93 Nothing -> s :| []
94 Just (x:|xs) ->
95 let getIndent y =
96 if all isSpace y
97 then startIndent
98 else length (takeWhile isSpace y)
99 n = minimum (startIndent : fmap getIndent xs)
100 in x :| (drop n <$> xs)
101 else s :| []
102 where
103 dropTrailing = dropWhileEnd isSpace
104 startIndent = srcSpanStartCol l - 1
106-- | Get a 'String' from 'GHC.AnnotationComment'.
108unAnnotationComment :: GHC.AnnotationComment -> String
109unAnnotationComment = \case
110 GHC.AnnDocCommentNext s -> s
111 GHC.AnnDocCommentPrev s -> s
112 GHC.AnnDocCommentNamed s -> s
113 GHC.AnnDocSection _ s -> s
114 GHC.AnnDocOptions s -> s
115 GHC.AnnLineComment s -> s
116 GHC.AnnBlockComment s -> s
118toRealSpan :: Located a -> Maybe (RealLocated a)
119toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
120toRealSpan _ = Nothing
122-- | If a given comment is a pragma, return it in parsed form in 'Right'.
123-- Otherwise return the original comment unchanged.
125partitionComments
126 :: RealLocated String
127 -> Either (RealLocated String) Pragma
128partitionComments input =
129 case parsePragma (unLoc input) of
130 Nothing -> Left input
131 Just pragma -> Right pragma