{-# LANGUAGE DataKinds #-}

module Language.Haskell.Brittany.Internal.ExactPrintUtils
  ( parseModule
  , parseModuleFromString
  , commentAnnFixTransform
  , commentAnnFixTransformGlob
  , extractToplevelAnns
  , foldedAnnKeys
  , withTransformedAnns
  )
where



#include "prelude.inc"

import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.Utils
import           Data.Data
import           Data.HList.HList

import           DynFlags ( getDynFlags )
import           GHC ( runGhc, GenLocated(L), moduleNameString )
import qualified DynFlags      as GHC
import qualified GHC           as GHC hiding (parseModule)
import qualified Parser        as GHC
import qualified SrcLoc        as GHC
import qualified FastString    as GHC
import qualified GHC           as GHC hiding (parseModule)
import qualified Lexer         as GHC
import qualified StringBuffer  as GHC
import qualified Outputable    as GHC
import qualified CmdLineParser as GHC

#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
import           GHC.Hs
import           Bag
#else
import           HsSyn
#endif

import           SrcLoc ( SrcSpan, Located )


import qualified Language.Haskell.GHC.ExactPrint            as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate   as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types      as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers    as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta      as ExactPrint

import qualified Data.Generics as SYB

import           Control.Exception
-- import           Data.Generics.Schemes



parseModule
  :: [String]
  -> System.IO.FilePath
  -> (GHC.DynFlags -> IO (Either String a))
  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModule :: [String]
-> String
-> (DynFlags -> IO (Either String a))
-> IO (Either String (Anns, ParsedSource, a))
parseModule =
  CppOptions
-> DeltaOptions
-> [String]
-> String
-> (DynFlags -> IO (Either String a))
-> IO (Either String (Anns, ParsedSource, a))
forall a.
CppOptions
-> DeltaOptions
-> [String]
-> String
-> (DynFlags -> IO (Either String a))
-> IO (Either String (Anns, ParsedSource, a))
parseModuleWithCpp CppOptions
ExactPrint.defaultCppOptions DeltaOptions
ExactPrint.normalLayout

-- | Parse a module with specific instructions for the C pre-processor.
parseModuleWithCpp
  :: ExactPrint.CppOptions
  -> ExactPrint.DeltaOptions
  -> [String]
  -> System.IO.FilePath
  -> (GHC.DynFlags -> IO (Either String a))
  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleWithCpp :: CppOptions
-> DeltaOptions
-> [String]
-> String
-> (DynFlags -> IO (Either String a))
-> IO (Either String (Anns, ParsedSource, a))
parseModuleWithCpp CppOptions
cpp DeltaOptions
opts [String]
args String
fp DynFlags -> IO (Either String a)
dynCheck =
  Ghc (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a. Ghc a -> IO a
ExactPrint.ghcWrapper (Ghc (Either String (Anns, ParsedSource, a))
 -> IO (Either String (Anns, ParsedSource, a)))
-> Ghc (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a b. (a -> b) -> a -> b
$ ExceptT String Ghc (Anns, ParsedSource, a)
-> Ghc (Either String (Anns, ParsedSource, a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
ExceptT.runExceptT (ExceptT String Ghc (Anns, ParsedSource, a)
 -> Ghc (Either String (Anns, ParsedSource, a)))
-> ExceptT String Ghc (Anns, ParsedSource, a)
-> Ghc (Either String (Anns, ParsedSource, a))
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags0                       <- Ghc DynFlags -> ExceptT String Ghc DynFlags
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc DynFlags -> ExceptT String Ghc DynFlags)
-> Ghc DynFlags -> ExceptT String Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    (DynFlags
dflags1, [Located String]
leftover, [Warn]
warnings) <- Ghc (DynFlags, [Located String], [Warn])
-> ExceptT String Ghc (DynFlags, [Located String], [Warn])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc (DynFlags, [Located String], [Warn])
 -> ExceptT String Ghc (DynFlags, [Located String], [Warn]))
-> Ghc (DynFlags, [Located String], [Warn])
-> ExceptT String Ghc (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlagsCmdLine
      DynFlags
dflags0
      (String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
"-hide-all-packages" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args))
      -- that we pass -hide-all-packages here is a duplication, because
      -- ExactPrint.initDynFlags also does it, but necessary because of
      -- stupid and careless GHC API design. We explicitly want to pass
      -- our args before calling that, so this is what we do. Should be
      -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063.
    ExceptT String Ghc [InstalledUnitId] -> ExceptT String Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT String Ghc [InstalledUnitId] -> ExceptT String Ghc ())
-> ExceptT String Ghc [InstalledUnitId] -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$ Ghc [InstalledUnitId] -> ExceptT String Ghc [InstalledUnitId]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc [InstalledUnitId] -> ExceptT String Ghc [InstalledUnitId])
-> Ghc [InstalledUnitId] -> ExceptT String Ghc [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags1
    DynFlags
dflags2 <- Ghc DynFlags -> ExceptT String Ghc DynFlags
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc DynFlags -> ExceptT String Ghc DynFlags)
-> Ghc DynFlags -> ExceptT String Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ String -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => String -> m DynFlags
ExactPrint.initDynFlags String
fp
    Bool -> ExceptT String Ghc () -> ExceptT String Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Located String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
leftover)
      (ExceptT String Ghc () -> ExceptT String Ghc ())
