{-# 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
(CommentStream -> CommentStream -> Bool)
-> (CommentStream -> CommentStream -> Bool) -> Eq CommentStream
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
DataType
Constr
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 -> DataType
CommentStream -> Constr
(forall b. Data b => b -> b) -> CommentStream -> CommentStream
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CommentStream -> c CommentStream
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cCommentStream :: Constr
$tCommentStream :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> CommentStream -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CommentStream -> u
gmapQ :: (forall d. Data d => d -> u) -> CommentStream -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CommentStream -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable CommentStream
Data, b -> CommentStream -> CommentStream
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
stimes :: 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
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
mconcat :: [CommentStream] -> CommentStream
$cmconcat :: [CommentStream] -> CommentStream
mappend :: CommentStream -> CommentStream -> CommentStream
$cmappend :: CommentStream -> CommentStream -> CommentStream
mempty :: CommentStream
$cmempty :: CommentStream
$cp1Monoid :: Semigroup 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 =
      ((RealSrcSpan, String) -> RealLocated String)
-> [(RealSrcSpan, String)] -> [RealLocated String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RealSrcSpan -> String -> RealLocated String)
-> (RealSrcSpan, String) -> RealLocated String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealSrcSpan -> String -> RealLocated String
forall l e. l -> e -> GenLocated l e
L)
        ([(RealSrcSpan, String)] -> [RealLocated String])
-> ([RealLocated String] -> [(RealSrcSpan, String)])
-> [RealLocated String]
-> [RealLocated String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RealSrcSpan String -> [(RealSrcSpan, String)]
forall k a. Map k a -> [(k, a)]
M.toAscList
        (Map RealSrcSpan String -> [(RealSrcSpan, String)])
-> ([RealLocated String] -> Map RealSrcSpan String)
-> [RealLocated String]
-> [(RealSrcSpan, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map RealSrcSpan String
 -> Set RealSrcSpan -> Map RealSrcSpan String)
-> Set RealSrcSpan
-> Map RealSrcSpan String
-> Map RealSrcSpan String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map RealSrcSpan String -> Set RealSrcSpan -> Map RealSrcSpan String
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Set RealSrcSpan
validHaddockCommentSpans
        (Map RealSrcSpan String -> Map RealSrcSpan String)
-> ([RealLocated String] -> Map RealSrcSpan String)
-> [RealLocated String]
-> Map RealSrcSpan String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealSrcSpan, String)] -> Map RealSrcSpan String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        ([(RealSrcSpan, String)] -> Map RealSrcSpan String)
-> ([RealLocated String] -> [(RealSrcSpan, String)])
-> [RealLocated String]
-> Map RealSrcSpan String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated String -> (RealSrcSpan, String))
-> [RealLocated String] -> [(RealSrcSpan, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(L RealSrcSpan
l String
a) -> (RealSrcSpan
l, String
a))
        ([RealLocated String] -> [RealLocated String])
-> [RealLocated String] -> [RealLocated String]
forall a b. (a -> b) -> a -> b
$ [RealLocated String]
allComments
      where
        -- All comments, including valid and invalid Haddock comments
        allComments :: [RealLocated String]
allComments =
          (LEpaComment -> Maybe (RealLocated String))
-> [LEpaComment] -> [RealLocated String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealLocated String)
unAnnotationComment ([LEpaComment] -> [RealLocated String])
-> [LEpaComment] -> [RealLocated String]
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) -> HsModule -> [EpAnnComments]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (EpAnnComments -> Bool
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 [LEpaComment] -> [LEpaComment] -> [LEpaComment]
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 =
          [RealSrcSpan] -> Set RealSrcSpan
forall a. Ord a => [a] -> Set a
S.fromList
            ([RealSrcSpan] -> Set RealSrcSpan)
-> (HsModule -> [RealSrcSpan]) -> HsModule -> 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 -> [SrcSpan]) -> HsModule -> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsModule -> [SrcSpan]] -> HsModule -> [SrcSpan]
forall a. Monoid a => [a] -> a
mconcat
              [ (GenLocated SrcSpan HsDocString -> SrcSpan)
-> [GenLocated SrcSpan HsDocString] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan HsDocString -> SrcSpan
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpan HsDocString] -> [SrcSpan])
-> (HsModule -> [GenLocated SrcSpan HsDocString])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan HsDocString -> Bool)
-> GenericQ [GenLocated SrcSpan HsDocString]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (GenLocated SrcSpan HsDocString -> Bool
forall a. a -> Bool
only @LHsDocString),
                (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
 -> [SrcSpan])
-> (HsModule
    -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl -> Bool)
-> GenericQ [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) DocDecl]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (LDocDecl GhcPs -> Bool
forall a. a -> Bool
only @(LDocDecl GhcPs)),
                (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
 -> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
 -> [SrcSpan])
-> (HsModule
    -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
 -> Bool)
-> GenericQ
     [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs) -> Bool
LHsDecl GhcPs -> Bool
isDocD,
                (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)
 -> SrcSpan)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
-> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
 -> [SrcSpan])
-> (HsModule
    -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)])
