git.iko.soy/ormolu
on d82d607 help sign in
ormolu/src/Ormolu/Parser/CommentStream.hs
133 lines 4.5 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 Data.Set (Set)
25import Ormolu.Parser.LanguagePragma
26import Ormolu.Utils (showOutputable)
27import SrcLoc
28import qualified Data.List.NonEmpty as NE
29import qualified Data.Set as S
30import qualified GHC
31import qualified Lexer as GHC
33-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
34-- beginning of corresponding spans.
36newtype CommentStream = CommentStream [RealLocated Comment]
37 deriving (Eq, Data, Semigroup, Monoid)
39-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
40-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
42newtype Comment = Comment (NonEmpty String)
43 deriving (Eq, Show, Data)
45-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
46-- extensions here, which is not sorted in any way. The pragma comment are
47-- removed from the 'CommentStream'.
49mkCommentStream
50 :: [Located String] -- ^ Extra comments to include
51 -> GHC.PState -- ^ Parser state to use for comment extraction
52 -> (CommentStream, Set String)
53 -- ^ Comment stream and a set of extensions enabled
54mkCommentStream extraComments pstate =
55 ( CommentStream $
56 -- NOTE It's easier to normalize pragmas right when we construct comment
57 -- streams. Because this way we need to do it only once and when we
58 -- perform checking later they'll automatically match.
59 mkComment <$> sortOn (realSrcSpanStart . getLoc) comments
60 , S.unions exts
61 )
62 where
63 (comments, exts) = partitionEithers (partitionComments <$> rawComments)
64 rawComments = mapMaybe toRealSpan $
65 extraComments ++
66 (fmap unAnnotationComment <$> GHC.comment_q pstate) ++
67 concatMap (fmap (fmap unAnnotationComment) . snd)
68 (GHC.annotations_comments pstate)
70-- | Test whether a 'Comment' looks like a Haddock following a definition,
71-- i.e. something starting with @-- ^@.
73isPrevHaddock :: Comment -> Bool
74isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
76-- | Pretty-print a 'CommentStream'.
78showCommentStream :: CommentStream -> String
79showCommentStream (CommentStream xs) = unlines $
80 showComment <$> xs
81 where
82 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
84----------------------------------------------------------------------------
85-- Helpers
87-- | Normalize comment string. Sometimes one multi-line comment is turned
88-- into several lines for subsequent outputting with correct indentation for
89-- each line.
91mkComment :: RealLocated String -> RealLocated Comment
92mkComment (L l s) = L l . Comment . fmap dropTrailing $
93 if "{-" `isPrefixOf` s
94 then case NE.nonEmpty (lines s) of
95 Nothing -> s :| []
96 Just (x:|xs) ->
97 let getIndent y =
98 if all isSpace y
99 then startIndent
100 else length (takeWhile isSpace y)
101 n = minimum (startIndent : fmap getIndent xs)
102 in x :| (drop n <$> xs)
103 else s :| []
104 where
105 dropTrailing = dropWhileEnd isSpace
106 startIndent = srcSpanStartCol l - 1
108-- | Get a 'String' from 'GHC.AnnotationComment'.
110unAnnotationComment :: GHC.AnnotationComment -> String
111unAnnotationComment = \case
112 GHC.AnnDocCommentNext s -> s
113 GHC.AnnDocCommentPrev s -> s
114 GHC.AnnDocCommentNamed s -> s
115 GHC.AnnDocSection _ s -> s
116 GHC.AnnDocOptions s -> s
117 GHC.AnnLineComment s -> s
118 GHC.AnnBlockComment s -> s
120toRealSpan :: Located a -> Maybe (RealLocated a)
121toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
122toRealSpan _ = Nothing
124-- | If a given comment is a LANGUAGE pragma, return the set of extensions
125-- it enables in 'Right'. Otherwise return the original comment unchanged.
127partitionComments
128 :: RealLocated String
129 -> Either (RealLocated String) (Set String)
130partitionComments input =
131 case parseLanguagePragma (unLoc input) of
132 Nothing -> Left input
133 Just exts -> Right exts