-> ExceptT String Ghc () -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String -> ExceptT String Ghc ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE
      (String -> ExceptT String Ghc ())
-> String -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String
"when parsing ghc flags: leftover flags: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([Located String]
leftover [Located String] -> (Located String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(L SrcSpan
_ String
s) -> String
s)
    Bool -> ExceptT String Ghc () -> ExceptT String Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Warn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Warn]
warnings)
      (ExceptT String Ghc () -> ExceptT String Ghc ())
-> ExceptT String Ghc () -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String -> ExceptT String Ghc ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE
      (String -> ExceptT String Ghc ())
-> String -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String
"when parsing ghc flags: encountered warnings: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([Warn]
warnings [Warn] -> (Warn -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Warn -> String
warnExtractorCompat)
    a
x   <- Ghc (Either String a) -> ExceptT String Ghc a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT.ExceptT (Ghc (Either String a) -> ExceptT String Ghc a)
-> Ghc (Either String a) -> ExceptT String Ghc a
forall a b. (a -> b) -> a -> b
$ IO (Either String a) -> Ghc (Either String a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> Ghc (Either String a))
-> IO (Either String a) -> Ghc (Either String a)
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO (Either String a)
dynCheck DynFlags
dflags2
    Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource)
res <- Ghc
  (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
-> ExceptT
     String
     Ghc
     (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc
   (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
 -> ExceptT
      String
      Ghc
      (Either
         ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource)))
-> Ghc
     (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
-> ExceptT
     String
     Ghc
     (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
forall a b. (a -> b) -> a -> b
$ CppOptions
-> DynFlags
-> String
-> Ghc
     (Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource))
ExactPrint.parseModuleApiAnnsWithCppInternal CppOptions
cpp DynFlags
dflags2 String
fp
#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
    (ErrorMessages -> ExceptT String Ghc (Anns, ParsedSource, a))
-> ((Anns, ParsedSource)
    -> ExceptT String Ghc (Anns, ParsedSource, a))
-> Either ErrorMessages (Anns, ParsedSource)
-> ExceptT String Ghc (Anns, ParsedSource, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ErrorMessages
err -> String -> ExceptT String Ghc (Anns, ParsedSource, a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE (String -> ExceptT String Ghc (Anns, ParsedSource, a))
-> String -> ExceptT String Ghc (Anns, ParsedSource, a)
forall a b. (a -> b) -> a -> b
$ String
"transform error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (Bag String -> [String]
forall a. Bag a -> [a]
bagToList (ErrMsg -> String
forall a. Show a => a -> String
show (ErrMsg -> String) -> ErrorMessages -> Bag String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorMessages
err)))
#else
    either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
#endif
           (\(Anns
a, ParsedSource
m) -> (Anns, ParsedSource, a)
-> ExceptT String Ghc (Anns, ParsedSource, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
a, ParsedSource
m, a
x))
      (Either ErrorMessages (Anns, ParsedSource)
 -> ExceptT String Ghc (Anns, ParsedSource, a))
-> Either ErrorMessages (Anns, ParsedSource)
-> ExceptT String Ghc (Anns, ParsedSource, a)
forall a b. (a -> b) -> a -> b
$ Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource)
-> DeltaOptions -> Either ErrorMessages (Anns, ParsedSource)
forall a.
Either a (ApiAnns, [Comment], DynFlags, ParsedSource)
-> DeltaOptions -> Either a (Anns, ParsedSource)
ExactPrint.postParseTransform Either ErrorMessages (ApiAnns, [Comment], DynFlags, ParsedSource)
res DeltaOptions
opts

parseModuleFromString
  :: [String]
  -> System.IO.FilePath
  -> (GHC.DynFlags -> IO (Either String a))
  -> String
  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleFromString :: [String]
-> String
-> (DynFlags -> IO (Either String a))
-> String
-> IO (Either String (Anns, ParsedSource, a))
parseModuleFromString [String]
args String
fp DynFlags -> IO (Either String a)
dynCheck String
str =
  -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will
  -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we
  -- cannot kill the parsing thread - not very nice. But i'll
  -- optimistically assume that most of the time brittany uses noticable or
  -- longer time, the majority of the time is not spend in parsing, but in
  -- bridoc transformation stuff.
  -- (reminder to update note on `parsePrintModule` if this changes.)
  IO (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a. IO a -> IO a
mask_ (IO (Either String (Anns, ParsedSource, a))
 -> IO (Either String (Anns, ParsedSource, a)))
-> IO (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a b. (a -> b) -> a -> b
$ Ghc (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a. Ghc a -> IO a
ExactPrint.ghcWrapper (Ghc (Either String (Anns, ParsedSource, a))
 -> IO (Either String (Anns, ParsedSource, a)))
-> Ghc (Either String (Anns, ParsedSource, a))
-> IO (Either String (Anns, ParsedSource, a))
forall a b. (a -> b) -> a -> b
$ ExceptT String Ghc (Anns, ParsedSource, a)
-> Ghc (Either String (Anns, ParsedSource, a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
ExceptT.runExceptT (ExceptT String Ghc (Anns, ParsedSource, a)
 -> Ghc (Either String (Anns, ParsedSource, a)))
-> ExceptT String Ghc (Anns, ParsedSource, a)
-> Ghc (Either String (Anns, ParsedSource, a))
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags0                       <- Ghc DynFlags -> ExceptT String Ghc DynFlags
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ghc DynFlags -> ExceptT String Ghc DynFlags)
-> Ghc DynFlags -> ExceptT String Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ String -> String -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => String -> String -> m DynFlags
ExactPrint.initDynFlagsPure String
fp String
str
    (DynFlags
dflags1, [Located String]
leftover, [Warn]
warnings) <- Ghc (DynFlags, [Located String], [Warn])
-> ExceptT String Ghc (DynFlags, [Located String], [Warn])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (Ghc (DynFlags, [Located String], [Warn])
 -> ExceptT String Ghc (DynFlags, [Located String], [Warn]))
-> Ghc (DynFlags, [Located String], [Warn])
-> ExceptT String Ghc (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlagsCmdLine DynFlags
dflags0 (String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args)
    Bool -> ExceptT String Ghc () -> ExceptT String Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Located String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
leftover)
      (ExceptT String Ghc () -> ExceptT String Ghc ())
-> ExceptT String Ghc () -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String -> ExceptT String Ghc ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE
      (String -> ExceptT String Ghc ())
-> String -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String
"when parsing ghc flags: leftover flags: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([Located String]
leftover [Located String] -> (Located String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(L SrcSpan
_ String
s) -> String
s)
    Bool -> ExceptT String Ghc () -> ExceptT String Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Warn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Warn]
warnings)
      (ExceptT String Ghc () -> ExceptT String Ghc ())
-> ExceptT String Ghc () -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String -> ExceptT String Ghc ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE
      (String -> ExceptT String Ghc ())
-> String -> ExceptT String Ghc ()
forall a b. (a -> b) -> a -> b
$  String
"when parsing ghc flags: encountered warnings: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([Warn]
warnings [Warn] -> (Warn -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Warn -> String
warnExtractorCompat)
    a
dynCheckRes <- Ghc (Either String a) -> ExceptT String Ghc a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT.ExceptT (Ghc (Either String a) -> ExceptT String Ghc a)
-> Ghc (Either String a) -> ExceptT String Ghc a
forall a b. (a -> b) -> a -> b
$ IO (Either String a) -> Ghc (Either String a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> Ghc (Either String a))
-> IO (Either String a) -> Ghc (Either String a)
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO (Either String a)
dynCheck DynFlags
dflags1
    let res :: Either ErrorMessages (Anns, ParsedSource)
res = Parser ParsedSource
ExactPrint.parseModuleFromStringInternal DynFlags
dflags1 String
fp String
str
    case Either ErrorMessages (Anns, ParsedSource)
res of
#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
      Left  ErrorMessages
err -> String -> ExceptT String Ghc (Anns, ParsedSource, a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE (String -> ExceptT String Ghc (Anns, ParsedSource, a))
-> String -> ExceptT String Ghc (Anns, ParsedSource, a)
forall a b. (a -> b) -> a -> b
$ String
"parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (Bag String -> [String]
forall a. Bag a -> [a]
bagToList (ErrMsg -> String
forall a. Show a => a -> String
show (ErrMsg -> String) -> ErrorMessages -> Bag String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorMessages
err))
#else
      Left  (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err
#endif
      Right (Anns
a   , ParsedSource
m  ) -> (Anns, ParsedSource, a)
-> ExceptT String Ghc (Anns, ParsedSource, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
a, ParsedSource
m, a
dynCheckRes)


commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob :: ast -> Transform ()
commentAnnFixTransformGlob ast
ast = do
  let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
      extract :: a -> Seq (SrcSpan, AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
        Seq (SrcSpan, AnnKey) -> a -> Seq (SrcSpan, AnnKey)
forall a b. a -> b -> a
const Seq (SrcSpan, AnnKey)
forall a. Seq a
Seq.empty
          (a -> Seq (SrcSpan, AnnKey))
-> (forall e.
    Data e =>
    GenLocated SrcSpan e -> Seq (SrcSpan, AnnKey))
-> a
-> Seq (SrcSpan, AnnKey)
forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`SYB.ext1Q`
            (\l :: GenLocated SrcSpan e
l@(L span _) -> (SrcSpan, AnnKey) -> Seq (SrcSpan, AnnKey)
forall a. a -> Seq a
Seq.singleton (SrcSpan
span, GenLocated SrcSpan e -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey GenLocated SrcSpan e
l))
  let nodes :: Seq (SrcSpan, AnnKey)
nodes = (Seq (SrcSpan, AnnKey)
 -> Seq (SrcSpan, AnnKey) -> Seq (SrcSpan, AnnKey))
-> GenericQ (Seq (SrcSpan, AnnKey)) -> ast -> Seq (SrcSpan, AnnKey)
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything Seq (SrcSpan, AnnKey)
-> Seq (SrcSpan, AnnKey) -> Seq (SrcSpan, AnnKey)
forall a. Semigroup a => a -> a -> a
(<>) GenericQ (Seq (SrcSpan, AnnKey))
extract ast
ast
  let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
      annsMap :: Map RealSrcLoc AnnKey
annsMap = (AnnKey -> AnnKey -> AnnKey)
-> [(RealSrcLoc, AnnKey)] -> Map RealSrcLoc AnnKey
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        ((AnnKey -> AnnKey -> AnnKey) -> AnnKey -> AnnKey -> AnnKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnnKey -> AnnKey -> AnnKey
forall a b. a -> b -> a
const)
        [ (RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanEnd RealSrcSpan
span, AnnKey
annKey)
        | (GHC.RealSrcSpan RealSrcSpan
span, AnnKey
annKey) <- Seq (SrcSpan, AnnKey) -> [(SrcSpan, AnnKey)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (SrcSpan, AnnKey)
nodes
        ]
  Seq (SrcSpan, AnnKey)
nodes Seq (SrcSpan, AnnKey)
-> ((SrcSpan, AnnKey) -> Transform ()) -> Transform ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` ((SrcSpan, AnnKey) -> AnnKey
forall a b. (a, b) -> b
snd ((SrcSpan, AnnKey) -> AnnKey)
-> (AnnKey -> Transform ()) -> (SrcSpan, AnnKey) -> Transform ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Map RealSrcLoc AnnKey -> AnnKey -> Transform ()
processComs Map RealSrcLoc AnnKey
annsMap)
 where
  processComs :: Map RealSrcLoc AnnKey -> AnnKey -> Transform ()
processComs Map RealSrcLoc AnnKey
annsMap AnnKey
annKey1 = do
    Maybe Annotation
mAnn <- ((Anns, Int) -> Anns) -> TransformT Identity Anns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.Class.gets (Anns, Int) -> Anns
forall a b. (a, b) -> a
fst TransformT Identity Anns
-> (Anns -> Maybe Annotation)
-> TransformT Identity (Maybe Annotation)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey1
    Maybe Annotation
mAnn Maybe Annotation -> (Annotation -> Transform ()) -> Transform ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \Annotation
ann1 -> do
      let priors :: [(Comment, DeltaPos)]
priors  = Annotation -> [(Comment, DeltaPos)]
ExactPrint.annPriorComments Annotation
ann1
          follows :: [(Comment, DeltaPos)]
follows = Annotation -> [(Comment, DeltaPos)]
ExactPrint.annFollowingComments Annotation
ann1
          assocs :: [(KeywordId, DeltaPos)]
assocs  = Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.annsDP Annotation
ann1
      let
        processCom
          :: (ExactPrint.Comment, ExactPrint.DeltaPos)
          -> ExactPrint.TransformT Identity Bool
        processCom :: (Comment, DeltaPos) -> TransformT Identity Bool
processCom comPair :: (Comment, DeltaPos)
comPair@(Comment
com, DeltaPos
_) =
          case SrcSpan -> SrcLoc
GHC.srcSpanStart (SrcSpan -> SrcLoc) -> SrcSpan -> SrcLoc
forall a b. (a -> b) -> a -> b
$ Comment -> SrcSpan
ExactPrint.commentIdentifier Comment
com of
            GHC.UnhelpfulLoc{}    -> Bool -> TransformT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- retain comment at current node.
            GHC.RealSrcLoc RealSrcLoc
comLoc -> case RealSrcLoc -> Map RealSrcLoc AnnKey -> Maybe (RealSrcLoc, AnnKey)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE RealSrcLoc
comLoc Map RealSrcLoc AnnKey
annsMap of
              Just (RealSrcLoc
_, AnnKey
annKey2) | SrcLoc
loc1 SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcLoc
loc2 -> case (AnnConName
con1, AnnConName
con2) of
                (ExactPrint.CN String
"RecordCon", ExactPrint.CN String
"HsRecField") ->
                  Transform ()
move Transform () -> Bool -> TransformT Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
                (AnnConName
x, AnnConName
y) | AnnConName
x AnnConName -> AnnConName -> Bool
forall a. Eq a => a -> a -> Bool
== AnnConName
y -> Transform ()
move Transform () -> Bool -> TransformT Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
                (AnnConName, AnnConName)
_               -> Bool -> TransformT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               where
                ExactPrint.AnnKey SrcSpan
annKeyLoc1 AnnConName
con1 = AnnKey
annKey1
                ExactPrint.AnnKey SrcSpan
annKeyLoc2 AnnConName
con2 = AnnKey
annKey2
                loc1 :: SrcLoc
loc1                              = SrcSpan -> SrcLoc
GHC.srcSpanStart SrcSpan
annKeyLoc1
                loc2 :: SrcLoc
loc2                              = SrcSpan -> SrcLoc
GHC.srcSpanStart SrcSpan
annKeyLoc2
                move :: Transform ()
move = (Anns -> Anns) -> Transform ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
ExactPrint.modifyAnnsT ((Anns -> Anns) -> Transform ()) -> (Anns -> Anns) -> Transform ()
forall a b. (a -> b) -> a -> b
$ \Anns
anns ->
                  let
                    ann2 :: Annotation
ann2  = Maybe Annotation -> Annotation
forall a. HasCallStack => Maybe a -> a
Data.Maybe.fromJust (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey2 Anns
anns
                    ann2' :: Annotation
ann2' = Annotation
ann2
                      { annFollowingComments :: [(Comment, DeltaPos)]
ExactPrint.annFollowingComments =
                          Annotation -> [(Comment, DeltaPos)]
ExactPrint.annFollowingComments Annotation
ann2 [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment, DeltaPos)
comPair]
                      }
                  in
                    AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
annKey2 Annotation
ann2' Anns
anns
              Maybe (RealSrcLoc, AnnKey)
_ -> Bool -> TransformT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- retain comment at current node.
      [(Comment, DeltaPos)]
priors'  <- (((Comment, DeltaPos) -> TransformT Identity Bool)
 -> [(Comment, DeltaPos)]
 -> TransformT Identity [(Comment, DeltaPos)])
-> [(Comment, DeltaPos)]
-> ((Comment, DeltaPos) -> TransformT Identity Bool)
-> TransformT Identity [(Comment, DeltaPos)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Comment, DeltaPos) -> TransformT Identity Bool)
-> [(Comment, DeltaPos)]
-> TransformT Identity [(Comment, DeltaPos)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [(Comment, DeltaPos)]
priors (Comment, DeltaPos) -> TransformT Identity Bool
processCom
      [(Comment, DeltaPos)]
follows' <- (((Comment, DeltaPos) -> TransformT Identity Bool)
 -> [(Comment, DeltaPos)]
 -> TransformT Identity [(Comment, DeltaPos)])
-> [(Comment, DeltaPos)]
-> ((Comment, DeltaPos) -> TransformT Identity Bool)
-> TransformT Identity [(Comment, DeltaPos)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Comment, DeltaPos) -> TransformT Identity Bool)
-> [(Comment, DeltaPos)]
-> TransformT Identity [(Comment, DeltaPos)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [(Comment, DeltaPos)]
follows (((Comment, DeltaPos) -> TransformT Identity Bool)
 -> TransformT Identity [(Comment, DeltaPos)])
-> ((Comment, DeltaPos) -> TransformT Identity Bool)
-> TransformT Identity [(Comment, DeltaPos)]
forall a b. (a -> b) -> a -> b
$ (Comment, DeltaPos) -> TransformT Identity Bool
processCom
      [(KeywordId, DeltaPos)]
assocs'  <- (((KeywordId, DeltaPos) -> TransformT Identity Bool)
 -> [(KeywordId, DeltaPos)]
 -> TransformT Identity [(KeywordId, DeltaPos)])
-> [(KeywordId, DeltaPos)]
-> ((KeywordId, DeltaPos) -> TransformT Identity Bool)
-> TransformT Identity [(KeywordId, DeltaPos)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((KeywordId, DeltaPos) -> TransformT Identity Bool)
-> [(KeywordId, DeltaPos)]
-> TransformT Identity [(KeywordId, DeltaPos)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [(KeywordId, DeltaPos)]
assocs (((KeywordId, DeltaPos) -> TransformT Identity Bool)
 -> TransformT Identity [(KeywordId, DeltaPos)])
-> ((KeywordId, DeltaPos) -> TransformT Identity Bool)
-> TransformT Identity [(KeywordId, DeltaPos)]
forall a b. (a -> b) -> a -> b
$ \case
        (ExactPrint.AnnComment Comment
com, DeltaPos
dp) -> (Comment, DeltaPos) -> TransformT Identity Bool
processCom (Comment
com, DeltaPos
dp)
        (KeywordId, DeltaPos)
_                               -> Bool -> TransformT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      let ann1' :: Annotation
ann1' = Annotation
ann1 { annPriorComments :: [(Comment, DeltaPos)]
ExactPrint.annPriorComments     = [(Comment, DeltaPos)]
priors'
                       , annFollowingComments :: [(Comment, DeltaPos)]
ExactPrint.annFollowingComments = [(Comment, DeltaPos)]
follows'
                       , annsDP :: [(KeywordId, DeltaPos)]
ExactPrint.annsDP               = [(KeywordId, DeltaPos)]
assocs'
                       }
      (Anns -> Anns) -> Transform ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
ExactPrint.modifyAnnsT ((Anns -> Anns) -> Transform ()) -> (Anns -> Anns) -> Transform ()
forall a b. (a -> b) -> a -> b
$ \Anns
anns -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
annKey1 Annotation
ann1' Anns
anns



commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
commentAnnFixTransform :: ParsedSource -> Transform ()
commentAnnFixTransform ParsedSource
modul = (Transform () -> Transform () -> Transform ())
-> GenericQ (Transform ()) -> ParsedSource -> Transform ()
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything Transform () -> Transform () -> Transform ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) GenericQ (Transform ())
genF ParsedSource
modul
 where
  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
  genF :: a -> Transform ()
genF = (\a
_ -> () -> Transform ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (a -> Transform ())
-> (Located (HsExpr GhcPs) -> Transform ()) -> a -> Transform ()
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` Located (HsExpr GhcPs) -> Transform ()
exprF
  exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
  exprF :: Located (HsExpr GhcPs) -> Transform ()
exprF lexpr :: Located (HsExpr GhcPs)
lexpr@(L SrcSpan
_ HsExpr GhcPs
expr) = case HsExpr GhcPs
expr of
    RecordCon XRecordCon GhcPs
_ Located (IdP GhcPs)
_ (HsRecFields fs :: [LHsRecField GhcPs (Located (HsExpr GhcPs))]
fs@(LHsRecField GhcPs (Located (HsExpr GhcPs))
_:[LHsRecField GhcPs (Located (HsExpr GhcPs))]
_) Maybe (Located Int)
Nothing) ->
      Located (HsExpr GhcPs)
-> LHsRecField GhcPs (Located (HsExpr GhcPs)) -> Transform ()
forall a b.
(Data a, Data b) =>
Located a -> Located b -> Transform ()
moveTrailingComments Located (HsExpr GhcPs)
lexpr ([LHsRecField GhcPs (Located (HsExpr GhcPs))]
-> LHsRecField GhcPs (Located (HsExpr GhcPs))
forall a. [a] -> a
List.last [LHsRecField GhcPs (Located (HsExpr GhcPs))]
fs)
    RecordUpd XRecordUpd GhcPs
_ Located (HsExpr GhcPs)
_e fs :: [LHsRecUpdField GhcPs]
fs@(LHsRecUpdField GhcPs
_:[LHsRecUpdField GhcPs]
_) ->
      Located (HsExpr GhcPs) -> LHsRecUpdField GhcPs -> Transform ()
forall a b.
(Data a, Data b) =>
Located a -> Located b -> Transform ()
moveTrailingComments Located (HsExpr GhcPs)
lexpr ([LHsRecUpdField GhcPs] -> LHsRecUpdField GhcPs
forall a. [a] -> a
List.last [LHsRecUpdField GhcPs]
fs)
    HsExpr GhcPs
_ -> () -> Transform ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
moveTrailingComments :: Located a -> Located b -> Transform ()
moveTrailingComments Located a
astFrom Located b
astTo = do
  let
    k1 :: AnnKey
k1 = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey Located a
astFrom
    k2 :: AnnKey
k2 = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey Located b
astTo
    moveComments :: Anns -> Anns
moveComments Anns
ans = Anns
ans'
      where
        an1 :: Annotation
an1 = Maybe Annotation -> Annotation
forall a. HasCallStack => Maybe a -> a
Data.Maybe.fromJust (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k1 Anns
ans
        an2 :: Annotation
an2 = Maybe Annotation -> Annotation
forall a. HasCallStack => Maybe a -> a
Data.Maybe.fromJust (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k2 Anns
ans
        cs1f :: [(Comment, DeltaPos)]
cs1f = Annotation -> [(Comment, DeltaPos)]
ExactPrint.annFollowingComments Annotation
an1
        cs2f :: [(Comment, DeltaPos)]
cs2f = Annotation -> [(Comment, DeltaPos)]
ExactPrint.annFollowingComments Annotation
an2
        ([(Comment, DeltaPos)]
comments, [(KeywordId, DeltaPos)]
nonComments) = (((KeywordId, DeltaPos)
  -> Either (Comment, DeltaPos) (KeywordId, DeltaPos))
 -> [(KeywordId, DeltaPos)]
 -> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)]))
-> [(KeywordId, DeltaPos)]
-> ((KeywordId, DeltaPos)
    -> Either (Comment, DeltaPos) (KeywordId, DeltaPos))
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((KeywordId, DeltaPos)
 -> Either (Comment, DeltaPos) (KeywordId, DeltaPos))
-> [(KeywordId, DeltaPos)]
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
breakEither (Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.annsDP Annotation
an1)
             (((KeywordId, DeltaPos)
  -> Either (Comment, DeltaPos) (KeywordId, DeltaPos))
 -> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)]))
-> ((KeywordId, DeltaPos)
    -> Either (Comment, DeltaPos) (KeywordId, DeltaPos))
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b. (a -> b) -> a -> b
$ \case
               (ExactPrint.AnnComment Comment
com, DeltaPos
dp) -> (Comment, DeltaPos)
-> Either (Comment, DeltaPos) (KeywordId, DeltaPos)
forall a b. a -> Either a b
Left (Comment
com, DeltaPos
dp)
               (KeywordId, DeltaPos)
x -> (KeywordId, DeltaPos)
-> Either (Comment, DeltaPos) (KeywordId, DeltaPos)
forall a b. b -> Either a b
Right (KeywordId, DeltaPos)
x
        an1' :: Annotation
an1' = Annotation
an1
          { annsDP :: [(KeywordId, DeltaPos)]
ExactPrint.annsDP               = [(KeywordId, DeltaPos)]
nonComments
          , annFollowingComments :: [(Comment, DeltaPos)]
ExactPrint.annFollowingComments = []
          }
        an2' :: Annotation
an2' = Annotation
an2
          { annFollowingComments :: [(Comment, DeltaPos)]
ExactPrint.annFollowingComments = [(Comment, DeltaPos)]
cs1f [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment, DeltaPos)]
cs2f [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment, DeltaPos)]
comments
          }
        ans' :: Anns
