{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Comment relocation for pretty-printing comments correctly.
--
-- HIndent gathers all comments above a function, an import, a module
-- declaration, etc. For example, HIndent formats the following code
--
-- > f :: Int
-- > f = 1
-- >
-- > -- A comment between f and g
-- >
-- > -- Another comment between f and g
-- >
-- > g :: Int
-- > g = 2
--
-- to
--
-- > f :: Int
-- > f = 1
-- >
-- > -- A comment between f and g
-- > -- Another comment between f and g
-- > g :: Int
-- > g = 2
--
-- AST nodes must have the information of which comments are above, on the
-- same line, and below. However, AST nodes generated by a parser of
-- 'ghc-lib-parser' only contain comments after them. 'relocateComments' is
-- defined to solve the problem.
module HIndent.ModulePreprocessing.CommentRelocation
  ( relocateComments
  ) where

import Control.Exception
import Control.Monad.State
import Data.Foldable
import Data.Function
import Data.List
import GHC.Data.Bag
import GHC.Hs
import GHC.Types.SrcLoc
import Generics.SYB hiding (GT, typeOf, typeRep)
import HIndent.Pretty.Pragma
import HIndent.Pretty.SigBindFamily
import Type.Reflection

-- | A wrapper type used in everywhereMEpAnnsBackwards' to collect all
-- 'EpAnn's to apply a function with them in order their positions.
data Wrapper =
  forall a. Typeable (EpAnn a) =>
            Wrapper (EpAnn a)

-- | 'State' with comments.
type WithComments = State [LEpaComment]

-- | This function collects all comments from the passed 'HsModule', and
-- modifies all 'EpAnn's so that all 'EpAnn's have 'EpaCommentsBalanced's.
relocateComments :: HsModule -> [LEpaComment] -> HsModule
relocateComments :: HsModule -> [LEpaComment] -> HsModule
relocateComments = State [LEpaComment] HsModule -> [LEpaComment] -> HsModule
forall s a. State s a -> s -> a
evalState (State [LEpaComment] HsModule -> [LEpaComment] -> HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> [LEpaComment]
-> HsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> State [LEpaComment] HsModule
relocate
  where
    relocate :: HsModule -> State [LEpaComment] HsModule
relocate =
      HsModule -> State [LEpaComment] HsModule
relocatePragmas (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsBeforePragmas (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsInExportList (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsBeforeTopLevelDecls (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsSameLine (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsTopLevelWhereClause (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      HsModule -> State [LEpaComment] HsModule
relocateCommentsAfter (HsModule -> State [LEpaComment] HsModule)
-> (HsModule -> State [LEpaComment] HsModule)
-> HsModule
-> State [LEpaComment] HsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> HsModule -> State [LEpaComment] HsModule
forall {m :: * -> *} {t :: * -> *} {a} {b}.
(MonadState (t a) m, Foldable t) =>
b -> m b
assertAllCommentsAreConsumed
    assertAllCommentsAreConsumed :: b -> m b
assertAllCommentsAreConsumed b
x = do
      t a
cs <- m (t a)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool -> m b -> m b
forall a. HasCallStack => Bool -> a -> a
assert (t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
cs) (b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x)

-- | This function locates pragmas to the module's EPA.
relocatePragmas :: HsModule -> WithComments HsModule
relocatePragmas :: HsModule -> State [LEpaComment] HsModule
relocatePragmas m :: HsModule
m@HsModule {hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodAnn = epa :: EpAnn AnnsModule
epa@EpAnn {}} = do
  EpAnn AnnsModule
newAnn <- (LEpaComment -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn AnnsModule
-> WithComments (EpAnn AnnsModule)
forall a.
(LEpaComment -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertComments (EpaCommentTok -> Bool
isPragma (EpaCommentTok -> Bool)
-> (LEpaComment -> EpaCommentTok) -> LEpaComment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpaComment -> EpaCommentTok
ac_tok (EpaComment -> EpaCommentTok)
-> (LEpaComment -> EpaComment) -> LEpaComment -> EpaCommentTok
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> EpaComment
forall l e. GenLocated l e -> e
unLoc) EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments EpAnn AnnsModule
epa
  HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return HsModule
m {hsmodAnn :: EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
newAnn}
relocatePragmas HsModule
m = HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
m

-- | This function locates comments that are located before pragmas to the
-- module's EPA.
relocateCommentsBeforePragmas :: HsModule -> WithComments HsModule
relocateCommentsBeforePragmas :: HsModule -> State [LEpaComment] HsModule
relocateCommentsBeforePragmas m :: HsModule
m@HsModule {hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
ann}
  | HsModule -> Bool
pragmaExists HsModule
m = do
    EpAnn AnnsModule
newAnn <- (RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn AnnsModule
-> WithComments (EpAnn AnnsModule)
forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos (RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan
startPosOfPragmas) EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments EpAnn AnnsModule
ann
    HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
m {hsmodAnn :: EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
newAnn}
  | Bool
otherwise = HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
m
  where
    startPosOfPragmas :: RealSrcSpan
startPosOfPragmas = Anchor -> RealSrcSpan
anchor (Anchor -> RealSrcSpan) -> Anchor -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ LEpaComment -> Anchor
forall l e. GenLocated l e -> l
getLoc (LEpaComment -> Anchor) -> LEpaComment -> Anchor
forall a b. (a -> b) -> a -> b
$ [LEpaComment] -> LEpaComment
forall a. HasCallStack => [a] -> a
head ([LEpaComment] -> LEpaComment) -> [LEpaComment] -> LEpaComment
forall a b. (a -> b) -> a -> b
$ EpAnnComments -> [LEpaComment]
priorComments (EpAnnComments -> [LEpaComment]) -> EpAnnComments -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ EpAnn AnnsModule -> EpAnnComments
forall ann. EpAnn ann -> EpAnnComments
comments EpAnn AnnsModule
ann

-- | This function locates comments that are located before each element of
-- an export list.
relocateCommentsInExportList :: HsModule -> WithComments HsModule
relocateCommentsInExportList :: HsModule -> State [LEpaComment] HsModule
relocateCommentsInExportList m :: HsModule
m@HsModule {hsmodExports :: HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodExports = Just (L listSp :: SrcSpanAnnL
listSp@SrcSpanAnn {ann :: forall a. SrcSpanAnn' a -> a
ann = EpAnn {entry :: forall ann. EpAnn ann -> Anchor
entry = Anchor
listAnn}} [LIE GhcPs]
xs)} = do
  [GenLocated SrcSpanAnnA (IE GhcPs)]
newExports <- (GenLocated SrcSpanAnnA (IE GhcPs)
 -> StateT
      [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs)))
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> StateT
     [LEpaComment] Identity [GenLocated SrcSpanAnnA (IE GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (IE GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs))
insertCommentsBeforeElement [GenLocated SrcSpanAnnA (IE GhcPs)]
[LIE GhcPs]
xs
  HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
m {hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodExports = GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. a -> Maybe a
Just (SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
listSp [GenLocated SrcSpanAnnA (IE GhcPs)]
newExports)}
  where
    insertCommentsBeforeElement :: GenLocated SrcSpanAnnA (IE GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs))
insertCommentsBeforeElement (L sp :: SrcSpanAnnA
sp@SrcSpanAnn {ann :: forall a. SrcSpanAnn' a -> a
ann = entryAnn :: EpAnn AnnListItem
entryAnn@EpAnn {}} IE GhcPs
x) = do
      EpAnn AnnListItem
newEpa <-
        (RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn AnnListItem
-> WithComments (EpAnn AnnListItem)
forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos
          (RealSrcSpan -> RealSrcSpan -> Bool
isBefore (RealSrcSpan -> RealSrcSpan -> Bool)
-> RealSrcSpan -> RealSrcSpan -> Bool
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor (Anchor -> RealSrcSpan) -> Anchor -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ EpAnn AnnListItem -> Anchor
forall ann. EpAnn ann -> Anchor
entry EpAnn AnnListItem
entryAnn)
          EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments
          EpAnn AnnListItem
entryAnn
      GenLocated SrcSpanAnnA (IE GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (IE GhcPs)
 -> StateT
      [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs)))
-> GenLocated SrcSpanAnnA (IE GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
sp {ann :: EpAnn AnnListItem
ann = EpAnn AnnListItem
newEpa} IE GhcPs
x
    insertCommentsBeforeElement GenLocated SrcSpanAnnA (IE GhcPs)
x = GenLocated SrcSpanAnnA (IE GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (IE GhcPs)
x
    isBefore :: RealSrcSpan -> RealSrcSpan -> Bool
isBefore RealSrcSpan
anc RealSrcSpan
comAnc =
      RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
anc Bool -> Bool -> Bool
&&
      RealSrcSpan -> RealSrcLoc
realSrcSpanStart (Anchor -> RealSrcSpan
anchor Anchor
listAnn) RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
comAnc
relocateCommentsInExportList HsModule
x = HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
x

-- | This function locates comments located before top-level declarations.
relocateCommentsBeforeTopLevelDecls :: HsModule -> WithComments HsModule
relocateCommentsBeforeTopLevelDecls :: HsModule -> State [LEpaComment] HsModule
relocateCommentsBeforeTopLevelDecls = GenericM (StateT [LEpaComment] Identity)
-> GenericM (StateT [LEpaComment] Identity)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
forall a.
Typeable a =>
(forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
applyM EpAnn b -> WithComments (EpAnn b)
forall b. EpAnn b -> WithComments (EpAnn b)
f)
  where
    f :: EpAnn a -> WithComments (EpAnn a)
f epa :: EpAnn a
epa@EpAnn {a
EpAnnComments
Anchor
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
entry :: Anchor
anns :: a
comments :: EpAnnComments
anns :: forall ann. EpAnn ann -> ann
..} =
      (RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos (RealSrcSpan -> RealSrcSpan -> Bool
isBefore (RealSrcSpan -> RealSrcSpan -> Bool)
-> RealSrcSpan -> RealSrcSpan -> Bool
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
entry) EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments EpAnn a
epa
    f EpAnn a
EpAnnNotUsed = EpAnn a -> WithComments (EpAnn a)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpAnn a
forall ann. EpAnn ann
EpAnnNotUsed
    isBefore :: RealSrcSpan -> RealSrcSpan -> Bool
isBefore RealSrcSpan
anc RealSrcSpan
comAnc =
      RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
anc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
      RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
      RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
anc

-- | This function scans the given AST from bottom to top and locates
-- comments that are on the same line as the node.  Comments are stored in
-- the 'followingComments' of 'EpaCommentsBalanced'.
relocateCommentsSameLine :: HsModule -> WithComments HsModule
relocateCommentsSameLine :: HsModule -> State [LEpaComment] HsModule
relocateCommentsSameLine = (forall b. EpAnn b -> WithComments (EpAnn b))
-> HsModule -> State [LEpaComment] HsModule
forall a.
Data a =>
(forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
everywhereMEpAnnsBackwards EpAnn b -> WithComments (EpAnn b)
forall b. EpAnn b -> WithComments (EpAnn b)
f
  where
    f :: EpAnn a -> WithComments (EpAnn a)
f epa :: EpAnn a
epa@EpAnn {a
EpAnnComments
Anchor
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
entry :: Anchor
anns :: a
comments :: EpAnnComments
..} =
      (RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos
        (RealSrcSpan -> RealSrcSpan -> Bool
isOnSameLine (RealSrcSpan -> RealSrcSpan -> Bool)
-> RealSrcSpan -> RealSrcSpan -> Bool
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
entry)
        EpAnnComments -> [LEpaComment] -> EpAnnComments
insertFollowingComments
        EpAnn a
epa
    f EpAnn a
EpAnnNotUsed = EpAnn a -> WithComments (EpAnn a)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpAnn a
forall ann. EpAnn ann
EpAnnNotUsed
    isOnSameLine :: RealSrcSpan -> RealSrcSpan -> Bool
isOnSameLine RealSrcSpan
anc RealSrcSpan
comAnc =
      RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
anc Bool -> Bool -> Bool
&&
      RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
anc

-- | This function locates comments above the top-level declarations in
-- a 'where' clause in the topmost declaration.
relocateCommentsTopLevelWhereClause :: HsModule -> WithComments HsModule
relocateCommentsTopLevelWhereClause :: HsModule -> State [LEpaComment] HsModule
relocateCommentsTopLevelWhereClause m :: HsModule
m@HsModule {[LImportDecl GhcPs]
[LHsDecl GhcPs]
Maybe (LHsDoc GhcPs)
Maybe (LocatedP (WarningTxt GhcPs))
Maybe (LocatedL [LIE GhcPs])
Maybe (LocatedA ModuleName)
LayoutInfo
EpAnn AnnsModule
hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodExports :: HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: LayoutInfo
hsmodName :: Maybe (LocatedA ModuleName)
hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodImports :: [LImportDecl GhcPs]
hsmodDecls :: [LHsDecl GhcPs]
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodLayout :: HsModule -> LayoutInfo
hsmodName :: HsModule -> Maybe (LocatedA ModuleName)
hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDeprecMessage :: HsModule -> Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: HsModule -> Maybe (LHsDoc GhcPs)
..} = do
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls' <- (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> StateT
      [LEpaComment] Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> StateT
     [LEpaComment] Identity [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall {p} {t :: * -> *} {t :: * -> *} {l} {body} {l}.
(XRec p [XRec p (Match p (XRec p (HsExpr p)))]
 ~ t (t (GenLocated l (Match GhcPs body))),
 Traversable t, Traversable t) =>
GenLocated l (HsDecl p)
-> StateT [LEpaComment] Identity (GenLocated l (HsDecl p))
relocateCommentsDeclWhereClause [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
hsmodDecls
  HsModule -> State [LEpaComment] HsModule
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule
m {hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
hsmodDecls'}
  where
    relocateCommentsDeclWhereClause :: GenLocated l (HsDecl p)
-> StateT [LEpaComment] Identity (GenLocated l (HsDecl p))
relocateCommentsDeclWhereClause (L l
l (ValD XValD p
ext fb :: HsBind p
fb@(FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MG {Origin
XMG p (XRec p (HsExpr p))
XRec p [XRec p (Match p (XRec p (HsExpr p)))]
mg_ext :: XMG p (XRec p (HsExpr p))
mg_alts :: XRec p [XRec p (Match p (XRec p (HsExpr p)))]
mg_origin :: Origin
mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_origin :: forall p body. MatchGroup p body -> Origin
..}}))) = do
      t (t (GenLocated l (Match GhcPs body)))
mg_alts' <- (t (GenLocated l (Match GhcPs body))
 -> StateT
      [LEpaComment] Identity (t (GenLocated l (Match GhcPs body))))
-> t (t (GenLocated l (Match GhcPs body)))
-> StateT
     [LEpaComment] Identity (t (t (GenLocated l (Match GhcPs body))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM ((GenLocated l (Match GhcPs body)
 -> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body)))
-> t (GenLocated l (Match GhcPs body))
-> StateT
     [LEpaComment] Identity (t (GenLocated l (Match GhcPs body)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
forall {l} {body}.
GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
relocateCommentsMatch) t (t (GenLocated l (Match GhcPs body)))
XRec p [XRec p (Match p (XRec p (HsExpr p)))]
mg_alts
      GenLocated l (HsDecl p)
-> StateT [LEpaComment] Identity (GenLocated l (HsDecl p))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated l (HsDecl p)
 -> StateT [LEpaComment] Identity (GenLocated l (HsDecl p)))
-> GenLocated l (HsDecl p)
-> StateT [LEpaComment] Identity (GenLocated l (HsDecl p))
forall a b. (a -> b) -> a -> b
$ l -> HsDecl p -> GenLocated l (HsDecl p)
forall l e. l -> e -> GenLocated l e
L l
l (XValD p -> HsBind p -> HsDecl p
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD p
ext HsBind p
fb {fun_matches :: MatchGroup p (XRec p (HsExpr p))
fun_matches = MG {mg_alts :: XRec p [XRec p (Match p (XRec p (HsExpr p)))]
mg_alts = t (t (GenLocated l (Match GhcPs body)))
XRec p [XRec p (Match p (XRec p (HsExpr p)))]
mg_alts', Origin
XMG p (XRec p (HsExpr p))
mg_ext :: XMG p (XRec p (HsExpr p))
mg_origin :: Origin
mg_ext :: XMG p (XRec p (HsExpr p))
mg_origin :: Origin
..}})
    relocateCommentsDeclWhereClause GenLocated l (HsDecl p)
x = GenLocated l (HsDecl p)
-> StateT [LEpaComment] Identity (GenLocated l (HsDecl p))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated l (HsDecl p)
x
    relocateCommentsMatch :: GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
relocateCommentsMatch (L l
l match :: Match GhcPs body
match@Match {m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = gs :: GRHSs GhcPs body
gs@GRHSs {grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds = (HsValBinds XHsValBinds GhcPs GhcPs
ext (ValBinds XValBinds GhcPs GhcPs
ext' LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs))}}) = do
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs') <- LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])
relocateCommentsBindsSigs LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs
      let localBinds :: HsLocalBindsLR GhcPs GhcPs
localBinds = XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
ext (XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
ext' Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
LHsBindsLR GhcPs GhcPs
binds' [GenLocated SrcSpanAnnA (Sig GhcPs)]
[LSig GhcPs]
sigs')
      GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated l (Match GhcPs body)
 -> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body)))
-> GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
forall a b. (a -> b) -> a -> b
$ l -> Match GhcPs body -> GenLocated l (Match GhcPs body)
forall l e. l -> e -> GenLocated l e
L l
l Match GhcPs body
match {m_grhss :: GRHSs GhcPs body
m_grhss = GRHSs GhcPs body
gs {grhssLocalBinds :: HsLocalBindsLR GhcPs GhcPs
grhssLocalBinds = HsLocalBindsLR GhcPs GhcPs
localBinds}}
    relocateCommentsMatch GenLocated l (Match GhcPs body)
x = GenLocated l (Match GhcPs body)
-> StateT [LEpaComment] Identity (GenLocated l (Match GhcPs body))
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated l (Match GhcPs body)
x
    relocateCommentsBindsSigs ::
         LHsBindsLR GhcPs GhcPs
      -> [LSig GhcPs]
      -> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])
    relocateCommentsBindsSigs :: LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])
relocateCommentsBindsSigs LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs = do
      [GenLocated SrcSpanAnnA SigBindFamily]
bindsSigs' <- (GenLocated SrcSpanAnnA SigBindFamily
 -> StateT
      [LEpaComment] Identity (GenLocated SrcSpanAnnA SigBindFamily))
-> [GenLocated SrcSpanAnnA SigBindFamily]
-> StateT
     [LEpaComment] Identity [GenLocated SrcSpanAnnA SigBindFamily]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA SigBindFamily
-> StateT
     [LEpaComment] Identity (GenLocated SrcSpanAnnA SigBindFamily)
forall {m :: * -> *} {ann} {e}.
MonadState [LEpaComment] m =>
GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
addCommentsBeforeEpAnn [GenLocated SrcSpanAnnA SigBindFamily]
bindsSigs
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 [GenLocated SrcSpanAnnA (Sig GhcPs)])
-> StateT
     [LEpaComment]
     Identity
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)])
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LHsBindLR GhcPs GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a. [a] -> Bag a
listToBag ([LHsBindLR GhcPs GhcPs] -> LHsBindsLR GhcPs GhcPs)
-> [LHsBindLR GhcPs GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA SigBindFamily] -> [LHsBindLR GhcPs GhcPs]
filterLBind [GenLocated SrcSpanAnnA SigBindFamily]
bindsSigs', [GenLocated SrcSpanAnnA SigBindFamily] -> [LSig GhcPs]
filterLSig [GenLocated SrcSpanAnnA SigBindFamily]
bindsSigs')
      where
        bindsSigs :: [GenLocated SrcSpanAnnA SigBindFamily]
bindsSigs = [LSig GhcPs]
-> [LHsBindLR GhcPs GhcPs]
-> [LFamilyDecl GhcPs]
-> [LTyFamInstDecl GhcPs]
-> [LDataFamInstDecl GhcPs]
-> [GenLocated SrcSpanAnnA SigBindFamily]
mkSortedLSigBindFamilyList [LSig GhcPs]
sigs (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
LHsBindsLR GhcPs GhcPs
binds) [] [] []
    addCommentsBeforeEpAnn :: GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
addCommentsBeforeEpAnn (L (SrcSpanAnn epa :: EpAnn ann
epa@EpAnn {ann
EpAnnComments
Anchor
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
entry :: Anchor
anns :: ann
comments :: EpAnnComments
..} SrcSpan
sp) e
x) = do
      [LEpaComment]
cs <- m [LEpaComment]
forall s (m :: * -> *). MonadState s m => m s
get
      let ([LEpaComment]
notAbove, [LEpaComment]
above) =
            [LEpaComment] -> Anchor -> ([LEpaComment], [LEpaComment])
forall {t :: * -> *} {e}.
Foldable t =>
t (GenLocated Anchor e)
-> Anchor -> ([GenLocated Anchor e], [GenLocated Anchor e])
partitionAboveNotAbove ([LEpaComment] -> [LEpaComment]
sortCommentsByLocation [LEpaComment]
cs) Anchor
entry
          epa' :: EpAnn ann
epa' = EpAnn ann
epa {comments :: EpAnnComments
comments = EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments EpAnnComments
comments [LEpaComment]
above}
      [LEpaComment] -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [LEpaComment]
notAbove
      GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated (SrcSpanAnn' (EpAnn ann)) e
 -> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e))
-> GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnn' (EpAnn ann)
-> e -> GenLocated (SrcSpanAnn' (EpAnn ann)) e
forall l e. l -> e -> GenLocated l e
L (EpAnn ann -> SrcSpan -> SrcSpanAnn' (EpAnn ann)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn ann
epa' SrcSpan
sp) e
x
    addCommentsBeforeEpAnn GenLocated (SrcSpanAnn' (EpAnn ann)) e
x = GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> m (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated (SrcSpanAnn' (EpAnn ann)) e
x
    partitionAboveNotAbove :: t (GenLocated Anchor e)
-> Anchor -> ([GenLocated Anchor e], [GenLocated Anchor e])
partitionAboveNotAbove t (GenLocated Anchor e)
cs Anchor
sp =
      (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
-> ([GenLocated Anchor e], [GenLocated Anchor e])
forall a b. (a, b) -> a
fst ((([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
 -> ([GenLocated Anchor e], [GenLocated Anchor e]))
-> (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
-> ([GenLocated Anchor e], [GenLocated Anchor e])
forall a b. (a -> b) -> a -> b
$
      (GenLocated Anchor e
 -> (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
 -> (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor))
-> (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
-> t (GenLocated Anchor e)
-> (([GenLocated Anchor e], [GenLocated Anchor e]), Anchor)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr'
        (\c :: GenLocated Anchor e
c@(L Anchor
l e
_) (([GenLocated Anchor e]
ls, [GenLocated Anchor e]
rs), Anchor
lastSpan) ->
           if Anchor -> RealSrcSpan
anchor Anchor
l RealSrcSpan -> RealSrcSpan -> Bool
`isAbove` Anchor -> RealSrcSpan
anchor Anchor
lastSpan
             then (([GenLocated Anchor e]
ls, GenLocated Anchor e
c GenLocated Anchor e
-> [GenLocated Anchor e] -> [GenLocated Anchor e]
forall a. a -> [a] -> [a]
: [GenLocated Anchor e]
rs), Anchor
l)
             else ((GenLocated Anchor e
c GenLocated Anchor e
-> [GenLocated Anchor e] -> [GenLocated Anchor e]
forall a. a -> [a] -> [a]
: [GenLocated Anchor e]
ls, [GenLocated Anchor e]
rs), Anchor
lastSpan))
        (([], []), Anchor
sp)
        t (GenLocated Anchor e)
cs
    isAbove :: RealSrcSpan -> RealSrcSpan -> Bool
isAbove RealSrcSpan
comAnc RealSrcSpan
anc =
      RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
comAnc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
anc Bool -> Bool -> Bool
&&
      RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
comAnc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
anc

-- | This function scans the given AST from bottom to top and locates
-- comments in the comment pool after each node on it.
relocateCommentsAfter :: HsModule -> WithComments HsModule
relocateCommentsAfter :: HsModule -> State [LEpaComment] HsModule
relocateCommentsAfter = (forall b. EpAnn b -> WithComments (EpAnn b))
-> HsModule -> State [LEpaComment] HsModule
forall a.
Data a =>
(forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
everywhereMEpAnnsBackwards EpAnn b -> WithComments (EpAnn b)
forall b. EpAnn b -> WithComments (EpAnn b)
f
  where
    f :: EpAnn a -> WithComments (EpAnn a)
f epa :: EpAnn a
epa@EpAnn {a
EpAnnComments
Anchor
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
entry :: Anchor
anns :: a
comments :: EpAnnComments
..} =
      (RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos (RealSrcSpan -> RealSrcSpan -> Bool
isAfter (RealSrcSpan -> RealSrcSpan -> Bool)
-> RealSrcSpan -> RealSrcSpan -> Bool
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
entry) EpAnnComments -> [LEpaComment] -> EpAnnComments
insertFollowingComments EpAnn a
epa
    f EpAnn a
EpAnnNotUsed = EpAnn a -> WithComments (EpAnn a)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpAnn a
forall ann. EpAnn ann
EpAnnNotUsed
    isAfter :: RealSrcSpan -> RealSrcSpan -> Bool
isAfter RealSrcSpan
anc RealSrcSpan
comAnc = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
anc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
comAnc

-- | This function applies the given function to all 'EpAnn's.
applyM ::
     forall a. Typeable a
  => (forall b. EpAnn b -> WithComments (EpAnn b))
  -> (a -> WithComments a)
applyM :: forall a.
Typeable a =>
(forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
applyM forall b. EpAnn b -> WithComments (EpAnn b)
f
  | App TypeRep a
g TypeRep b
_ <- forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a
  , Just a :~~: EpAnn
HRefl <- TypeRep a -> TypeRep EpAnn -> Maybe (a :~~: EpAnn)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
g (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> *). Typeable a => TypeRep a
typeRep @EpAnn) = a -> StateT [LEpaComment] Identity a
EpAnn b -> WithComments (EpAnn b)
forall b. EpAnn b -> WithComments (EpAnn b)
f
  | Bool
otherwise = a -> StateT [LEpaComment] Identity a
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | This function drains comments whose positions satisfy the given
-- predicate and inserts them to the given node using the given inserter.
insertCommentsByPos ::
     (RealSrcSpan -> Bool)
  -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
  -> EpAnn a
  -> WithComments (EpAnn a)
insertCommentsByPos :: forall a.
(RealSrcSpan -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertCommentsByPos RealSrcSpan -> Bool
cond = (LEpaComment -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
forall a.
(LEpaComment -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertComments (RealSrcSpan -> Bool
cond (RealSrcSpan -> Bool)
-> (LEpaComment -> RealSrcSpan) -> LEpaComment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> RealSrcSpan
anchor (Anchor -> RealSrcSpan)
-> (LEpaComment -> Anchor) -> LEpaComment -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> Anchor
forall l e. GenLocated l e -> l
getLoc)

-- | This function drains comments that satisfy the given predicate and
-- inserts them to the given node using the given inserter.
insertComments ::
     (LEpaComment -> Bool)
  -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
  -> EpAnn a
  -> WithComments (EpAnn a)
insertComments :: forall a.
(LEpaComment -> Bool)
-> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
-> EpAnn a
-> WithComments (EpAnn a)
insertComments LEpaComment -> Bool
cond EpAnnComments -> [LEpaComment] -> EpAnnComments
inserter epa :: EpAnn a
epa@EpAnn {a
EpAnnComments
Anchor
comments :: forall ann. EpAnn ann -> EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
entry :: Anchor
anns :: a
comments :: EpAnnComments
..} = do
  [LEpaComment]
coms <- (LEpaComment -> Bool) -> WithComments [LEpaComment]
drainComments LEpaComment -> Bool
cond
  EpAnn a -> WithComments (EpAnn a)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpAnn a -> WithComments (EpAnn a))
-> EpAnn a -> WithComments (EpAnn a)
forall a b. (a -> b) -> a -> b
$ EpAnn a
epa {comments :: EpAnnComments
comments = EpAnnComments -> [LEpaComment] -> EpAnnComments
inserter EpAnnComments
comments [LEpaComment]
coms}
insertComments LEpaComment -> Bool
_ EpAnnComments -> [LEpaComment] -> EpAnnComments
_ EpAnn a
EpAnnNotUsed = EpAnn a -> WithComments (EpAnn a)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpAnn a
forall ann. EpAnn ann
EpAnnNotUsed

-- | This function inserts comments to `priorComments`.
insertPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
insertPriorComments (EpaComments [LEpaComment]
prior) [LEpaComment]
cs =
  [LEpaComment] -> EpAnnComments
EpaComments ([LEpaComment] -> [LEpaComment]
sortCommentsByLocation ([LEpaComment] -> [LEpaComment]) -> [LEpaComment] -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ [LEpaComment]
prior [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
cs)
insertPriorComments (EpaCommentsBalanced [LEpaComment]
prior [LEpaComment]
following) [LEpaComment]
cs =
  [LEpaComment] -> [LEpaComment] -> EpAnnComments
EpaCommentsBalanced ([LEpaComment] -> [LEpaComment]
sortCommentsByLocation ([LEpaComment] -> [LEpaComment]) -> [LEpaComment] -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ [LEpaComment]
prior [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
cs) [LEpaComment]
following

-- | This function inserts comments to `followingComments`.
insertFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
insertFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
insertFollowingComments (EpaComments [LEpaComment]
prior) [LEpaComment]
cs = [LEpaComment] -> [LEpaComment] -> EpAnnComments
EpaCommentsBalanced [LEpaComment]
prior [LEpaComment]
cs
insertFollowingComments (EpaCommentsBalanced [LEpaComment]
prior [LEpaComment]
following) [LEpaComment]
cs =
  [LEpaComment] -> [LEpaComment] -> EpAnnComments
EpaCommentsBalanced [LEpaComment]
prior ([LEpaComment] -> [LEpaComment]
sortCommentsByLocation ([LEpaComment] -> [LEpaComment]) -> [LEpaComment] -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ [LEpaComment]
following [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
cs)

-- | This function drains comments that satisfy the given predicate.
drainComments :: (LEpaComment -> Bool) -> WithComments [LEpaComment]
drainComments :: (LEpaComment -> Bool) -> WithComments [LEpaComment]
drainComments LEpaComment -> Bool
cond = do
  [LEpaComment]
coms <- WithComments [LEpaComment]
forall s (m :: * -> *). MonadState s m => m s
get
  let ([LEpaComment]
xs, [LEpaComment]
others) = (LEpaComment -> Bool)
-> [LEpaComment] -> ([LEpaComment], [LEpaComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition LEpaComment -> Bool
cond [LEpaComment]
coms
  [LEpaComment] -> StateT [LEpaComment] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [LEpaComment]
others
  [LEpaComment] -> WithComments [LEpaComment]
forall a. a -> StateT [LEpaComment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [LEpaComment]
xs

-- | 'everywhereM' but applies the given function to EPAs in order their
-- positions from backwards.
everywhereMEpAnnsBackwards ::
     Data a
  => (forall b. EpAnn b -> WithComments (EpAnn b))
  -> a
  -> WithComments a
everywhereMEpAnnsBackwards :: forall a.
Data a =>
(forall b. EpAnn b -> WithComments (EpAnn b))
-> a -> WithComments a
everywhereMEpAnnsBackwards =
  (forall b c. EpAnn b -> EpAnn c -> Ordering)
-> (forall b. EpAnn b -> WithComments (EpAnn b))
-> a
-> WithComments a
forall a.
Data a =>
(forall b c. EpAnn b -> EpAnn c -> Ordering)
-> (forall b. EpAnn b -> WithComments (EpAnn b))
-> a
-> WithComments a
everywhereMEpAnnsInOrder ((EpAnn c -> EpAnn b -> Ordering) -> EpAnn b -> EpAnn c -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip EpAnn c -> EpAnn b -> Ordering
forall b c. EpAnn b -> EpAnn c -> Ordering
compareEpaByEndPosition)

-- | 'everywhereM' but applies the given function to EPAs in order
-- specified by the given ordering function.
everywhereMEpAnnsInOrder ::
     Data a
  => (forall b c. EpAnn b -> EpAnn c -> Ordering)
  -> (forall b. EpAnn b -> WithComments (EpAnn b))
  -> a
  -> WithComments a
everywhereMEpAnnsInOrder :: forall a.
Data a =>
(forall b c. EpAnn b -> EpAnn c -> Ordering)
-> (forall b. EpAnn b -> WithComments (EpAnn b))
-> a
-> WithComments a
everywhereMEpAnnsInOrder forall b c. EpAnn b -> EpAnn c -> Ordering
cmp forall b. EpAnn b -> WithComments (EpAnn b)
f a
hm =
  StateT [LEpaComment] Identity [Wrapper]
collectEpAnnsInOrderEverywhereMTraverses StateT [LEpaComment] Identity [Wrapper]
-> ([Wrapper] -> StateT [LEpaComment] Identity [(Int, Wrapper)])
-> StateT [LEpaComment] Identity [(Int, Wrapper)]
forall a b.
StateT [LEpaComment] Identity a
-> (a -> StateT [LEpaComment] Identity b)
-> StateT [LEpaComment] Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  [Wrapper] -> StateT [LEpaComment] Identity [(Int, Wrapper)]
applyFunctionInOrderEpAnnEndPositions StateT [LEpaComment] Identity [(Int, Wrapper)]
-> ([(Int, Wrapper)] -> StateT [LEpaComment] Identity a)
-> StateT [LEpaComment] Identity a
forall a b.
StateT [LEpaComment] Identity a
-> (a -> StateT [LEpaComment] Identity b)
-> StateT [LEpaComment] Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  [(Int, Wrapper)] -> StateT [LEpaComment] Identity a
putModifiedEpAnnsToModule
  where
    collectEpAnnsInOrderEverywhereMTraverses :: StateT [LEpaComment] Identity [Wrapper]
collectEpAnnsInOrderEverywhereMTraverses
      -- This function uses 'everywhereM' to collect 'EpAnn's because they
      -- should be collected in the same order as 'putModifiedEpAnnsToModule'
      -- puts them to the AST.
     = [Wrapper] -> [Wrapper]
forall a. [a] -> [a]
reverse ([Wrapper] -> [Wrapper])
-> StateT [LEpaComment] Identity [Wrapper]
-> StateT [LEpaComment] Identity [Wrapper]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Wrapper] (StateT [LEpaComment] Identity) a
-> [Wrapper] -> StateT [LEpaComment] Identity [Wrapper]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (GenericM (StateT [Wrapper] (StateT [LEpaComment] Identity))
-> GenericM (StateT [Wrapper] (StateT [LEpaComment] Identity))
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM a -> StateT [Wrapper] (StateT [LEpaComment] Identity) a
GenericM (StateT [Wrapper] (StateT [LEpaComment] Identity))
forall {m :: * -> *} {b}.
(MonadState [Wrapper] m, Typeable b) =>
b -> m b
collectEpAnnsST a
hm) []
      where
        collectEpAnnsST :: b -> m b
collectEpAnnsST b
x = do
          ([Wrapper] -> [Wrapper]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([Wrapper] -> [Wrapper]) -> m ())
-> ([Wrapper] -> [Wrapper]) -> m ()
forall a b. (a -> b) -> a -> b
$ b -> [Wrapper] -> [Wrapper]
forall a. Typeable a => a -> [Wrapper] -> [Wrapper]
collectEpAnns b
x
          b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
        collectEpAnns ::
             forall a. Typeable a
          => a
          -> ([Wrapper] -> [Wrapper])
        collectEpAnns :: forall a. Typeable a => a -> [Wrapper] -> [Wrapper]
collectEpAnns a
x
          -- If 'a' is 'EpAnn b' ('b' can be any type), wrap 'x' with a 'Wrapper'.
          | App TypeRep a
g TypeRep b
_ <- forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a
          , Just a :~~: EpAnn
HRefl <- TypeRep a -> TypeRep EpAnn -> Maybe (a :~~: EpAnn)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
g (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> *). Typeable a => TypeRep a
typeRep @EpAnn) = (EpAnn b -> Wrapper
forall a. Typeable (EpAnn a) => EpAnn a -> Wrapper
Wrapper a
EpAnn b
x Wrapper -> [Wrapper] -> [Wrapper]
forall a. a -> [a] -> [a]
:)
          | Bool
otherwise = [Wrapper] -> [Wrapper]
forall a. a -> a
id
    applyFunctionInOrderEpAnnEndPositions ::
         [Wrapper]
      -> WithComments [(Int, Wrapper)] -- ^ The first element of the tuple
                                       -- indicates how many 'Wrapper's were there before 'everywhereM'
                                       -- accessed the second element.
    applyFunctionInOrderEpAnnEndPositions :: [Wrapper] -> StateT [LEpaComment] Identity [(Int, Wrapper)]
applyFunctionInOrderEpAnnEndPositions [Wrapper]
anns =
      [(Int, Wrapper)]
-> ((Int, Wrapper) -> StateT [LEpaComment] Identity (Int, Wrapper))
-> StateT [LEpaComment] Identity [(Int, Wrapper)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, Wrapper)]
sorted (((Int, Wrapper) -> StateT [LEpaComment] Identity (Int, Wrapper))
 -> StateT [LEpaComment] Identity [(Int, Wrapper)])
-> ((Int, Wrapper) -> StateT [LEpaComment] Identity (Int, Wrapper))
-> StateT [LEpaComment] Identity [(Int, Wrapper)]
forall a b. (a -> b) -> a -> b
$ \(Int
i, Wrapper EpAnn a
x) -> do
        EpAnn a
x' <- EpAnn a -> WithComments (EpAnn a)
forall b. EpAnn b -> WithComments (EpAnn b)
f EpAnn a
x
        (Int, Wrapper) -> StateT [LEpaComment] Identity (Int, Wrapper)
forall a. a -> StateT [LEpaComment] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, EpAnn a -> Wrapper
forall a. Typeable (EpAnn a) => EpAnn a -> Wrapper
Wrapper EpAnn a
x')
      where
        indexed :: [(Int, Wrapper)]
indexed = [Int] -> [Wrapper] -> [(Int, Wrapper)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Wrapper]
anns
        sorted :: [(Int, Wrapper)]
sorted = ((Int, Wrapper) -> (Int, Wrapper) -> Ordering)
-> [(Int, Wrapper)] -> [(Int, Wrapper)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
_, Wrapper EpAnn a
a) (Int
_, Wrapper EpAnn a
b) -> EpAnn a -> EpAnn a -> Ordering
forall b c. EpAnn b -> EpAnn c -> Ordering
cmp EpAnn a
a EpAnn a
b) [(Int, Wrapper)]
indexed
    putModifiedEpAnnsToModule :: [(Int, Wrapper)] -> StateT [LEpaComment] Identity a
putModifiedEpAnnsToModule [(Int, Wrapper)]
anns = StateT [Int] (StateT [LEpaComment] Identity) a
-> [Int] -> StateT [LEpaComment] Identity a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GenericM (StateT [Int] (StateT [LEpaComment] Identity))
-> GenericM (StateT [Int] (StateT [LEpaComment] Identity))
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM a -> StateT [Int] (StateT [LEpaComment] Identity) a
GenericM (StateT [Int] (StateT [LEpaComment] Identity))
forall a.
Typeable a =>
a -> StateT [Int] (StateT [LEpaComment] Identity) a
setEpAnn a
hm) [Int
0 ..]
      where
        setEpAnn ::
             forall a. Typeable a
          => a
          -> StateT [Int] WithComments a
        setEpAnn :: forall a.
Typeable a =>
a -> StateT [Int] (StateT [LEpaComment] Identity) a
setEpAnn a
x
          -- This guard arm checks if 'a' is 'EpAnn b' ('b' can be any type).
          | App TypeRep a
g TypeRep b
g' <- forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a
          , Just a :~~: EpAnn
HRefl <- TypeRep a -> TypeRep EpAnn -> Maybe (a :~~: EpAnn)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
g (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> *). Typeable a => TypeRep a
typeRep @EpAnn) = do
            Int
i <- ([Int] -> Int) -> StateT [Int] (StateT [LEpaComment] Identity) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [Int] -> Int
forall a. HasCallStack => [a] -> a
head
            ([Int] -> [Int]) -> StateT [Int] (StateT [LEpaComment] Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
tail
            case Int -> [(Int, Wrapper)] -> Maybe Wrapper
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Wrapper)]
anns of
              Just (Wrapper EpAnn a
y)
                | App TypeRep a
_ TypeRep b
h <- EpAnn a -> TypeRep (EpAnn a)
forall a. Typeable a => a -> TypeRep a
typeOf EpAnn a
y
                , Just b :~~: b
HRefl <- TypeRep b -> TypeRep b -> Maybe (b :~~: b)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep b
g' TypeRep b
h -> a -> StateT [Int] (StateT [LEpaComment] Identity) a
forall a. a -> StateT [Int] (StateT [LEpaComment] Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
EpAnn a
y
              Maybe Wrapper
_ -> [Char] -> StateT [Int] (StateT [LEpaComment] Identity) a
forall a. HasCallStack => [Char] -> a
error [Char]
"Unmatches"
          | Bool
otherwise = a -> StateT [Int] (StateT [LEpaComment] Identity) a
forall a. a -> StateT [Int] (StateT [LEpaComment] Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | This function sorts comments by its location.
sortCommentsByLocation :: [LEpaComment] -> [LEpaComment]
sortCommentsByLocation :: [LEpaComment] -> [LEpaComment]
sortCommentsByLocation = (LEpaComment -> LEpaComment -> Ordering)
-> [LEpaComment] -> [LEpaComment]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> (LEpaComment -> RealSrcSpan)
-> LEpaComment
-> LEpaComment
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Anchor -> RealSrcSpan
anchor (Anchor -> RealSrcSpan)
-> (LEpaComment -> Anchor) -> LEpaComment -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> Anchor
forall l e. GenLocated l e -> l
getLoc)

-- | This function compares given EPAs by their end positions.
compareEpaByEndPosition :: EpAnn a -> EpAnn b -> Ordering
compareEpaByEndPosition :: forall b c. EpAnn b -> EpAnn c -> Ordering
compareEpaByEndPosition (EpAnn Anchor
a a
_ EpAnnComments
_) (EpAnn Anchor
b b
_ EpAnnComments
_) =
  (RealSrcLoc -> RealSrcLoc -> Ordering)
-> (Anchor -> RealSrcLoc) -> Anchor -> Anchor -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on RealSrcLoc -> RealSrcLoc -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcLoc
realSrcSpanEnd (RealSrcSpan -> RealSrcLoc)
-> (Anchor -> RealSrcSpan) -> Anchor -> RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> RealSrcSpan
anchor) Anchor
a Anchor
b
compareEpaByEndPosition EpAnn a
EpAnnNotUsed EpAnn b
EpAnnNotUsed = Ordering
EQ
compareEpaByEndPosition EpAnn a
_ EpAnn b
EpAnnNotUsed = Ordering
GT
compareEpaByEndPosition EpAnn a
EpAnnNotUsed EpAnn b
_ = Ordering
LT