{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
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 Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Lazy qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Data.Strict qualified as Strict
import GHC.Hs (HsModule)
import GHC.Hs.Doc
import GHC.Hs.Extension
import GHC.Hs.ImpExp
import GHC.Parser.Annotation (EpAnnComments (..), getLocA)
import GHC.Parser.Annotation qualified as GHC
import GHC.Types.SrcLoc
import Ormolu.Parser.Pragma
import Ormolu.Utils (onTheSameLine, showOutputable)
newtype = [RealLocated Comment]
deriving (CommentStream -> CommentStream -> Bool
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, Typeable CommentStream
CommentStream -> DataType
CommentStream -> Constr
(forall b. Data b => b -> b) -> CommentStream -> CommentStream
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CommentStream
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CommentStream)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CommentStream)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
gmapT :: (forall b. Data b => b -> b) -> CommentStream -> CommentStream
$cgmapT :: (forall b. Data b => b -> b) -> CommentStream -> CommentStream
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CommentStream)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CommentStream)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CommentStream)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CommentStream)
dataTypeOf :: CommentStream -> DataType
$cdataTypeOf :: CommentStream -> DataType
toConstr :: CommentStream -> Constr
$ctoConstr :: CommentStream -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CommentStream
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CommentStream
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
Data, NonEmpty CommentStream -> CommentStream
CommentStream -> CommentStream -> 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 :: forall b. Integral b => 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
[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
Monoid)
mkCommentStream ::
Text ->
HsModule GhcPs ->
( Maybe (RealLocated Comment),
[([RealLocated Comment], Pragma)],
CommentStream
)
Text
input HsModule GhcPs
hsModule =
( Maybe (RealLocated Comment)
mstackHeader,
[([RealLocated Comment], Pragma)]
pragmas,
[RealLocated Comment] -> CommentStream
CommentStream [RealLocated Comment]
comments
)
where
([RealLocated Comment]
comments, [([RealLocated Comment], Pragma)]
pragmas) = Text
-> [RealLocated Text]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas Text
input [RealLocated Text]
rawComments1
([RealLocated Text]
rawComments1, Maybe (RealLocated Comment)
mstackHeader) = [RealLocated Text]
-> ([RealLocated Text], Maybe (RealLocated Comment))
extractStackHeader [RealLocated Text]
rawComments0
rawComments0 :: [RealLocated Text]
rawComments0 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall l e. l -> e -> GenLocated l e
L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toAscList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Set RealSrcSpan
validHaddockCommentSpans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(L RealSrcSpan
l Text
a) -> (RealSrcSpan
l, Text
a))
forall a b. (a -> b) -> a -> b
$ [RealLocated Text]
allComments
where
allComments :: [RealLocated Text]
allComments =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment forall a b. (a -> b) -> a -> b
$
EpAnnComments -> [LEpaComment]
epAnnCommentsToList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (forall a. a -> Bool
only @EpAnnComments) HsModule GhcPs
hsModule
where
epAnnCommentsToList :: EpAnnComments -> [LEpaComment]
epAnnCommentsToList = \case
EpaComments [LEpaComment]
cs -> [LEpaComment]
cs
EpaCommentsBalanced [LEpaComment]
pcs [LEpaComment]
fcs -> [LEpaComment]
pcs forall a. Semigroup a => a -> a -> a
<> [LEpaComment]
fcs
validHaddockCommentSpans :: Set RealSrcSpan
validHaddockCommentSpans =
forall a. Ord a => [a] -> Set a
S.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat
[ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> l
getLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (forall a. a -> Bool
only @(LHsDoc GhcPs)),
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify LIE GhcPs -> Bool
isIEDocLike
]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs
hsModule
where
isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike = \case
L SrcSpanAnn' (EpAnn AnnListItem)
_ IEGroup {} -> Bool
True
L SrcSpanAnn' (EpAnn AnnListItem)
_ IEDoc {} -> Bool
True
L SrcSpanAnn' (EpAnn AnnListItem)
_ IEDocNamed {} -> Bool
True
LIE GhcPs
_ -> Bool
False
only :: a -> Bool
only :: forall a. a -> Bool
only a
_ = Bool
True
showCommentStream :: CommentStream -> String
(CommentStream [RealLocated Comment]
xs) =
[String] -> String
unlines forall a b. (a -> b) -> a -> b
$
forall {o} {a}. (Outputable o, Show a) => GenLocated o a -> String
showComment 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) = forall o. Outputable o => o -> String
showOutputable o
l forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
str
data = Bool (NonEmpty Text)
deriving (Comment -> Comment -> Bool
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 -> ShowS
[Comment] -> ShowS
Comment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comment] -> ShowS
$cshowList :: [Comment] -> ShowS
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> ShowS
$cshowsPrec :: Int -> Comment -> ShowS
Show, Typeable Comment
Comment -> DataType
Comment -> Constr
(forall b. Data b => b -> b) -> Comment -> Comment
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
forall u. (forall d. Data d => d -> u) -> Comment -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Comment
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Comment)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Comment)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Comment -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Comment -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
gmapT :: (forall b. Data b => b -> b) -> Comment -> Comment
$cgmapT :: (forall b. Data b => b -> b) -> Comment -> Comment
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Comment)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Comment)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Comment)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Comment)
dataTypeOf :: Comment -> DataType
$cdataTypeOf :: Comment -> DataType
toConstr :: Comment -> Constr
$ctoConstr :: Comment -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Comment
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Comment
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
Data)
mkComment ::
[(Int, Text)] ->
RealLocated Text ->
([(Int, Text)], RealLocated Comment)
[(Int, Text)]
ls (L RealSrcSpan
l Text
s) = ([(Int, Text)]
ls', RealLocated Comment
comment)
where
comment :: RealLocated Comment
comment =
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NonEmpty Text -> Comment
Comment Bool
atomsBefore forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> NonEmpty Text
removeConseqBlanks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.stripEnd forall a b. (a -> b) -> a -> b
$
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (Text -> [Text]
T.lines Text
s) of
Maybe (NonEmpty Text)
Nothing -> Text
s forall a. a -> [a] -> NonEmpty a
:| []
Just (Text
x :| [Text]
xs) ->
let getIndent :: Text -> Int
getIndent Text
y =
if (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
y
then Int
startIndent
else Text -> Int
T.length ((Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isSpace Text
y)
n :: Int
n = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
startIndent forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
getIndent [Text]
xs)
commentPrefix :: Text
commentPrefix = if Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
s then Text
"" else Text
"-- "
in Text
x forall a. a -> [a] -> NonEmpty a
:| ((Text
commentPrefix <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeHaddockTriggers forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs)
(Bool
atomsBefore, [(Int, Text)]
ls') =
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
< Int
commentLine) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Int, Text)]
ls of
[] -> (Bool
False, [])
((Int
_, Text
i) : [(Int, Text)]
ls'') ->
case Int -> Text -> Text
T.take Int
2 (Text -> Text
T.stripStart Text
i) of
Text
"--" -> (Bool
False, [(Int, Text)]
ls'')
Text
"{-" -> (Bool
False, [(Int, Text)]
ls'')
Text
_ -> (Bool
True, [(Int, Text)]
ls'')
startIndent :: Int
startIndent
| Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
s = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l forall a. Num a => a -> a -> a
- Int
1
| Bool
otherwise = Int
1
commentLine :: Int
commentLine = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l
unComment :: Comment -> NonEmpty Text
(Comment Bool
_ NonEmpty Text
xs) = NonEmpty Text
xs
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore (Comment Bool
atomsBefore NonEmpty Text
_) = Bool
atomsBefore
isMultilineComment :: Comment -> Bool
(Comment Bool
_ (Text
x :| [Text]
_)) = Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
x
extractStackHeader ::
[RealLocated Text] ->
([RealLocated Text], Maybe (RealLocated Comment))
= \case
[] -> ([], forall a. Maybe a
Nothing)
(RealLocated Text
x : [RealLocated Text]
xs) ->
let comment :: RealLocated Comment
comment = forall a b. (a, b) -> b
snd ([(Int, Text)]
-> RealLocated Text -> ([(Int, Text)], RealLocated Comment)
mkComment [] RealLocated Text
x)
in if Comment -> Bool
isStackHeader (forall a. RealLocated a -> a
unRealSrcSpan RealLocated Comment
comment)
then ([RealLocated Text]
xs, forall a. a -> Maybe a
Just RealLocated Comment
comment)
else (RealLocated Text
x forall a. a -> [a] -> [a]
: [RealLocated Text]
xs, forall a. Maybe a
Nothing)
where
isStackHeader :: Comment -> Bool
isStackHeader (Comment Bool
_ (Text
x :| [Text]
_)) =
Text
"stack" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.stripStart (Int -> Text -> Text
T.drop Int
2 Text
x)
extractPragmas ::
Text ->
[RealLocated Text] ->
([RealLocated Comment], [([RealLocated Comment], Pragma)])
Text
input = forall {b}.
[(Int, Text)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go [(Int, Text)]
initialLs forall a. a -> a
id forall a. a -> a
id
where
initialLs :: [(Int, Text)]
initialLs = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] (Text -> [Text]
T.lines Text
input)
go :: [(Int, Text)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go [(Int, Text)]
ls [RealLocated Comment] -> [RealLocated Comment]
csSoFar [([RealLocated Comment], Pragma)] -> b
pragmasSoFar = \case
[] -> ([RealLocated Comment] -> [RealLocated Comment]
csSoFar [], [([RealLocated Comment], Pragma)] -> b
pragmasSoFar [])
(RealLocated Text
x : [RealLocated Text]
xs) ->
case Text -> Maybe Pragma
parsePragma (forall a. RealLocated a -> a
unRealSrcSpan RealLocated Text
x) of
Maybe Pragma
Nothing ->
let ([(Int, Text)]
ls', RealLocated Comment
x') = [(Int, Text)]
-> RealLocated Text -> ([(Int, Text)], RealLocated Comment)
mkComment [(Int, Text)]
ls RealLocated Text
x
in [(Int, Text)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go [(Int, Text)]
ls' ([RealLocated Comment] -> [RealLocated Comment]
csSoFar forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated Comment
x' :)) [([RealLocated Comment], Pragma)] -> b
pragmasSoFar [RealLocated Text]
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, Text)]
-> [RealLocated Comment]
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go' [(Int, Text)]
ls' [RealLocated Comment]
ys [RealLocated Text]
rest = [(Int, Text)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go [(Int, Text)]
ls' forall a. a -> a
id ([([RealLocated Comment], Pragma)] -> b
pragmasSoFar forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RealLocated Comment] -> ([RealLocated Comment], Pragma)
combined [RealLocated Comment]
ys :)) [RealLocated Text]
rest
in case [RealLocated Text]
xs of
[] -> [(Int, Text)]
-> [RealLocated Comment]
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go' [(Int, Text)]
ls [] [RealLocated Text]
xs
(RealLocated Text
y : [RealLocated Text]
ys) ->
let ([(Int, Text)]
ls', RealLocated Comment
y') = [(Int, Text)]
-> RealLocated Text -> ([(Int, Text)], RealLocated Comment)
mkComment [(Int, Text)]
ls RealLocated Text
y
in if SrcSpan -> SrcSpan -> Bool
onTheSameLine
(RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated Text
x) forall a. Maybe a
Strict.Nothing)
(RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated Text
y) forall a. Maybe a
Strict.Nothing)
then [(Int, Text)]
-> [RealLocated Comment]
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go' [(Int, Text)]
ls' [RealLocated Comment
y'] [RealLocated Text]
ys
else [(Int, Text)]
-> [RealLocated Comment]
-> [RealLocated Text]
-> ([RealLocated Comment], b)
go' [(Int, Text)]
ls [] [RealLocated Text]
xs
unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)
(L (GHC.Anchor RealSrcSpan
anchor AnchorOperation
_) (GHC.EpaComment EpaCommentTok
eck RealSrcSpan
_)) =
case EpaCommentTok
eck of
GHC.EpaDocComment HsDocString
s ->
let trigger :: Maybe HsDocStringDecorator
trigger = case HsDocString
s of
MultiLineDocString HsDocStringDecorator
t NonEmpty LHsDocStringChunk
_ -> forall a. a -> Maybe a
Just HsDocStringDecorator
t
NestedDocString HsDocStringDecorator
t LHsDocStringChunk
_ -> forall a. a -> Maybe a
Just HsDocStringDecorator
t
GeneratedDocString HsDocStringChunk
_ -> forall a. Maybe a
Nothing
in Maybe HsDocStringDecorator -> Text -> Maybe (RealLocated Text)
haddock Maybe HsDocStringDecorator
trigger (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ HsDocString -> String
renderHsDocString HsDocString
s)
GHC.EpaDocOptions String
s -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (String -> Text
T.pack String
s)
GHC.EpaLineComment (String -> Text
T.pack -> Text
s) -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL forall a b. (a -> b) -> a -> b
$
case Int -> Text -> Text
T.take Int
3 Text
s of
Text
"-- " -> Text
s
Text
"---" -> Text
s
Text
_ -> Text -> Text -> Int -> Text
insertAt Text
" " Text
s Int
3
GHC.EpaBlockComment String
s -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (String -> Text
T.pack String
s)
EpaCommentTok
GHC.EpaEofComment -> forall a. Maybe a
Nothing
where
mkL :: a -> Maybe (GenLocated RealSrcSpan a)
mkL = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L RealSrcSpan
anchor
insertAt :: Text -> Text -> Int -> Text
insertAt Text
x Text
xs Int
n = Int -> Text -> Text
T.take (Int
n forall a. Num a => a -> a -> a
- Int
1) Text
xs forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop (Int
n forall a. Num a => a -> a -> a
- Int
1) Text
xs
haddock :: Maybe HsDocStringDecorator -> Text -> Maybe (RealLocated Text)
haddock Maybe HsDocStringDecorator
mtrigger =
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dashPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeHaddockTriggers forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
trigger <>) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Maybe Text
dropBlank
where
trigger :: Text
trigger = case Maybe HsDocStringDecorator
mtrigger of
Just HsDocStringDecorator
HsDocStringNext -> Text
"|"
Just HsDocStringDecorator
HsDocStringPrevious -> Text
"^"
Just (HsDocStringNamed String
n) -> Text
"$" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
n
Just (HsDocStringGroup Int
k) -> Int -> Text -> Text
T.replicate Int
k Text
"*"
Maybe HsDocStringDecorator
Nothing -> Text
""
dashPrefix :: Text -> Text
dashPrefix Text
s = Text
"--" forall a. Semigroup a => a -> a -> a
<> Text
spaceIfNecessary forall a. Semigroup a => a -> a -> a
<> Text
s
where
spaceIfNecessary :: Text
spaceIfNecessary = case Text -> Maybe (Char, Text)
T.uncons Text
s of
Just (Char
c, Text
_) | Char
c forall a. Eq a => a -> a -> Bool
/= Char
' ' -> Text
" "
Maybe (Char, Text)
_ -> Text
""
dropBlank :: Text -> Maybe Text
dropBlank :: Text -> Maybe Text
dropBlank Text
s = if (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
s then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Text
s
removeConseqBlanks :: NonEmpty Text -> NonEmpty Text
removeConseqBlanks :: NonEmpty Text -> NonEmpty Text
removeConseqBlanks (Text
x :| [Text]
xs) = Text
x forall a. a -> [a] -> NonEmpty a
:| forall {t}. Bool -> ([Text] -> t) -> [Text] -> t
go (Text -> Bool
T.null Text
x) forall a. a -> a
id [Text]
xs
where
go :: Bool -> ([Text] -> t) -> [Text] -> t
go Bool
seenBlank [Text] -> t
acc = \case
[] -> [Text] -> t
acc []
(Text
y : [Text]
ys) ->
if Bool
seenBlank Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
y
then Bool -> ([Text] -> t) -> [Text] -> t
go Bool
True [Text] -> t
acc [Text]
ys
else Bool -> ([Text] -> t) -> [Text] -> t
go (Text -> Bool
T.null Text
y) ([Text] -> t
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
y :)) [Text]
ys
escapeHaddockTriggers :: Text -> Text
escapeHaddockTriggers :: Text -> Text
escapeHaddockTriggers Text
string
| Just (Char
h, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
string, Char
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"|^*$" :: [Char]) = Char -> Text -> Text
T.cons Char
'\\' Text
string
| Bool
otherwise = Text
string