ans' = AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k1 Annotation
an1' (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k2 Annotation
an2' Anns
ans

  (Anns -> Anns) -> Transform ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
ExactPrint.modifyAnnsT Anns -> Anns
moveComments

-- | split a set of annotations in a module into a map from top-level module
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have.
extractToplevelAnns
  :: Located (HsModule GhcPs)
  -> ExactPrint.Anns
  -> Map ExactPrint.AnnKey ExactPrint.Anns
extractToplevelAnns :: ParsedSource -> Anns -> Map AnnKey Anns
extractToplevelAnns ParsedSource
lmod Anns
anns = Map AnnKey Anns
output
 where
  (L SrcSpan
_ (HsModule Maybe (Located ModuleName)
_ Maybe (Located [LIE GhcPs])
_ [LImportDecl GhcPs]
_ [LHsDecl GhcPs]
ldecls Maybe (Located WarningTxt)
_ Maybe LHsDocString
_)) = ParsedSource
lmod
  declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
  declMap1 :: Map AnnKey AnnKey
declMap1 = [Map AnnKey AnnKey] -> Map AnnKey AnnKey
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map AnnKey AnnKey] -> Map AnnKey AnnKey)
-> [Map AnnKey AnnKey] -> Map AnnKey AnnKey
forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs]
ldecls [LHsDecl GhcPs]
-> (LHsDecl GhcPs -> Map AnnKey AnnKey) -> [Map AnnKey AnnKey]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \LHsDecl GhcPs
ldecl ->
    (AnnKey -> AnnKey) -> Set AnnKey -> Map AnnKey AnnKey
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (AnnKey -> AnnKey -> AnnKey
forall a b. a -> b -> a
const (LHsDecl GhcPs -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey LHsDecl GhcPs
ldecl)) (LHsDecl GhcPs -> Set AnnKey
forall ast. Data ast => ast -> Set AnnKey
foldedAnnKeys LHsDecl GhcPs
ldecl)
  declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
  declMap2 :: Map AnnKey AnnKey
