{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- | Functions for working with comment stream.
module Ormolu.Parser.CommentStream
  ( -- * Comment stream
    CommentStream (..),
    mkCommentStream,

    -- * Comment
    LComment,
    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)

----------------------------------------------------------------------------
-- Comment stream

-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
-- beginning of corresponding spans.
newtype CommentStream = CommentStream [LComment]
  deriving (CommentStream -> CommentStream -> Bool
(CommentStream -> CommentStream -> Bool)
-> (CommentStream -> CommentStream -> Bool) -> Eq CommentStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommentStream -> CommentStream -> Bool
== :: CommentStream -> CommentStream -> Bool
$c/= :: CommentStream -> CommentStream -> Bool
/= :: CommentStream -> CommentStream -> Bool
Eq, Typeable CommentStream
Typeable CommentStream =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> CommentStream -> c CommentStream)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c CommentStream)
-> (CommentStream -> Constr)
-> (CommentStream -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> CommentStream -> CommentStream)
-> (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 u. (forall d. Data d => d -> u) -> CommentStream -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> CommentStream -> u)
-> (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 (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CommentStream -> m CommentStream)
-> Data CommentStream
CommentStream -> Constr
CommentStream -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CommentStream
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CommentStream
$ctoConstr :: CommentStream -> Constr
toConstr :: CommentStream -> Constr
$cdataTypeOf :: CommentStream -> DataType
dataTypeOf :: CommentStream -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CommentStream)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CommentStream)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CommentStream)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CommentStream)
$cgmapT :: (forall b. Data b => b -> b) -> CommentStream -> CommentStream
gmapT :: (forall b. Data b => b -> b) -> CommentStream -> CommentStream
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CommentStream -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CommentStream -> m CommentStream
Data, 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
$c<> :: CommentStream -> CommentStream -> CommentStream
<> :: CommentStream -> CommentStream -> CommentStream
$csconcat :: NonEmpty CommentStream -> CommentStream
sconcat :: NonEmpty CommentStream -> CommentStream
$cstimes :: forall b. Integral b => b -> CommentStream -> CommentStream
stimes :: forall b. Integral b => b -> 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
$cmempty :: CommentStream
mempty :: CommentStream
$cmappend :: CommentStream -> CommentStream -> CommentStream
mappend :: CommentStream -> CommentStream -> CommentStream
$cmconcat :: [CommentStream] -> CommentStream
mconcat :: [CommentStream] -> CommentStream
Monoid)

-- | Create 'CommentStream' from 'HsModule'. The pragmas are
-- removed from the 'CommentStream'.
mkCommentStream ::
  -- | Original input
  Text ->
  -- | Module to use for comment extraction
  HsModule GhcPs ->
  -- | Stack header, pragmas, and comment stream
  ( Maybe LComment,
    [([LComment], Pragma)],
    CommentStream
  )
mkCommentStream :: Text
-> HsModule GhcPs
-> (Maybe LComment, [([LComment], Pragma)], CommentStream)
mkCommentStream Text
input HsModule GhcPs
hsModule =
  ( Maybe LComment
mstackHeader,
    [([LComment], Pragma)]
pragmas,
    [LComment] -> CommentStream
CommentStream [LComment]
comments
  )
  where
    ([LComment]
comments, [([LComment], Pragma)]
pragmas) = Text -> [RealLocated Text] -> ([LComment], [([LComment], Pragma)])
extractPragmas Text
input [RealLocated Text]
rawComments1
    ([RealLocated Text]
rawComments1, Maybe LComment
mstackHeader) = [RealLocated Text] -> ([RealLocated Text], Maybe LComment)
extractStackHeader [RealLocated Text]
rawComments0

    -- We want to extract all comments except _valid_ Haddock comments
    rawComments0 :: [RealLocated Text]
rawComments0 =
      ((RealSrcSpan, Text) -> RealLocated Text)
