{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module Ormolu.Parser.CommentStream
(
CommentStream (..),
mkCommentStream,
showCommentStream,
Comment (..),
unComment,
hasAtomsBefore,
isMultilineComment,
)
where
import Data.Char (isSpace)
import Data.Data (Data)
import Data.Generics.Schemes
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Lazy as M
import Data.Maybe
import qualified Data.Set as S
import GHC.Hs (HsModule)
import GHC.Hs.Decls (HsDecl (..), LDocDecl, LHsDecl)
import GHC.Hs.Doc
import GHC.Hs.Extension
import GHC.Hs.ImpExp
import qualified GHC.Parser.Annotation as GHC
import qualified GHC.Parser.Lexer as GHC
import GHC.Types.SrcLoc
import Ormolu.Parser.Pragma
import Ormolu.Utils (onTheSameLine, showOutputable, unSrcSpan)
newtype = [RealLocated Comment]
deriving (CommentStream -> CommentStream -> Bool
(CommentStream -> CommentStream -> Bool)
-> (CommentStream -> CommentStream -> Bool) -> Eq CommentStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentStream -> CommentStream -> Bool
$c/= :: CommentStream -> CommentStream -> Bool
== :: CommentStream -> CommentStream -> Bool
$c== :: CommentStream -> CommentStream -> Bool
Eq, , b -> CommentStream -> CommentStream
NonEmpty CommentStream -> CommentStream
CommentStream -> CommentStream -> CommentStream
(CommentStream -> CommentStream -> CommentStream)
-> (NonEmpty CommentStream -> CommentStream)
-> (forall b. Integral b => b -> CommentStream -> CommentStream)
-> Semigroup CommentStream
forall b. Integral b => b -> CommentStream -> CommentStream
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> CommentStream -> CommentStream
$cstimes :: forall b. Integral b => b -> CommentStream -> CommentStream
sconcat :: NonEmpty CommentStream -> CommentStream
$csconcat :: NonEmpty CommentStream -> CommentStream
<> :: CommentStream -> CommentStream -> CommentStream
$c<> :: CommentStream -> CommentStream -> CommentStream
Semigroup, Semigroup CommentStream
CommentStream
Semigroup CommentStream
-> CommentStream
-> (CommentStream -> CommentStream -> CommentStream)
-> ([CommentStream] -> CommentStream)
-> Monoid CommentStream
[CommentStream] -> CommentStream
CommentStream -> CommentStream -> CommentStream
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CommentStream] -> CommentStream
$cmconcat :: [CommentStream] -> CommentStream
mappend :: CommentStream -> CommentStream -> CommentStream
$cmappend :: CommentStream -> CommentStream -> CommentStream
mempty :: CommentStream
$cmempty :: CommentStream
$cp1Monoid :: Semigroup CommentStream
Monoid)
mkCommentStream ::
String ->
GHC.PState ->
HsModule ->
( Maybe (RealLocated Comment),
[([RealLocated Comment], Pragma)],
CommentStream
)
String
input PState
pstate HsModule
hsModule =
( Maybe (RealLocated Comment)
mstackHeader,
[([RealLocated Comment], Pragma)]
pragmas,
[RealLocated Comment] -> CommentStream
CommentStream [RealLocated Comment]
comments
)
where
([RealLocated Comment]
comments, [([RealLocated Comment], Pragma)]
pragmas) = String
-> [RealLocated String]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas String
input [RealLocated String]
rawComments1
([RealLocated String]
rawComments1, Maybe (RealLocated Comment)
mstackHeader) = [RealLocated String]
-> ([RealLocated String], Maybe (RealLocated Comment))
extractStackHeader [RealLocated String]
rawComments0
rawComments0 :: [RealLocated String]
rawComments0 =
((RealSrcSpan, String) -> RealLocated String)
-> [(RealSrcSpan, String)] -> [RealLocated String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RealSrcSpan -> String -> RealLocated String)
-> (RealSrcSpan, String) -> RealLocated String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealSrcSpan -> String -> RealLocated String
forall l e. l -> e -> GenLocated l e
L)
([(RealSrcSpan, String)] -> [RealLocated String])
-> ([RealLocated String] -> [(RealSrcSpan, String)])
-> [RealLocated String]
-> [RealLocated String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RealSrcSpan String -> [(RealSrcSpan, String)]
forall k a. Map k a -> [(k, a)]
M.toAscList
(Map RealSrcSpan String -> [(RealSrcSpan, String)])
-> ([RealLocated String] -> Map RealSrcSpan String)
-> [RealLocated String]
-> [(RealSrcSpan, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map RealSrcSpan String
-> Set RealSrcSpan -> Map RealSrcSpan String)
-> Set RealSrcSpan
-> Map RealSrcSpan String
-> Map RealSrcSpan String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map RealSrcSpan String -> Set RealSrcSpan -> Map RealSrcSpan String
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Set RealSrcSpan
validHaddockCommentSpans
(Map RealSrcSpan String -> Map RealSrcSpan String)
-> ([RealLocated String] -> Map RealSrcSpan String)
-> [RealLocated String]
-> Map RealSrcSpan String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealSrcSpan, String)] -> Map RealSrcSpan String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
([(RealSrcSpan, String)] -> Map RealSrcSpan String)
-> ([RealLocated String] -> [(RealSrcSpan, String)])
-> [RealLocated String]
-> Map RealSrcSpan String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated String -> (RealSrcSpan, String))
-> [RealLocated String] -> [(RealSrcSpan, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(L RealSrcSpan
l String
a) -> (RealSrcSpan
l, String
a))
([RealLocated String] -> [RealLocated String])
-> [RealLocated String] -> [RealLocated String]
forall a b. (a -> b) -> a -> b
$ [RealLocated String]
allComments
where
allComments :: [RealLocated String]
allComments =
(GenLocated RealSrcSpan AnnotationComment -> RealLocated String)
-> [GenLocated RealSrcSpan AnnotationComment]
-> [RealLocated String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AnnotationComment -> String)
-> GenLocated RealSrcSpan AnnotationComment -> RealLocated String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnotationComment -> String
unAnnotationComment)
([GenLocated RealSrcSpan AnnotationComment]
-> [RealLocated String])
-> (PState -> [GenLocated RealSrcSpan AnnotationComment])
-> PState
-> [RealLocated String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState -> [GenLocated RealSrcSpan AnnotationComment]
GHC.comment_q (PState -> [GenLocated RealSrcSpan AnnotationComment])
-> (PState -> [GenLocated RealSrcSpan AnnotationComment])
-> PState
-> [GenLocated RealSrcSpan AnnotationComment]
forall a. Semigroup a => a -> a -> a
<> (((RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])
-> [GenLocated RealSrcSpan AnnotationComment])
-> [(RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])]
-> [GenLocated RealSrcSpan AnnotationComment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])
-> [GenLocated RealSrcSpan AnnotationComment]
forall a b. (a, b) -> b
snd ([(RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])]
-> [GenLocated RealSrcSpan AnnotationComment])
-> (PState
-> [(RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])])
-> PState
-> [GenLocated RealSrcSpan AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState
-> [(RealSrcSpan, [GenLocated RealSrcSpan AnnotationComment])]
GHC.annotations_comments))
(PState -> [RealLocated String]) -> PState -> [RealLocated String]
forall a b. (a -> b) -> a -> b
$ PState
pstate
validHaddockCommentSpans :: Set RealSrcSpan
validHaddockCommentSpans =
[RealSrcSpan] -> Set RealSrcSpan
forall a. Ord a => [a] -> Set a
S.fromList
([RealSrcSpan] -> Set RealSrcSpan)
-> (HsModule -> [RealSrcSpan]) -> HsModule -> Set RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> Maybe RealSrcSpan) -> [SrcSpan] -> [RealSrcSpan]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SrcSpan -> Maybe RealSrcSpan
unSrcSpan
([SrcSpan] -> [RealSrcSpan])
-> (HsModule -> [SrcSpan]) -> HsModule -> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsModule -> [SrcSpan]] -> HsModule -> [SrcSpan]
forall a. Monoid a => [a] -> a
mconcat
[ (GenLocated SrcSpan HsDocString -> SrcSpan)
-> [GenLocated SrcSpan HsDocString] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan HsDocString -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan HsDocString] -> [SrcSpan])
-> (HsModule -> [GenLocated SrcSpan HsDocString])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan HsDocString -> Bool)
-> GenericQ [GenLocated SrcSpan HsDocString]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (GenLocated SrcSpan HsDocString -> Bool
forall a. a -> Bool
only @LHsDocString),
(GenLocated SrcSpan DocDecl -> SrcSpan)
-> [GenLocated SrcSpan DocDecl] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan DocDecl -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan DocDecl] -> [SrcSpan])
-> (HsModule -> [GenLocated SrcSpan DocDecl])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan DocDecl -> Bool)
-> GenericQ [GenLocated SrcSpan DocDecl]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (GenLocated SrcSpan DocDecl -> Bool
forall a. a -> Bool
only @LDocDecl),
(GenLocated SrcSpan (HsDecl GhcPs) -> SrcSpan)
-> [GenLocated SrcSpan (HsDecl GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan (HsDecl GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan (HsDecl GhcPs)] -> [SrcSpan])
-> (HsModule -> [GenLocated SrcSpan (HsDecl GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan (HsDecl GhcPs) -> Bool)
-> GenericQ [GenLocated SrcSpan (HsDecl GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify GenLocated SrcSpan (HsDecl GhcPs) -> Bool
isDocD,
(GenLocated SrcSpan (IE GhcPs) -> SrcSpan)
-> [GenLocated SrcSpan (IE GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan (IE GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan (IE GhcPs)] -> [SrcSpan])
-> (HsModule -> [GenLocated SrcSpan (IE GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan (IE GhcPs) -> Bool)
-> GenericQ [GenLocated SrcSpan (IE GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify GenLocated SrcSpan (IE GhcPs) -> Bool
isIEDocLike
]
(HsModule -> Set RealSrcSpan) -> HsModule -> Set RealSrcSpan
forall a b. (a -> b) -> a -> b
$ HsModule
hsModule
where
only :: a -> Bool
only :: a -> Bool
only a
_ = Bool
True
isDocD :: LHsDecl GhcPs -> Bool
isDocD :: GenLocated SrcSpan (HsDecl GhcPs) -> Bool
isDocD = \case
L SrcSpan
_ DocD {} -> Bool
True
GenLocated SrcSpan (HsDecl GhcPs)
_ -> Bool
False
isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike :: GenLocated SrcSpan (IE GhcPs) -> Bool
isIEDocLike = \case
L SrcSpan
_ IEGroup {} -> Bool
True
L SrcSpan
_ IEDoc {} -> Bool
True
L SrcSpan
_ IEDocNamed {} -> Bool
True
GenLocated SrcSpan (IE GhcPs)
_ -> Bool
False
showCommentStream :: CommentStream -> String
(CommentStream [RealLocated Comment]
xs) =
[String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
RealLocated Comment -> String
forall o a. (Outputable o, Show a) => GenLocated o a -> String
showComment (RealLocated Comment -> String)
-> [RealLocated Comment] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RealLocated Comment]
xs
where
showComment :: GenLocated o a -> String
showComment (L o
l a
str) = o -> String
forall o. Outputable o => o -> String
showOutputable o
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
str
data = Bool (NonEmpty String)
deriving (Comment -> Comment -> Bool
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c== :: Comment -> Comment -> Bool
Eq, Int -> Comment -> String -> String
[Comment] -> String -> String
Comment -> String
(Int -> Comment -> String -> String)
-> (Comment -> String)
-> ([Comment] -> String -> String)
-> Show Comment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Comment] -> String -> String
$cshowList :: [Comment] -> String -> String
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> String -> String
$cshowsPrec :: Int -> Comment -> String -> String
Show, )
mkComment ::
[(Int, String)] ->
RealLocated String ->
([(Int, String)], RealLocated Comment)
[(Int, String)]
ls (L RealSrcSpan
l String
s) = ([(Int, String)]
ls', RealLocated Comment
comment)
where
comment :: RealLocated Comment
comment =
RealSrcSpan -> Comment -> RealLocated Comment
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l (Comment -> RealLocated Comment)
-> (NonEmpty String -> Comment)
-> NonEmpty String
-> RealLocated Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NonEmpty String -> Comment
Comment Bool
atomsBefore (NonEmpty String -> Comment)
-> (NonEmpty String -> NonEmpty String)
-> NonEmpty String
-> Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> NonEmpty String
removeConseqBlanks (NonEmpty String -> NonEmpty String)
-> (NonEmpty String -> NonEmpty String)
-> NonEmpty String
-> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> NonEmpty String -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropTrailing (NonEmpty String -> RealLocated Comment)
-> NonEmpty String -> RealLocated Comment
forall a b. (a -> b) -> a -> b
$
case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (String -> [String]
lines String
s) of
Maybe (NonEmpty String)
Nothing -> String
s String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
Just (String
x :| [String]
xs) ->
let getIndent :: String -> Int
getIndent String
y =
if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
y
then Int
startIndent
else String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace String
y)
n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
startIndent Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (String -> Int) -> [String] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
getIndent [String]
xs)
commentPrefix :: String
commentPrefix = if String
"{-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
s then String
"" else String
"-- "
in String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| ((String
commentPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs)
(Bool
atomsBefore, [(Int, String)]
ls') =
case ((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
commentLine) (Int -> Bool) -> ((Int, String) -> Int) -> (Int, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> Int
forall a b. (a, b) -> a
fst) [(Int, String)]
ls of
[] -> (Bool
False, [])
((Int
_, String
i) : [(Int, String)]
ls'') ->
case Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
i) of
String
"--" -> (Bool
False, [(Int, String)]
ls'')
String
"{-" -> (Bool
False, [(Int, String)]
ls'')
String
_ -> (Bool
True, [(Int, String)]
ls'')
dropTrailing :: String -> String
dropTrailing = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace
startIndent :: Int
startIndent = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
commentLine :: Int
commentLine = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l
unComment :: Comment -> NonEmpty String
(Comment Bool
_ NonEmpty String
xs) = NonEmpty String
xs
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore (Comment Bool
atomsBefore NonEmpty String
_) = Bool
atomsBefore
isMultilineComment :: Comment -> Bool
(Comment Bool
_ (String
x :| [String]
_)) = String
"{-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
x
extractStackHeader ::
[RealLocated String] ->
([RealLocated String], Maybe (RealLocated Comment))
= \case
[] -> ([], Maybe (RealLocated Comment)
forall a. Maybe a
Nothing)
(RealLocated String
x : [RealLocated String]
xs) ->
let comment :: RealLocated Comment
comment = ([(Int, String)], RealLocated Comment) -> RealLocated Comment
forall a b. (a, b) -> b
snd ([(Int, String)]
-> RealLocated String -> ([(Int, String)], RealLocated Comment)
mkComment [] RealLocated String
x)
in if Comment -> Bool
isStackHeader (RealLocated Comment -> Comment
forall a. RealLocated a -> a
unRealSrcSpan RealLocated Comment
comment)
then ([RealLocated String]
xs, RealLocated Comment -> Maybe (RealLocated Comment)
forall a. a -> Maybe a
Just RealLocated Comment
comment)
else (RealLocated String
x RealLocated String -> [RealLocated String] -> [RealLocated String]
forall a. a -> [a] -> [a]
: [RealLocated String]
xs, Maybe (RealLocated Comment)
forall a. Maybe a
Nothing)
where
isStackHeader :: Comment -> Bool
isStackHeader (Comment Bool
_ (String
x :| [String]
_)) =
String
"stack" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
x)
extractPragmas ::
String ->
[RealLocated String] ->
([RealLocated Comment], [([RealLocated Comment], Pragma)])
String
input = [(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)])
-> [RealLocated String]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
forall b.
[(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
initialLs [RealLocated Comment] -> [RealLocated Comment]
forall a. a -> a
id [([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)]
forall a. a -> a
id
where
initialLs :: [(Int, String)]
initialLs = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] (String -> [String]
lines String
input)
go :: [(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
ls [RealLocated Comment] -> [RealLocated Comment]
csSoFar [([RealLocated Comment], Pragma)] -> b
pragmasSoFar = \case
[] -> ([RealLocated Comment] -> [RealLocated Comment]
csSoFar [], [([RealLocated Comment], Pragma)] -> b
pragmasSoFar [])
(RealLocated String
x : [RealLocated String]
xs) ->
case String -> Maybe Pragma
parsePragma (RealLocated String -> String
forall a. RealLocated a -> a
unRealSrcSpan RealLocated String
x) of
Maybe Pragma
Nothing ->
let ([(Int, String)]
ls', RealLocated Comment
x') = [(Int, String)]
-> RealLocated String -> ([(Int, String)], RealLocated Comment)
mkComment [(Int, String)]
ls RealLocated String
x
in [(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
ls' ([RealLocated Comment] -> [RealLocated Comment]
csSoFar ([RealLocated Comment] -> [RealLocated Comment])
-> ([RealLocated Comment] -> [RealLocated Comment])
-> [RealLocated Comment]
-> [RealLocated Comment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated Comment
x' RealLocated Comment
-> [RealLocated Comment] -> [RealLocated Comment]
forall a. a -> [a] -> [a]
:)) [([RealLocated Comment], Pragma)] -> b
pragmasSoFar [RealLocated String]
xs
Just Pragma
pragma ->
let combined :: [RealLocated Comment] -> ([RealLocated Comment], Pragma)
combined [RealLocated Comment]
ys = ([RealLocated Comment] -> [RealLocated Comment]
csSoFar [RealLocated Comment]
ys, Pragma
pragma)
go' :: [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls' [RealLocated Comment]
ys [RealLocated String]
rest = [(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
ls' [RealLocated Comment] -> [RealLocated Comment]
forall a. a -> a
id ([([RealLocated Comment], Pragma)] -> b
pragmasSoFar ([([RealLocated Comment], Pragma)] -> b)
-> ([([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)])
-> [([RealLocated Comment], Pragma)]
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RealLocated Comment] -> ([RealLocated Comment], Pragma)
combined [RealLocated Comment]
ys ([RealLocated Comment], Pragma)
-> [([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)]
forall a. a -> [a] -> [a]
:)) [RealLocated String]
rest
in case [RealLocated String]
xs of
[] -> [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls [] [RealLocated String]
xs
(RealLocated String
y : [RealLocated String]
ys) ->
let ([(Int, String)]
ls', RealLocated Comment
y') = [(Int, String)]
-> RealLocated String -> ([(Int, String)], RealLocated Comment)
mkComment [(Int, String)]
ls RealLocated String
y
in if SrcSpan -> SrcSpan -> Bool
onTheSameLine
(RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealLocated String -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
x) Maybe BufSpan
forall a. Maybe a
Nothing)
(RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealLocated String -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
y) Maybe BufSpan
forall a. Maybe a
Nothing)
then [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls' [RealLocated Comment
y'] [RealLocated String]
ys
else [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls [] [RealLocated String]
xs
unAnnotationComment :: GHC.AnnotationComment -> String
= \case
GHC.AnnDocCommentNext String
s -> String -> String
dashPrefix String
s
GHC.AnnDocCommentPrev String
s -> String -> String
dashPrefix String
s
GHC.AnnDocCommentNamed String
s -> String -> String
dashPrefix String
s
GHC.AnnDocSection Int
_ String
s -> String -> String
dashPrefix String
s
GHC.AnnDocOptions String
s -> String
s
GHC.AnnLineComment String
s -> String
s
GHC.AnnBlockComment String
s -> String
s
where
dashPrefix :: String -> String
dashPrefix String
s = String
"--" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
spaceIfNecessary String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
where
spaceIfNecessary :: String
spaceIfNecessary = case String
s of
c : _ | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' -> String
" "
String
_ -> String
""
removeConseqBlanks :: NonEmpty String -> NonEmpty String
removeConseqBlanks :: NonEmpty String -> NonEmpty String
removeConseqBlanks (String
x :| [String]
xs) = String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| Bool -> ([String] -> [String]) -> [String] -> [String]
forall (t :: * -> *) a c.
Foldable t =>
Bool -> ([t a] -> c) -> [t a] -> c
go (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x) [String] -> [String]
forall a. a -> a
id [String]
xs
where
go :: Bool -> ([t a] -> c) -> [t a] -> c
go Bool
seenBlank [t a] -> c
acc = \case
[] -> [t a] -> c
acc []
(t a
y : [t a]
ys) ->
if Bool
seenBlank Bool -> Bool -> Bool
&& t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y
then Bool -> ([t a] -> c) -> [t a] -> c
go Bool
True [t a] -> c
acc [t a]
ys
else Bool -> ([t a] -> c) -> [t a] -> c
go (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y) ([t a] -> c
acc ([t a] -> c) -> ([t a] -> [t a]) -> [t a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a
y t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:)) [t a]
ys