declMap2 =
    [(AnnKey, AnnKey)] -> Map AnnKey AnnKey
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      ([(AnnKey, AnnKey)] -> Map AnnKey AnnKey)
-> [(AnnKey, AnnKey)] -> Map AnnKey AnnKey
forall a b. (a -> b) -> a -> b
$ [ (AnnKey
captured, Map AnnKey AnnKey
declMap1 Map AnnKey AnnKey -> AnnKey -> AnnKey
forall k a. Ord k => Map k a -> k -> a
Map.! AnnKey
k)
        | (AnnKey
k, ExactPrint.Ann DeltaPos
_ [(Comment, DeltaPos)]
_ [(Comment, DeltaPos)]
_ [(KeywordId, DeltaPos)]
_ Maybe [SrcSpan]
_ (Just AnnKey
captured)) <- Anns -> [(AnnKey, Annotation)]
forall k a. Map k a -> [(k, a)]
Map.toList Anns
anns
        ]
  declMap :: Map AnnKey AnnKey
declMap = Map AnnKey AnnKey
declMap1 Map AnnKey AnnKey -> Map AnnKey AnnKey -> Map AnnKey AnnKey
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map AnnKey AnnKey
declMap2
  modKey :: AnnKey
modKey  = ParsedSource -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey ParsedSource
lmod
  output :: Map AnnKey Anns