-> HsModule
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> Bool)
-> GenericQ
     [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs) -> Bool
LIE GhcPs -> Bool
isIEDocLike
              ]
            (HsModule -> Set RealSrcSpan) -> HsModule -> Set RealSrcSpan
forall a b. (a -> b) -> a -> b
$ HsModule
hsModule
          where
            isDocD :: LHsDecl GhcPs -> Bool
            isDocD :: LHsDecl GhcPs -> Bool
isDocD = \case
              L _ DocD {} -> Bool
True
              LHsDecl GhcPs
_ -> Bool
False
            isIEDocLike :: LIE GhcPs -> Bool
            isIEDocLike :: LIE GhcPs -> Bool
isIEDocLike = \case
              L _ IEGroup {} -> Bool
True
              L _ IEDoc {} -> Bool
True
              L _ IEDocNamed {} -> Bool
True
              LIE GhcPs
_ -> Bool
False
    only :: a -> Bool
    only :: a -> Bool
only a
_ = Bool
True

-- | Pretty-print a 'CommentStream'.
showCommentStream :: CommentStream -> String
showCommentStream :: CommentStream -> String
showCommentStream (CommentStream [RealLocated Comment]
xs) =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    RealLocated Comment -> String
forall o a. (Outputable o, Show a) => GenLocated o a -> String
showComment (RealLocated Comment -> String)
-> [RealLocated Comment] -> [String]
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) = o -> String
forall o. Outputable o => o -> String
showOutputable o
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
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
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
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 -> String -> String
[Comment] -> String -> String
Comment -> String
(Int -> Comment -> String -> String)
-> (Comment -> String)
-> ([Comment] -> String -> String)
-> Show Comment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Comment] -> String -> String
$cshowList :: [Comment] -> String -> String
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> String -> String
$cshowsPrec :: Int -> Comment -> String -> String
Show, Typeable Comment
DataType
Constr
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 -> DataType
Comment -> Constr
(forall b. Data b => b -> b) -> Comment -> Comment
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Comment -> c Comment
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cComment :: Constr
$tComment :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> Comment -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Comment -> u
gmapQ :: (forall d. Data d => d -> u) -> Comment -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Comment -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable 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 =
      RealSrcSpan -> Comment -> RealLocated Comment
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
l (Comment -> RealLocated Comment)
-> (NonEmpty String -> Comment)
-> NonEmpty String
-> RealLocated Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NonEmpty String -> Comment
Comment Bool
atomsBefore (NonEmpty String -> Comment)
-> (NonEmpty String -> NonEmpty String)
-> NonEmpty String
-> Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> NonEmpty String
removeConseqBlanks (NonEmpty String -> NonEmpty String)
-> (NonEmpty String -> NonEmpty String)
-> NonEmpty String
-> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> NonEmpty String -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropTrailing (NonEmpty String -> RealLocated Comment)
-> NonEmpty String -> RealLocated Comment
forall a b. (a -> b) -> a -> b
$
        case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (String -> [String]
lines String
s) of
          Maybe (NonEmpty String)
Nothing -> String
s String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
          Just (String
x :| [String]
xs) ->
            let getIndent :: String -> Int
getIndent String
y =
                  if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
y
                    then Int
startIndent
                    else String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace String
y)
                n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
startIndent Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (String -> Int) -> [String] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
getIndent [String]
xs)
                commentPrefix :: String
