{-# 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 qualified GHC.Data.Strict 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 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
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 ::
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 =
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 String
a) -> (RealSrcSpan
l, String
a))
forall a b. (a -> b) -> a -> b
$ [RealLocated String]
allComments
where
allComments :: [RealLocated String]
allComments =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealLocated String)
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
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
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 String)
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, 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 =
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NonEmpty String -> Comment
Comment Bool
atomsBefore forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> NonEmpty String
removeConseqBlanks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
dropTrailing forall a b. (a -> b) -> a -> b
$
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (String -> [String]
lines String
s) of
Maybe (NonEmpty String)
Nothing -> String
s forall a. a -> [a] -> NonEmpty a
:| []
Just (String
x :| [String]
xs) ->
let getIndent :: String -> Int
getIndent String
y =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
y
then Int
startIndent
else forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace String
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 String -> Int
getIndent [String]
xs)
commentPrefix :: String
commentPrefix = if String
"{-" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
s then String
"" else String
"-- "
in String
x forall a. a -> [a] -> NonEmpty a
:| ((String
commentPrefix forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeHaddockTriggers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs)
(Bool
atomsBefore, [(Int, String)]
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, String)]
ls of
[] -> (Bool
False, [])
((Int
_, String
i) : [(Int, String)]
ls'') ->
case forall a. Int -> [a] -> [a]
take Int
2 (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 :: ShowS
dropTrailing = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace
startIndent :: Int
startIndent
| String
"{-" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
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 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
"{-" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
x
extractStackHeader ::
[RealLocated String] ->
([RealLocated String], Maybe (RealLocated Comment))
= \case
[] -> ([], forall a. Maybe a
Nothing)
(RealLocated String
x : [RealLocated String]
xs) ->
let comment :: RealLocated Comment
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 (forall a. RealLocated a -> a
unRealSrcSpan RealLocated Comment
comment)
then ([RealLocated String]
xs, forall a. a -> Maybe a
Just RealLocated Comment
comment)
else (RealLocated String
x forall a. a -> [a] -> [a]
: [RealLocated String]
xs, forall a. Maybe a
Nothing)
where
isStackHeader :: Comment -> Bool
isStackHeader (Comment Bool
_ (String
x :| [String]
_)) =
String
"stack" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (forall a. Int -> [a] -> [a]
drop Int
2 String
x)
extractPragmas ::
String ->
[RealLocated String] ->
([RealLocated Comment], [([RealLocated Comment], Pragma)])
String
input = forall {b}.
[(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
initialLs forall a. a -> a
id forall a. a -> a
id
where
initialLs :: [(Int, String)]
initialLs = 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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated Comment
x' 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' 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 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 (forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
x) forall a. Maybe a
Strict.Nothing)
(RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
y) forall a. Maybe a
Strict.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.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 -> String -> Maybe (RealLocated String)
haddock Maybe HsDocStringDecorator
trigger (HsDocString -> String
renderHsDocString HsDocString
s)
GHC.EpaDocOptions String
s -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL String
s
GHC.EpaLineComment String
s -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL forall a b. (a -> b) -> a -> b
$
case forall a. Int -> [a] -> [a]
take Int
3 String
s of
String
"-- " -> String
s
String
"---" -> String
s
String
_ -> let s' :: String
s' = forall {a}. [a] -> [a] -> Int -> [a]
insertAt String
" " String
s Int
3 in String
s'
GHC.EpaBlockComment String
s -> forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL 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 :: [a] -> [a] -> Int -> [a]
insertAt [a]
x [a]
xs Int
n = forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
1) [a]
xs forall a. [a] -> [a] -> [a]
++ [a]
x forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
n forall a. Num a => a -> a -> a
- Int
1) [a]
xs
haddock :: Maybe HsDocStringDecorator -> String -> Maybe (RealLocated String)
haddock Maybe HsDocStringDecorator
mtrigger =
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dashPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeHaddockTriggers forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
trigger forall a. Semigroup a => a -> a -> a
<>) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Maybe String
dropBlank
where
trigger :: String
trigger = case Maybe HsDocStringDecorator
mtrigger of
Just HsDocStringDecorator
HsDocStringNext -> String
"|"
Just HsDocStringDecorator
HsDocStringPrevious -> String
"^"
Just (HsDocStringNamed String
n) -> String
"$" forall a. Semigroup a => a -> a -> a
<> String
n
Just (HsDocStringGroup Int
k) -> forall a. Int -> a -> [a]
replicate Int
k Char
'*'
Maybe HsDocStringDecorator
Nothing -> String
""
dashPrefix :: ShowS
dashPrefix String
s = String
"--" forall a. Semigroup a => a -> a -> a
<> String
spaceIfNecessary forall a. Semigroup a => a -> a -> a
<> String
s
where
spaceIfNecessary :: String
spaceIfNecessary = case String
s of
Char
c : String
_ | Char
c forall a. Eq a => a -> a -> Bool
/= Char
' ' -> String
" "
String
_ -> String
""
dropBlank :: String -> Maybe String
dropBlank :: String -> Maybe String
dropBlank String
s = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s then forall a. Maybe a
Nothing else 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 forall a. a -> [a] -> NonEmpty a
:| forall {t :: * -> *} {a} {t}.
Foldable t =>
Bool -> ([t a] -> t) -> [t a] -> t
go (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x) forall a. a -> a
id [String]
xs
where
go :: Bool -> ([t a] -> t) -> [t a] -> t
go Bool
seenBlank [t a] -> t
acc = \case
[] -> [t a] -> t
acc []
(t a
y : [t a]
ys) ->
if Bool
seenBlank Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y
then Bool -> ([t a] -> t) -> [t a] -> t
go Bool
True [t a] -> t
acc [t a]
ys
else Bool -> ([t a] -> t) -> [t a] -> t
go (forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y) ([t a] -> t
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a
y forall a. a -> [a] -> [a]
:)) [t a]
ys
escapeHaddockTriggers :: String -> String
escapeHaddockTriggers :: ShowS
escapeHaddockTriggers String
string
| Char
h : String
_ <- String
string, Char
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"|^*$" = Char
'\\' forall a. a -> [a] -> [a]
: String
string
| Bool
otherwise = String
string