output  = (AnnKey -> Annotation -> AnnKey) -> Anns -> Map AnnKey Anns
forall k l a.
(Ord k, Ord l) =>
(k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap (\AnnKey
k Annotation
_ -> AnnKey -> AnnKey -> Map AnnKey AnnKey -> AnnKey
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault AnnKey
modKey AnnKey
k Map AnnKey AnnKey
declMap) Anns
anns

groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap :: (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap k -> a -> l
f = (Map l (Map k a) -> k -> a -> Map l (Map k a))
-> Map l (Map k a) -> Map k a -> Map l (Map k a)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Map l (Map k a)
m k
k a
a -> (Maybe (Map k a) -> Maybe (Map k a))
-> l -> Map l (Map k a) -> Map l (Map k a)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (k -> a -> Maybe (Map k a) -> Maybe (Map k a)
forall k a. Ord k => k -> a -> Maybe (Map k a) -> Maybe (Map k a)
insert k
k a
a) (k -> a -> l
f k
k a
a) Map l (Map k a)
m)
                               Map l (Map k a)
forall k a. Map k a
Map.empty
 where
  insert :: k -> a -> Maybe (Map k a) -> Maybe (Map k a)
insert k
k a
a Maybe (Map k a)
Nothing  = Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (k -> a -> Map k a
forall k a. k -> a -> Map k a
Map.singleton k
k a
a)
  insert k
k a
a (Just Map k a
m) = Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
a Map k a
m)

foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys :: ast -> Set AnnKey
foldedAnnKeys ast
ast = (Set AnnKey -> Set AnnKey -> Set AnnKey)
-> (forall ast. Data ast => ast -> Set AnnKey) -> ast -> Set AnnKey
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything
  Set AnnKey -> Set AnnKey -> Set AnnKey
forall a. Ord a => Set a -> Set a -> Set a
Set.union
  ( \a
x -> Set AnnKey -> (AnnKey -> Set AnnKey) -> Maybe AnnKey -> Set AnnKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    Set AnnKey
forall a. Set a
Set.empty
    AnnKey -> Set AnnKey
forall a. a -> Set a
Set.singleton
    [ Int -> (forall d. Data d => d -> AnnKey) -> a -> AnnKey
forall a u. Data a => Int -> (forall d. Data d => d -> u) -> a -> u
SYB.gmapQi Int
1 (\d
t -> GenLocated SrcSpan d -> AnnKey
forall a. Constraints a => a -> AnnKey
ExactPrint.mkAnnKey (GenLocated SrcSpan d -> AnnKey) -> GenLocated SrcSpan d -> AnnKey
forall a b. (a -> b) -> a -> b
$ SrcSpan -> d -> GenLocated SrcSpan d
forall l e. l -> e -> GenLocated l e
L SrcSpan
l d
t) a
x
    | TyCon
locTyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
SYB.typeRepTyCon (a -> TypeRep
forall a. Typeable a => a -> TypeRep
SYB.typeOf a
x)
    , SrcSpan
l :: SrcSpan <- Int
-> (forall d. Data d => d -> Maybe SrcSpan) -> a -> Maybe SrcSpan
forall a u. Data a => Int -> (forall d. Data d => d -> u) -> a -> u
SYB.gmapQi Int
0 forall d. Data d => d -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
SYB.cast a
x
      -- for some reason, ghc-8.8 has forgotten how to infer the type of l,
      -- even though it is passed to mkAnnKey above, which only accepts
      -- SrcSpan.
    ]
  )
  ast