-> [(RealSrcSpan, Text)] -> [RealLocated Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RealSrcSpan -> Text -> RealLocated Text)
-> (RealSrcSpan, Text) -> RealLocated Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealSrcSpan -> Text -> RealLocated Text
forall l e. l -> e -> GenLocated l e
L)
        ([(RealSrcSpan, Text)] -> [RealLocated Text])
-> ([RealLocated Text] -> [(RealSrcSpan, Text)])
-> [RealLocated Text]
-> [RealLocated Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RealSrcSpan Text -> [(RealSrcSpan, Text)]
forall k a. Map k a -> [(k, a)]
M.toAscList
        (Map RealSrcSpan Text -> [(RealSrcSpan, Text)])
-> ([RealLocated Text] -> Map RealSrcSpan Text)
-> [RealLocated Text]
-> [(RealSrcSpan, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map RealSrcSpan Text -> Set RealSrcSpan -> Map RealSrcSpan Text)
-> Set RealSrcSpan -> Map RealSrcSpan Text -> Map RealSrcSpan Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map RealSrcSpan Text -> Set RealSrcSpan -> Map RealSrcSpan Text
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Set RealSrcSpan
validHaddockCommentSpans
        (Map RealSrcSpan Text -> Map RealSrcSpan Text)
-> ([RealLocated Text] -> Map RealSrcSpan Text)
-> [RealLocated Text]
-> Map RealSrcSpan Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealSrcSpan, Text)] -> Map RealSrcSpan Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        ([(RealSrcSpan, Text)] -> Map RealSrcSpan Text)
-> ([RealLocated Text] -> [(RealSrcSpan, Text)])
-> [RealLocated Text]
-> Map RealSrcSpan Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated Text -> (RealSrcSpan, Text))
-> [RealLocated Text] -> [(RealSrcSpan, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(L RealSrcSpan
l Text
a) -> (RealSrcSpan
l, Text
a))
        ([RealLocated Text] -> [RealLocated Text])
-> [RealLocated Text] -> [RealLocated Text]
forall a b. (a -> b) -> a -> b
$ [RealLocated Text]
allComments
      where
        -- All comments, including valid and invalid Haddock comments
        allComments :: [RealLocated Text]
allComments =
          (LEpaComment -> Maybe (RealLocated Text))
-> [LEpaComment] -> [RealLocated Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment ([LEpaComment] -> [RealLocated Text])
-> [LEpaComment] -> [RealLocated Text]
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) -> GenericQ [EpAnnComments]
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 [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> [LEpaComment]
fcs
        -- All spans of valid Haddock comments
        validHaddockCommentSpans :: Set RealSrcSpan
validHaddockCommentSpans =
          [RealSrcSpan] -> Set RealSrcSpan
forall a. Ord a => [a] -> Set a
S.fromList
            ([RealSrcSpan] -> Set RealSrcSpan)
-> (HsModule GhcPs -> [RealSrcSpan])
-> HsModule GhcPs
-> 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 GhcPs -> [SrcSpan]) -> HsModule GhcPs -> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsModule GhcPs -> [SrcSpan]] -> HsModule GhcPs -> [SrcSpan]
forall a. Monoid a => [a] -> a
mconcat
              [ (GenLocated SrcSpan (HsDoc GhcPs) -> SrcSpan)
-> [GenLocated SrcSpan (HsDoc GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan (HsDoc GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan (HsDoc GhcPs)] -> [SrcSpan])
-> (HsModule GhcPs -> [GenLocated SrcSpan (HsDoc GhcPs)])
-> HsModule GhcPs
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan (HsDoc GhcPs) -> Bool)
-> GenericQ [GenLocated SrcSpan (HsDoc GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (forall a. a -> Bool
only @(LHsDoc GhcPs)),
                (GenLocated SrcSpanAnnA (IE GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (IE GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (IE GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA ([GenLocated SrcSpanAnnA (IE GhcPs)] -> [SrcSpan])
-> (HsModule GhcPs -> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> HsModule GhcPs
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (IE GhcPs) -> Bool)
-> GenericQ [GenLocated SrcSpanAnnA (IE GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify LIE GhcPs -> Bool
GenLocated SrcSpanAnnA (IE GhcPs) -> Bool
isIEDocLike
              ]
            (HsModule GhcPs -> Set RealSrcSpan)
-> HsModule GhcPs -> Set RealSrcSpan
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs
hsModule
          where
            isIEDocLike :: LIE GhcPs -> Bool
            isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike = \case
              L SrcSpanAnnA
_ IEGroup {} -> Bool
True
              L SrcSpanAnnA
_ IEDoc {} -> Bool
True
              L SrcSpanAnnA
_ IEDocNamed {} -> Bool
True
              LIE GhcPs
_ -> Bool
False
    only :: a -> Bool
    only :: forall a. a -> Bool
only a
_ = Bool
True

----------------------------------------------------------------------------
-- Comment

type LComment = RealLocated Comment

-- | A wrapper for a single comment. The 'Bool' indicates whether there were
-- atoms before beginning of the comment in the original input. The
-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or
-- just single item\/line otherwise.
data Comment = Comment Bool (NonEmpty Text)
  deriving (Comment -> Comment -> Bool
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
/= :: Comment -> Comment -> Bool
Eq, Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
(Int -> Comment -> ShowS)
-> (Comment -> String) -> ([Comment] -> ShowS) -> Show Comment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Comment -> ShowS
showsPrec :: Int -> Comment -> ShowS
$cshow :: Comment -> String
show :: Comment -> String
$cshowList :: [Comment] -> ShowS
showList :: [Comment] -> ShowS
Show, Typeable Comment
Typeable Comment =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Comment -> c Comment)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Comment)
-> (Comment -> Constr)
-> (Comment -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> Comment -> Comment)
-> (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 u. (forall d. Data d => d -> u) -> Comment -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u)
-> (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 (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Comment -> m Comment)
-> Data Comment
Comment -> Constr
Comment -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Comment
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Comment
$ctoConstr :: Comment -> Constr
toConstr :: Comment -> Constr
$cdataTypeOf :: Comment -> DataType
dataTypeOf :: Comment -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Comment)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Comment)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Comment)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Comment)
$cgmapT :: (forall b. Data b => b -> b) -> Comment -> Comment
gmapT :: (forall b. Data b => b -> b) -> Comment -> Comment
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Comment -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Comment -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Comment -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Comment -> m Comment
Data)

-- | Normalize comment string. Sometimes one multi-line comment is turned
-- into several lines for subsequent outputting with correct indentation for
-- each line.
mkComment ::
  -- | Lines of original input with their indices
  [(Int, Text)] ->
  -- | Raw comment string
  RealLocated Text ->
  -- | Remaining lines of original input and the constructed 'Comment'
  ([(Int, Text)], LComment)
mkComment :: [(Int, Text)] -> RealLocated Text -> ([(Int, Text)], LComment)
mkComment [(Int, Text)]
ls (L RealSrcSpan
l Text
s) = ([(Int, Text)]
ls', LComment
comment)
  where
    comment :: LComment
comment =
      RealSrcSpan -> Comment -> LComment
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l (Comment -> LComment)
-> (NonEmpty Text -> Comment) -> NonEmpty Text -> LComment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NonEmpty Text -> Comment
Comment Bool
atomsBefore (NonEmpty Text -> Comment)
-> (NonEmpty Text -> NonEmpty Text) -> NonEmpty Text -> Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> NonEmpty Text
removeConseqBlanks (NonEmpty Text -> NonEmpty Text)
-> (NonEmpty Text -> NonEmpty Text)
-> NonEmpty Text
-> NonEmpty Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> NonEmpty Text -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.stripEnd (NonEmpty Text -> LComment) -> NonEmpty Text -> LComment
forall a b. (a -> b) -> a -> b
$
        case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (Text -> [Text]
T.lines Text
s) of
          Maybe (NonEmpty Text)
Nothing -> Text
s Text -> [Text] -> NonEmpty Text
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 = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
startIndent Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
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 Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| ((Text
commentPrefix <>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeHaddockTriggers (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
n (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs)
    (Bool
atomsBefore, [(Int, Text)]
ls') =
      case ((Int, Text) -> Bool) -> [(Int, Text)] -> [(Int, Text)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
commentLine) (Int -> Bool) -> ((Int, Text) -> Int) -> (Int, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Text) -> Int
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
      -- srcSpanStartCol counts columns starting from 1, so we subtract 1
      | Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
s = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      -- For single-line comments, the only case where xs != [] is when an
      -- invalid haddock comment composed of several single-line comments is
      -- encountered. In that case, each line of xs is prefixed with an
      -- extra space (not present in the original comment), so we set
      -- startIndent = 1 to remove this space.
      | Bool
otherwise = Int
1
    commentLine :: Int
commentLine = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l

-- | Get a collection of lines from a 'Comment'.
unComment :: Comment -> NonEmpty Text
unComment :: Comment -> NonEmpty Text
unComment (Comment Bool
_ NonEmpty Text
xs) = NonEmpty Text
xs

-- | Check whether the 'Comment' had some non-whitespace atoms in front of
-- it in the original input.
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore :: Comment -> Bool
hasAtomsBefore (Comment Bool
atomsBefore NonEmpty Text
_) = Bool
atomsBefore

-- | Is this comment multiline-style?
isMultilineComment :: Comment -> Bool
isMultilineComment :: Comment -> Bool
isMultilineComment (Comment Bool
_ (Text
x :| [Text]
_)) = Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
x

----------------------------------------------------------------------------
-- Helpers

-- | Detect and extract stack header if it is present.
extractStackHeader ::
  -- | Comment stream to analyze
  [RealLocated Text] ->
  ([RealLocated Text], Maybe LComment)
extractStackHeader :: [RealLocated Text] -> ([RealLocated Text], Maybe LComment)
extractStackHeader = \case
  [] -> ([], Maybe LComment
forall a. Maybe a
Nothing)
  (RealLocated Text
x : [RealLocated Text]
xs) ->
    let comment :: LComment
comment = ([(Int, Text)], LComment) -> LComment
forall a b. (a, b) -> b
snd ([(Int, Text)] -> RealLocated Text -> ([(Int, Text)], LComment)
mkComment [] RealLocated Text
x)
     in if Comment -> Bool
isStackHeader (LComment -> Comment
forall a. RealLocated a -> a
unRealSrcSpan LComment
comment)
          then ([RealLocated Text]
xs, LComment -> Maybe LComment
forall a. a -> Maybe a
Just LComment
comment)
          else (RealLocated Text
x RealLocated Text -> [RealLocated Text] -> [RealLocated Text]
forall a. a -> [a] -> [a]
: [RealLocated Text]
xs, Maybe LComment
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)

-- | Extract pragmas and their associated comments.
extractPragmas ::
  -- | Input
  Text ->
  -- | Comment stream to analyze
  [RealLocated Text] ->
  ([LComment], [([LComment], Pragma)])
extractPragmas :: Text -> [RealLocated Text] -> ([LComment], [([LComment], Pragma)])
extractPragmas Text
input = [(Int, Text)]
-> ([LComment] -> [LComment])
-> ([([LComment], Pragma)] -> [([LComment], Pragma)])
-> [RealLocated Text]
-> ([LComment], [([LComment], Pragma)])
forall {b}.
[(Int, Text)]
-> ([LComment] -> [LComment])
-> ([([LComment], Pragma)] -> b)
-> [RealLocated Text]
-> ([LComment], b)
go [(Int, Text)]
initialLs [LComment] -> [LComment]
forall a. a -> a
id [([LComment], Pragma)] -> [([LComment], Pragma)]
forall a. a -> a
id
  where
    initialLs :: [(Int, Text)]
initialLs = [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] (Text -> [Text]
T.lines Text
input)
    go :: [(Int, Text)]
-> ([LComment] -> [LComment])
-> ([([LComment], Pragma)] -> b)
-> [RealLocated Text]
-> ([LComment], b)
go [(Int, Text)]
ls [LComment] -> [LComment]
csSoFar [([LComment], Pragma)] -> b
pragmasSoFar = \case
      [] -> ([LComment] -> [LComment]
csSoFar [], [([LComment], Pragma)] -> b
pragmasSoFar [])
      (RealLocated Text
x : [RealLocated Text]
xs) ->
        case Text -> Maybe Pragma
parsePragma (RealLocated Text -> Text
forall a. RealLocated a -> a
unRealSrcSpan RealLocated Text
x) of
          Maybe Pragma
Nothing ->
            let ([(Int, Text)]
ls', LComment
x') = [(Int, Text)] -> RealLocated Text -> ([(Int, Text)], LComment)
mkComment [(Int, Text)]
ls RealLocated Text
x
             in [(Int, Text)]
-> ([LComment] -> [LComment])
-> ([([LComment], Pragma)] -> b)
-> [RealLocated Text]
-> ([LComment], b)
go [(Int, Text)]
ls' ([LComment] -> [LComment]
csSoFar ([LComment] -> [LComment])
-> ([LComment] -> [LComment]) -> [LComment] -> [LComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LComment
x' :)) [([LComment], Pragma)] -> b
pragmasSoFar [RealLocated Text]
xs
          Just Pragma
pragma ->
            let combined :: [LComment] -> ([LComment], Pragma)
combined [LComment]
ys = ([LComment] -> [LComment]
csSoFar [LComment]
ys, Pragma
pragma)
                go' :: [(Int, Text)]
-> [LComment] -> [RealLocated Text] -> ([LComment], b)
go' [(Int, Text)]
ls' [LComment]
ys [RealLocated Text]
rest = [(Int, Text)]
-> ([LComment] -> [LComment])
-> ([([LComment], Pragma)] -> b)
-> [RealLocated Text]
-> ([LComment], b)
go [(Int, Text)]
ls' [LComment] -> [LComment]
forall a. a -> a
id ([([LComment], Pragma)] -> b
pragmasSoFar ([([LComment], Pragma)] -> b)
-> ([([LComment], Pragma)] -> [([LComment], Pragma)])
-> [([LComment], Pragma)]
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LComment] -> ([LComment], Pragma)
combined [LComment]
ys :)) [RealLocated Text]
rest
             in case [RealLocated Text]
xs of
                  [] -> [(Int, Text)]
-> [LComment] -> [RealLocated Text] -> ([LComment], b)
go' [(Int, Text)]
ls [] [RealLocated Text]
xs
                  (RealLocated Text
y : [RealLocated Text]
ys) ->
                    let ([(Int, Text)]
ls', LComment
y') = [(Int, Text)] -> RealLocated Text -> ([(Int, Text)], LComment)
mkComment [(Int, Text)]
ls RealLocated Text
y
                     in if SrcSpan -> SrcSpan -> Bool
onTheSameLine
                          (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealLocated Text -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated Text
x) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
                          (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealLocated Text -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated Text
y) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
                          then [(Int, Text)]
-> [LComment] -> [RealLocated Text] -> ([LComment], b)
go' [(Int, Text)]
ls' [LComment
y'] [RealLocated Text]
ys
                          else [(Int, Text)]
-> [LComment] -> [RealLocated Text] -> ([LComment], b)
go' [(Int, Text)]
ls [] [RealLocated Text]
xs

-- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'.
unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment :: LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment (L NoCommentsLocation
epaLoc (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
_ -> HsDocStringDecorator -> Maybe HsDocStringDecorator
forall a. a -> Maybe a
Just HsDocStringDecorator
t
            NestedDocString HsDocStringDecorator
t LHsDocStringChunk
_ -> HsDocStringDecorator -> Maybe HsDocStringDecorator
forall a. a -> Maybe a
Just HsDocStringDecorator
t
            -- should not occur
            GeneratedDocString HsDocStringChunk
_ -> Maybe HsDocStringDecorator
forall a. Maybe a
Nothing
       in Maybe HsDocStringDecorator -> Text -> Maybe (RealLocated Text)
haddock Maybe HsDocStringDecorator
trigger (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HsDocString -> String
renderHsDocString HsDocString
s)
    GHC.EpaDocOptions String
s -> Text -> Maybe (RealLocated Text)
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (String -> Text
T.pack String
s)
    GHC.EpaLineComment (String -> Text
T.pack -> Text
s) -> Text -> Maybe (RealLocated Text)
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (Text -> Maybe (RealLocated Text))
-> Text -> Maybe (RealLocated Text)
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 -> Text -> Maybe (RealLocated Text)
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (String -> Text
T.pack String
s)
  where
    mkL :: a -> Maybe (GenLocated RealSrcSpan a)
mkL = case NoCommentsLocation
epaLoc of
      GHC.EpaSpan (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) -> GenLocated RealSrcSpan a -> Maybe (GenLocated RealSrcSpan a)
forall a. a -> Maybe a
Just (GenLocated RealSrcSpan a -> Maybe (GenLocated RealSrcSpan a))
-> (a -> GenLocated RealSrcSpan a)
-> a
-> Maybe (GenLocated RealSrcSpan a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> a -> GenLocated RealSrcSpan a
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
s
      NoCommentsLocation
_ -> Maybe (GenLocated RealSrcSpan a)
-> a -> Maybe (GenLocated RealSrcSpan a)
forall a b. a -> b -> a
const Maybe (GenLocated RealSrcSpan a)
forall a. Maybe a
Nothing
    insertAt :: Text -> Text -> Int -> Text
insertAt Text
x Text
xs Int
n = Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
xs
    haddock :: Maybe HsDocStringDecorator -> Text -> Maybe (RealLocated Text)
haddock Maybe HsDocStringDecorator
mtrigger =
      Text -> Maybe (RealLocated Text)
forall {a}. a -> Maybe (GenLocated RealSrcSpan a)
mkL (Text -> Maybe (RealLocated Text))
-> (Text -> Text) -> Text -> Maybe (RealLocated Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dashPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeHaddockTriggers (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
trigger <>) (Text -> Maybe (RealLocated Text))
-> (Text -> Maybe Text) -> Text -> Maybe (RealLocated Text)
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
"$" Text -> Text -> 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
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
spaceIfNecessary Text -> Text -> Text
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 Char -> Char -> Bool
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 Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s

-- | Remove consecutive blank lines.
removeConseqBlanks :: NonEmpty Text -> NonEmpty Text
removeConseqBlanks :: NonEmpty Text -> NonEmpty Text
removeConseqBlanks (Text
x :| [Text]
xs) = Text
x Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| Bool -> ([Text] -> [Text]) -> [Text] -> [Text]
forall {t}. Bool -> ([Text] -> t) -> [Text] -> t
go (Text -> Bool
T.null Text
x) [Text] -> [Text]
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 ([Text] -> t) -> ([Text] -> [Text]) -> [Text] -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
y :)) [Text]
ys

-- | Escape characters that can turn a line into a Haddock.
escapeHaddockTriggers :: Text -> Text
escapeHaddockTriggers :: Text -> Text
escapeHaddockTriggers Text
string
  | Just (Char
h, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
string, Char
h Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
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