{-# LANGUAGE DataKinds #-}
module Language.Haskell.Brittany.Internal.ExactPrintUtils
( parseModule
, parseModuleFromString
, 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
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
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))
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 =
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 ()
ast
ast = do
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract :: a -> Seq (SrcSpan, AnnKey)
extract =
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
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
[(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 ()
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 ()
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
extractToplevelAnns
:: Located (HsModule GhcPs)
-> ExactPrint.Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns
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
]
)
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
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
(GHC.Warn WarnReason
_ (L SrcSpan
_ String
s)) = String
s