ast
  where locTyCon :: TyCon
locTyCon = TypeRep -> TyCon
SYB.typeRepTyCon (GenLocated () () -> TypeRep
forall a. Typeable a => a -> TypeRep
SYB.typeOf (() -> () -> GenLocated () ()
forall l e. l -> e -> GenLocated l e
L () ()))


withTransformedAnns
  :: Data ast
  => ast
  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
withTransformedAnns :: ast
-> MultiRWS '[Config, Anns] w s a -> MultiRWS '[Config, Anns] w s a
withTransformedAnns ast
ast MultiRWS '[Config, Anns] w s a
m = MultiRWST '[Config, Anns] w s Identity (HList '[Config, Anns])
forall (m :: * -> *) (r :: [*]) (w :: [*]) (s :: [*]).
Monad m =>
MultiRWST r w s m (HList r)
MultiRWSS.mGetRawR MultiRWST '[Config, Anns] w s Identity (HList '[Config, Anns])
-> (HList '[Config, Anns] -> MultiRWS '[Config, Anns] w s a)
-> MultiRWS '[Config, Anns] w s a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  readers :: HList '[Config, Anns]
readers@(x
conf :+: x
anns :+: HList xs
HNil) -> do
    -- TODO: implement `local` for MultiReader/MultiRWS
    HList '[x, Anns] -> MultiRWST '[x, Anns] w s Identity ()
