{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

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

    -- * Comment
    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 qualified Data.List.NonEmpty as NE
import qualified Data.Map.Lazy as M
import Data.Maybe
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
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)

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

-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
-- beginning of corresponding spans.
newtype CommentStream = CommentStream [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)

-- | Create 'CommentStream' from 'HsModule'. The pragmas are
-- removed from the 'CommentStream'.
mkCommentStream ::
  -- | Original input
  Text ->
  -- | Module to use for comment extraction
  HsModule ->
  -- | Stack header, pragmas, and comment stream
  ( Maybe (RealLocated Comment),
    [([RealLocated Comment], Pragma)],
    CommentStream
  )
mkCommentStream :: Text
-> HsModule
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
    CommentStream)
mkCommentStream Text
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) = 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

    -- We want to extract all comments except _valid_ Haddock comments
    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
        -- All comments, including valid and invalid Haddock comments
        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
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
        -- All spans of valid Haddock comments
        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

-- | Pretty-print a 'CommentStream'.
showCommentStream :: CommentStream -> String
showCommentStream :: CommentStream -> String
showCommentStream (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

----------------------------------------------------------------------------
-- 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
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)

-- | 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)], RealLocated Comment)
mkComment :: [(Int, Text)]
-> RealLocated Text -> ([(Int, Text)], RealLocated Comment)
mkComment [(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 a. Semigroup a => a -> a -> a
<>) 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
      -- srcSpanStartCol counts columns starting from 1, so we subtract 1
      | Text
"{-" Text -> Text -> Bool
`T.isPrefixOf` Text
s = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l 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 (RealLocated Comment))
extractStackHeader :: [RealLocated Text]
-> ([RealLocated Text], Maybe (RealLocated Comment))
extractStackHeader = \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)

-- | Extract pragmas and their associated comments.
extractPragmas ::
  -- | Input
  Text ->
  -- | Comment stream to analyze
  [RealLocated Text] ->
  ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas :: Text
-> [RealLocated Text]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas 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' forall a. a -> [a] -> [a]
:)) [([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 forall a. a -> [a] -> [a]
:)) [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

-- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'.
unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment :: LEpaComment -> Maybe (RealLocated Text)
unAnnotationComment (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
            -- should not occur
            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 a. Semigroup a => a -> a -> a
<>) 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

-- | Remove consecutive blank lines.
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 forall a. a -> [a] -> [a]
:)) [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 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