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

-- | 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 qualified Data.List as L
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Lazy as M
import Data.Maybe
import qualified Data.Set as S
import GHC.Hs (HsModule)
import GHC.Hs.Decls (HsDecl (..), LDocDecl, LHsDecl)
import GHC.Hs.Doc
import GHC.Hs.Extension
import GHC.Hs.ImpExp
import GHC.Parser.Annotation (EpAnnComments (..), getLocA)
import qualified GHC.Parser.Annotation as GHC
import GHC.Types.SrcLoc
import Ormolu.Parser.Pragma
import Ormolu.Utils (onTheSameLine, showOutputable)

----------------------------------------------------------------------------
-- 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
  String ->
  -- | Module to use for comment extraction
  HsModule ->
  -- | Stack header, pragmas, and comment stream
  ( Maybe (RealLocated Comment),
    [([RealLocated Comment], Pragma)],
    CommentStream
  )
mkCommentStream :: String
-> HsModule
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
    CommentStream)
mkCommentStream 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

    -- We want to extract all comments except _valid_ Haddock comments
    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
        -- All comments, including valid and invalid Haddock comments
        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
        -- All spans of valid Haddock comments
        -- (everywhere where we use p_hsDoc{String,Name})
        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 @LHsDocString),
                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 (forall a. a -> Bool
only @(LDocDecl 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 LHsDecl GhcPs -> Bool
isDocD,
                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
            isDocD :: LHsDecl GhcPs -> Bool
            isDocD :: LHsDecl GhcPs -> Bool
isDocD = \case
              L SrcSpanAnn' (EpAnn AnnListItem)
_ DocD {} -> Bool
True
              LHsDecl GhcPs
_ -> Bool
False
            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 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)

-- | 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, String)] ->
  -- | Raw comment string
  RealLocated String ->
  -- | Remaining lines of original input and the constructed 'Comment'
  ([(Int, String)], RealLocated Comment)
mkComment :: [(Int, String)]
-> RealLocated String -> ([(Int, String)], RealLocated Comment)
mkComment [(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
      -- srcSpanStartCol counts columns starting from 1, so we subtract 1
      | 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
      -- 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 String
unComment :: Comment -> NonEmpty String
unComment (Comment Bool
_ NonEmpty String
xs) = NonEmpty String
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 String
_) = Bool
atomsBefore

-- | Is this comment multiline-style?
isMultilineComment :: Comment -> Bool
isMultilineComment :: Comment -> Bool
isMultilineComment (Comment Bool
_ (String
x :| [String]
_)) = String
"{-" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
x

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

-- | Detect and extract stack header if it is present.
extractStackHeader ::
  -- | Comment stream to analyze
  [RealLocated String] ->
  ([RealLocated String], Maybe (RealLocated Comment))
extractStackHeader :: [RealLocated String]
-> ([RealLocated String], Maybe (RealLocated Comment))
extractStackHeader = \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)

-- | Extract pragmas and their associated comments.
extractPragmas ::
  -- | Input
  String ->
  -- | Comment stream to analyze
  [RealLocated String] ->
  ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas :: String
-> [RealLocated String]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
extractPragmas 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
Nothing)
                          (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
y) forall a. Maybe a
Nothing)
                          then [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls' [RealLocated Comment
y'] [RealLocated String]
ys
                          else [(Int, String)]
-> [RealLocated Comment]
-> [RealLocated String]
-> ([RealLocated Comment], b)
go' [(Int, String)]
ls [] [RealLocated String]
xs

-- | Extract @'RealLocated' 'String'@ from 'GHC.LEpaComment'.
unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated String)
unAnnotationComment :: LEpaComment -> Maybe (RealLocated String)
unAnnotationComment (L (GHC.Anchor RealSrcSpan
anchor AnchorOperation
_) (GHC.EpaComment EpaCommentTok
eck RealSrcSpan
_)) =
  case EpaCommentTok
eck of
    GHC.EpaDocCommentNext String
s -> String -> String -> Maybe (RealLocated String)
haddock String
"|" String
s -- @-- |@
    GHC.EpaDocCommentPrev String
s -> String -> String -> Maybe (RealLocated String)
haddock String
"^" String
s -- @-- ^@
    GHC.EpaDocCommentNamed String
s -> String -> String -> Maybe (RealLocated String)
haddock String
"$" String
s -- @-- $@
    GHC.EpaDocSection Int
k String
s -> String -> String -> Maybe (RealLocated String)
haddock (forall a. Int -> a -> [a]
replicate Int
k Char
'*') String
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 :: String -> String -> Maybe (RealLocated String)
haddock String
trigger =
      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
        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

-- | Remove consecutive blank lines.
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

-- | Escape characters that can turn a line into a Haddock.
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