forall (m :: * -> *) (r :: [*]) (w :: [*]) (s :: [*]).
Monad m =>
HList r -> MultiRWST r w s m ()
MultiRWSS.mPutRawR (x
conf x -> HList '[Anns] -> HList '[x, Anns]
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
:+: Anns -> Anns
f x
Anns
anns Anns -> HList '[] -> HList '[Anns]
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
:+: HList '[]
HNil)
    a
x <- MultiRWS '[Config, Anns] w s a
m
    HList '[Config, Anns] -> MultiRWST '[Config, Anns] w s Identity ()
forall (m :: * -> *) (r :: [*]) (w :: [*]) (s :: [*]).
Monad m =>
HList r -> MultiRWST r w s m ()
MultiRWSS.mPutRawR HList '[Config, Anns]
readers
    a -> MultiRWS '[Config, Anns] w s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
 where
  f :: Anns -> Anns
f Anns
anns =
    let ((), (Anns
annsBalanced, Int
_), [String]
_) =
          Anns -> Transform () -> ((), (Anns, Int), [String])
forall a. Anns -> Transform a -> (a, (Anns, Int), [String])
ExactPrint.runTransform Anns
anns (ast -> Transform ()
GenericQ (Transform ())
commentAnnFixTransformGlob ast
ast)
    in  Anns
annsBalanced


warnExtractorCompat :: GHC.Warn -> String
warnExtractorCompat :: Warn -> String
warnExtractorCompat (GHC.Warn WarnReason
_ (L SrcSpan
_ String
s)) = String
s