commentPrefix = if String
"{-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
s then String
"" else String
"-- "
             in String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| ((String
commentPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs)
    (Bool
atomsBefore, [(Int, String)]
ls') =
      case ((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
commentLine) (Int -> Bool) -> ((Int, String) -> Int) -> (Int, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> Int
forall a b. (a, b) -> a
fst) [(Int, String)]
ls of
        [] -> (Bool
False, [])
        ((Int
_, String
i) : [(Int, String)]
ls'') ->
          case Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 ((Char -> Bool) -> String -> String
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 :: String -> String
dropTrailing = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace
    startIndent :: Int
startIndent = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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
"{-" String -> String -> Bool
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
  [] -> ([], Maybe (RealLocated Comment)
forall a. Maybe a
Nothing)
  (RealLocated String
x : [RealLocated String]
xs) ->
    let comment :: RealLocated Comment
comment = ([(Int, String)], RealLocated Comment) -> RealLocated 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 (RealLocated Comment -> Comment
forall a. RealLocated a -> a
unRealSrcSpan RealLocated Comment
comment)
          then ([RealLocated String]
xs, RealLocated Comment -> Maybe (RealLocated Comment)
forall a. a -> Maybe a
Just RealLocated Comment
comment)
          else (RealLocated String
x RealLocated String -> [RealLocated String] -> [RealLocated String]
forall a. a -> [a] -> [a]
: [RealLocated String]
xs, Maybe (RealLocated Comment)
forall a. Maybe a
Nothing)
  where
    isStackHeader :: Comment -> Bool
isStackHeader (Comment Bool
_ (String
x :| [String]
_)) =
      String
"stack" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (Int -> String -> String
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 = [(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], Pragma)])
-> [RealLocated String]
-> ([RealLocated Comment], [([RealLocated Comment], Pragma)])
forall b.
[(Int, String)]
-> ([RealLocated Comment] -> [RealLocated Comment])
-> ([([RealLocated Comment], Pragma)] -> b)
-> [RealLocated String]
-> ([RealLocated Comment], b)
go [(Int, String)]
initialLs [RealLocated Comment] -> [RealLocated Comment]
forall a. a -> a
id [([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)]
forall a. a -> a
id
  where
    initialLs :: [(Int, String)]
initialLs = [Int] -> [String] -> [(Int, String)]
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 (RealLocated String -> String
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 ([RealLocated Comment] -> [RealLocated Comment])
-> ([RealLocated Comment] -> [RealLocated Comment])
-> [RealLocated Comment]
-> [RealLocated Comment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated Comment
x' RealLocated Comment
-> [RealLocated Comment] -> [RealLocated Comment]
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' [RealLocated Comment] -> [RealLocated Comment]
forall a. a -> a
id ([([RealLocated Comment], Pragma)] -> b
pragmasSoFar ([([RealLocated Comment], Pragma)] -> b)
-> ([([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], Pragma)])
-> [([RealLocated Comment], Pragma)]
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RealLocated Comment] -> ([RealLocated Comment], Pragma)
combined [RealLocated Comment]
ys ([RealLocated Comment], Pragma)
-> [([RealLocated Comment], Pragma)]
-> [([RealLocated Comment], Pragma)]
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 (RealLocated String -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
x) Maybe BufSpan
forall a. Maybe a
Nothing)
                          (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealLocated String -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan RealLocated String
y) Maybe BufSpan
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 -> Maybe (RealLocated String)
haddock String
s -- @-- |@
  GHC.EpaDocCommentPrev String
s -> String -> Maybe (RealLocated String)
haddock String
s -- @-- ^@
  GHC.EpaDocCommentNamed String
s -> String -> Maybe (RealLocated String)
haddock String
s -- @-- $@
  GHC.EpaDocSection Int
_ String
s -> String -> Maybe (RealLocated String)
haddock String
s -- @-- *@
  GHC.EpaDocOptions String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL String
s
  GHC.EpaLineComment String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL (String -> Maybe (RealLocated String))
-> String -> Maybe (RealLocated String)
forall a b. (a -> b) -> a -> b
$
    case Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
3 String
s of
      String
"-- " -> String
s
      String
"---" -> String
s
      String
_ -> let s' :: String
s' = String -> String -> Int -> String
forall a. [a] -> [a] -> Int -> [a]
insertAt String
" " String
s Int
3 in String
s'
  GHC.EpaBlockComment String
s -> String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL String
s
  EpaCommentTok
GHC.EpaEofComment -> Maybe (RealLocated String)
forall a. Maybe a
Nothing
  where
    mkL :: e -> Maybe (GenLocated RealSrcSpan e)
mkL = GenLocated RealSrcSpan e -> Maybe (GenLocated RealSrcSpan e)
forall a. a -> Maybe a
Just (GenLocated RealSrcSpan e -> Maybe (GenLocated RealSrcSpan e))
-> (e -> GenLocated RealSrcSpan e)
-> e
-> Maybe (GenLocated RealSrcSpan e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> e -> GenLocated RealSrcSpan e
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
anchor
    insertAt :: [a] -> [a] -> Int -> [a]
insertAt [a]
x [a]
xs Int
n = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
    haddock :: String -> Maybe (RealLocated String)
haddock = String -> Maybe (RealLocated String)
forall e. e -> Maybe (GenLocated RealSrcSpan e)
mkL (String -> Maybe (RealLocated String))
-> (String -> String) -> String -> Maybe (RealLocated String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dashPrefix (String -> Maybe (RealLocated String))
-> (String -> Maybe String) -> String -> Maybe (RealLocated String)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Maybe String
dropBlank
      where
        dashPrefix :: String -> String
dashPrefix String
s = String
"--" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
spaceIfNecessary String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
          where
            spaceIfNecessary :: String
spaceIfNecessary = case String
s of
              c : _ | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' -> String
" "
              String
_ -> String
""
        dropBlank :: String -> Maybe String
        dropBlank :: String -> Maybe String
dropBlank String
s = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
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 String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| Bool -> ([String] -> [String]) -> [String] -> [String]
forall (t :: * -> *) a c.
Foldable t =>
Bool -> ([t a] -> c) -> [t a] -> c
go (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x) [String] -> [String]
forall a. a -> a
id [String]
xs
  where
    go :: Bool -> ([t a] -> c) -> [t a] -> c
go Bool
seenBlank [t a] -> c
acc = \case
      [] -> [t a] -> c
acc []
      (t a
y : [t a]
ys) ->
        if Bool
seenBlank Bool -> Bool -> Bool
&& t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y
          then Bool -> ([t a] -> c) -> [t a] -> c
go Bool
True [t a] -> c
acc [t a]
ys
          else Bool -> ([t a] -> c) -> [t a] -> c
go (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
y) ([t a] -> c
acc ([t a] -> c) -> ([t a] -> [t a]) -> [t a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a
y t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:)) [t a]
ys