{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module Ormolu.Parser.CommentStream
( CommentStream (..),
Comment (..),
mkCommentStream,
isShebang,
isPrevHaddock,
isMultilineComment,
showCommentStream,
)
where
import Data.Char (isSpace)
import Data.Data (Data)
import Data.Either (partitionEithers)
import Data.List (dropWhileEnd, isPrefixOf, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import qualified GHC
import qualified Lexer as GHC
import Ormolu.Parser.Pragma
import Ormolu.Utils (showOutputable)
import SrcLoc
newtype CommentStream = CommentStream [RealLocated Comment]
deriving (Eq, Data, Semigroup, Monoid)
newtype Comment = Comment (NonEmpty String)
deriving (Eq, Show, Data)
mkCommentStream ::
[Located String] ->
GHC.PState ->
(CommentStream, [Pragma], [Located String])
mkCommentStream extraComments pstate =
( CommentStream $
mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,
pragmas,
shebangs
)
where
(comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
rawComments =
mapMaybe toRealSpan $
otherExtraComments
++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
++ concatMap
(mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
(GHC.annotations_comments pstate)
(shebangs, otherExtraComments) = span (isShebang . unLoc) extraComments
isShebang :: String -> Bool
isShebang str = "#!" `isPrefixOf` str
isPrevHaddock :: Comment -> Bool
isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
isMultilineComment :: Comment -> Bool
isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
showCommentStream :: CommentStream -> String
showCommentStream (CommentStream xs) =
unlines $
showComment <$> xs
where
showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
mkComment :: RealLocated String -> RealLocated Comment
mkComment (L l s) =
L l . Comment . fmap dropTrailing $
if "{-" `isPrefixOf` s
then case NE.nonEmpty (lines s) of
Nothing -> s :| []
Just (x :| xs) ->
let getIndent y =
if all isSpace y
then startIndent
else length (takeWhile isSpace y)
n = minimum (startIndent : fmap getIndent xs)
in x :| (drop n <$> xs)
else s :| []
where
dropTrailing = dropWhileEnd isSpace
startIndent = srcSpanStartCol l - 1
unAnnotationComment :: GHC.AnnotationComment -> Maybe String
unAnnotationComment = \case
GHC.AnnDocCommentNext _ -> Nothing
GHC.AnnDocCommentPrev _ -> Nothing
GHC.AnnDocCommentNamed _ -> Nothing
GHC.AnnDocSection _ _ -> Nothing
GHC.AnnDocOptions s -> Just s
GHC.AnnLineComment s -> Just s
GHC.AnnBlockComment s -> Just s
liftMaybe :: Located (Maybe a) -> Maybe (Located a)
liftMaybe = \case
L _ Nothing -> Nothing
L l (Just a) -> Just (L l a)
toRealSpan :: Located a -> Maybe (RealLocated a)
toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
toRealSpan _ = Nothing
partitionComments ::
RealLocated String ->
Either (RealLocated String) Pragma
partitionComments input =
case parsePragma (unRealSrcSpan input) of
Nothing -> Left input
Just pragma -> Right pragma