{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Ormolu.Parser.CommentStream
(
CommentStream (..),
mkCommentStream,
showCommentStream,
Comment (..),
unComment,
hasAtomsBefore,
isMultilineComment,
)
where
import Control.Monad ((<=<))
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 GHC.Parser.Annotation (EpAnnComments (..), getLocA)
import qualified GHC.Parser.Annotation as GHC
import GHC.Types.SrcLoc
import Ormolu.Parser.Pragma
import Ormolu.Utils (onTheSameLine, showOutputable)
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 ->
HsModule ->
( Maybe (RealLocated Comment),
[([RealLocated Comment], Pragma)],
CommentStream
)
String
input 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 =
(LEpaComment -> Maybe (RealLocated String))
-> [LEpaComment] -> [RealLocated String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealLocated String)
unAnnotationComment ([LEpaComment] -> [RealLocated String])
-> [LEpaComment] -> [RealLocated String]
forall a b. (a -> b) -> a -> b
$
EpAnnComments -> [LEpaComment]
epAnnCommentsToList (EpAnnComments -> [LEpaComment])
-> [EpAnnComments] -> [LEpaComment]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (EpAnnComments -> Bool) -> HsModule -> [EpAnnComments]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (EpAnnComments -> Bool
forall a. a -> Bool
only @EpAnnComments) HsModule
hsModule
where
epAnnCommentsToList :: EpAnnComments -> [LEpaComment]
epAnnCommentsToList = \case
EpaComments [LEpaComment]
cs -> [LEpaComment]
cs
EpaCommentsBalanced [LEpaComment]
pcs [LEpaComment]
fcs -> [LEpaComment]
pcs [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> [LEpaComment]
fcs
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
srcSpanToRealSrcSpan
([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 (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
-> [SrcSpan])
-> (HsModule
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> Bool)
-> GenericQ [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (LDocDecl GhcPs -> Bool
forall a. a -> Bool
only @(LDocDecl GhcPs)),
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
-> [SrcSpan])
-> (HsModule
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> Bool)
-> GenericQ
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify LHsDecl GhcPs -> Bool
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs) -> Bool
isDocD,
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)
-> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
-> [SrcSpan])
-> (HsModule
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> Bool)
-> GenericQ
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify LIE GhcPs -> Bool
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> Bool
isIEDocLike
]
(HsModule -> Set RealSrcSpan) -> HsModule -> Set RealSrcSpan
forall a b. (a -> b) -> a -> b
$ HsModule
hsModule
where
isDocD :: LHsDecl GhcPs -> Bool
isDocD :: LHsDecl GhcPs -> Bool
isDocD = \case
L _ DocD {} -> Bool
True
LHsDecl GhcPs
_ -> Bool
False
isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike = \case
L _ IEGroup {} -> Bool
True
L _ IEDoc {} -> Bool
True
L _ IEDocNamed {} -> Bool
True
LIE GhcPs
_ -> Bool
False
only :: a -> Bool
only :: a -> Bool
only a
_ = Bool
True
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.LEpaComment -> Maybe (RealLocated String)
(L (GHC.Anchor RealSrcSpan
anchor AnchorOperation
_) (GHC.EpaComment EpaCommentTok
eck RealSrcSpan
_)) = case EpaCommentTok
eck of
GHC.EpaDocCommentNext String
s -> String -> Maybe (RealLocated String)
haddock String
s
GHC.EpaDocCommentPrev String
s -> String -> Maybe (RealLocated String)
haddock String
s
GHC.EpaDocCommentNamed String
s -> String -> Maybe (RealLocated String)
haddock String
s
GHC.EpaDocSection Int
_ String
s -> String -> Maybe (RealLocated String)
haddock String
s
GHC.EpaDocOptions String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL String
s
GHC.EpaLineComment String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL (String -> Maybe (RealLocated String))
-> String -> Maybe (RealLocated String)
forall a b. (a -> b) -> a -> b
$
case Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
3 String
s of
String
"-- " -> String
s
String
"---" -> String
s
String
_ -> let s' :: String
s' = String -> String -> Int -> String
forall a. [a] -> [a] -> Int -> [a]
insertAt String
" " String
s Int
3 in String
s'
GHC.EpaBlockComment String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL String
s
EpaCommentTok
GHC.EpaEofComment -> Maybe (RealLocated String)
forall a. Maybe a
Nothing
where
mkL :: e -> Maybe (GenLocated RealSrcSpan e)
mkL = GenLocated RealSrcSpan e -> Maybe (GenLocated RealSrcSpan e)
forall a. a -> Maybe a
Just (GenLocated RealSrcSpan e -> Maybe (GenLocated RealSrcSpan e))
-> (e -> GenLocated RealSrcSpan e)
-> e
-> Maybe (GenLocated RealSrcSpan e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> e -> GenLocated RealSrcSpan e
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
anchor
insertAt :: [a] -> [a] -> Int -> [a]
insertAt [a]
x [a]
xs Int
n = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
haddock :: String -> Maybe (RealLocated String)
haddock = String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL (String -> Maybe (RealLocated String))
-> (String -> String) -> String -> Maybe (RealLocated String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dashPrefix (String -> Maybe (RealLocated String))
-> (String -> Maybe String) -> String -> Maybe (RealLocated String)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Maybe String
dropBlank
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
""
dropBlank :: String -> Maybe String
dropBlank :: String -> Maybe String
dropBlank String
s = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
s
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