module Evoke
( plugin
) where
import qualified Control.Monad as Monad
import qualified Control.Monad.IO.Class as IO
import qualified Data.Bifunctor as Bifunctor
import qualified Data.Maybe as Maybe
import qualified Data.Version as Version
import qualified Evoke.Generator.Arbitrary as Arbitrary
import qualified Evoke.Generator.Common as Common
import qualified Evoke.Generator.FromJSON as FromJSON
import qualified Evoke.Generator.ToJSON as ToJSON
import qualified Evoke.Generator.ToSchema as ToSchema
import qualified Evoke.Hsc as Hsc
import qualified Evoke.Options as Options
import qualified Evoke.Type.Config as Config
import qualified Evoke.Type.Flag as Flag
import qualified GHC.Hs as Ghc
import qualified GhcPlugins as Ghc
import qualified Paths_evoke as This
import qualified System.Console.GetOpt as Console
plugin :: Ghc.Plugin
plugin :: Plugin
plugin = Plugin
Ghc.defaultPlugin
{ parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
Ghc.parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
Ghc.pluginRecompile = [CommandLineOption] -> IO PluginRecompile
Ghc.purePlugin
}
parsedResultAction
:: [Ghc.CommandLineOption]
-> Ghc.ModSummary
-> Ghc.HsParsedModule
-> Ghc.Hsc Ghc.HsParsedModule
parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction [CommandLineOption]
commandLineOptions ModSummary
modSummary HsParsedModule
hsParsedModule = do
let
lHsModule1 :: Located (HsModule GhcPs)
lHsModule1 = HsParsedModule -> Located (HsModule GhcPs)
Ghc.hpm_module HsParsedModule
hsParsedModule
srcSpan :: SrcSpan
srcSpan = Located (HsModule GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
Ghc.getLoc Located (HsModule GhcPs)
lHsModule1
[Flag]
flags <- [OptDescr Flag] -> [CommandLineOption] -> SrcSpan -> Hsc [Flag]
forall a. [OptDescr a] -> [CommandLineOption] -> SrcSpan -> Hsc [a]
Options.parse [OptDescr Flag]
Flag.options [CommandLineOption]
commandLineOptions SrcSpan
srcSpan
let config :: Config
config = [Flag] -> Config
forall (t :: * -> *). Foldable t => t Flag -> Config
Config.fromFlags [Flag]
flags
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Config -> Bool
Config.help Config
config)
(Hsc () -> Hsc ())
-> (CommandLineOption -> Hsc ()) -> CommandLineOption -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> MsgDoc -> Hsc ()
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
(MsgDoc -> Hsc ())
-> (CommandLineOption -> MsgDoc) -> CommandLineOption -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgDoc] -> MsgDoc
Ghc.vcat
([MsgDoc] -> MsgDoc)
-> (CommandLineOption -> [MsgDoc]) -> CommandLineOption -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommandLineOption -> MsgDoc) -> [CommandLineOption] -> [MsgDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommandLineOption -> MsgDoc
Ghc.text
([CommandLineOption] -> [MsgDoc])
-> (CommandLineOption -> [CommandLineOption])
-> CommandLineOption
-> [MsgDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> [CommandLineOption]
lines
(CommandLineOption -> Hsc ()) -> CommandLineOption -> Hsc ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> [OptDescr Flag] -> CommandLineOption
forall a. CommandLineOption -> [OptDescr a] -> CommandLineOption
Console.usageInfo (CommandLineOption
"Evoke version " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. Semigroup a => a -> a -> a
<> CommandLineOption
version) [OptDescr Flag]
Flag.options
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Config -> Bool
Config.version Config
config) (Hsc () -> Hsc ()) -> (MsgDoc -> Hsc ()) -> MsgDoc -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> MsgDoc -> Hsc ()
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc ()) -> MsgDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> MsgDoc
Ghc.text
CommandLineOption
version
let moduleName :: ModuleName
moduleName = Module -> ModuleName
Ghc.moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
Ghc.ms_mod ModSummary
modSummary
Located (HsModule GhcPs)
lHsModule2 <- Config
-> ModuleName
-> Located (HsModule GhcPs)
-> Hsc (Located (HsModule GhcPs))
handleLHsModule Config
config ModuleName
moduleName Located (HsModule GhcPs)
lHsModule1
HsParsedModule -> Hsc HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsParsedModule
hsParsedModule { hpm_module :: Located (HsModule GhcPs)
Ghc.hpm_module = Located (HsModule GhcPs)
lHsModule2 }
version :: String
version :: CommandLineOption
version = Version -> CommandLineOption
Version.showVersion Version
This.version
handleLHsModule
:: Config.Config
-> Ghc.ModuleName
-> LHsModule Ghc.GhcPs
-> Ghc.Hsc (LHsModule Ghc.GhcPs)
handleLHsModule :: Config
-> ModuleName
-> Located (HsModule GhcPs)
-> Hsc (Located (HsModule GhcPs))
handleLHsModule Config
config ModuleName
moduleName Located (HsModule GhcPs)
lHsModule = do
HsModule GhcPs
hsModule <- Config -> ModuleName -> HsModule GhcPs -> Hsc (HsModule GhcPs)
handleHsModule Config
config ModuleName
moduleName (HsModule GhcPs -> Hsc (HsModule GhcPs))
-> HsModule GhcPs -> Hsc (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> SrcSpanLess (Located (HsModule GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located (HsModule GhcPs)
lHsModule
Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs)))
-> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ (HsModule GhcPs -> HsModule GhcPs)
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
Ghc.mapLoc (HsModule GhcPs -> HsModule GhcPs -> HsModule GhcPs
forall a b. a -> b -> a
const HsModule GhcPs
hsModule) Located (HsModule GhcPs)
lHsModule
type LHsModule pass = Ghc.Located (Ghc.HsModule pass)
handleHsModule
:: Config.Config
-> Ghc.ModuleName
-> Ghc.HsModule Ghc.GhcPs
-> Ghc.Hsc (Ghc.HsModule Ghc.GhcPs)
handleHsModule :: Config -> ModuleName -> HsModule GhcPs -> Hsc (HsModule GhcPs)
handleHsModule Config
config ModuleName
moduleName HsModule GhcPs
hsModule = do
([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls) <- Config
-> ModuleName
-> [LHsDecl GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsDecls Config
config ModuleName
moduleName
([LHsDecl GhcPs] -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> [LHsDecl GhcPs] -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
Ghc.hsmodDecls HsModule GhcPs
hsModule
HsModule GhcPs -> Hsc (HsModule GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsModule GhcPs
hsModule
{ hsmodImports :: [LImportDecl GhcPs]
Ghc.hsmodImports = HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
Ghc.hsmodImports HsModule GhcPs
hsModule [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. Semigroup a => a -> a -> a
<> [LImportDecl GhcPs]
lImportDecls
, hsmodDecls :: [LHsDecl GhcPs]
Ghc.hsmodDecls = [LHsDecl GhcPs]
lHsDecls
}
handleLHsDecls
:: Config.Config
-> Ghc.ModuleName
-> [Ghc.LHsDecl Ghc.GhcPs]
-> Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
handleLHsDecls :: Config
-> ModuleName
-> [LHsDecl GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsDecls Config
config ModuleName
moduleName [LHsDecl GhcPs]
lHsDecls = do
[([LImportDecl GhcPs], [LHsDecl GhcPs])]
tuples <- (LHsDecl GhcPs -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> [LHsDecl GhcPs] -> Hsc [([LImportDecl GhcPs], [LHsDecl GhcPs])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Config
-> ModuleName
-> LHsDecl GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsDecl Config
config ModuleName
moduleName) [LHsDecl GhcPs]
lHsDecls
([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> (([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[LImportDecl GhcPs]] -> [LImportDecl GhcPs])
-> ([[LHsDecl GhcPs]] -> [LHsDecl GhcPs])
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap [[LImportDecl GhcPs]] -> [LImportDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat [[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat (([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ [([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([LImportDecl GhcPs], [LHsDecl GhcPs])]
tuples
handleLHsDecl
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LHsDecl Ghc.GhcPs
-> Ghc.Hsc ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
handleLHsDecl :: Config
-> ModuleName
-> LHsDecl GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsDecl Config
config ModuleName
moduleName LHsDecl GhcPs
lHsDecl = case LHsDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsDecl GhcPs
lHsDecl of
Ghc.TyClD xTyClD tyClDecl1 -> do
(TyClDecl GhcPs
tyClDecl2, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)) <- Config
-> ModuleName
-> TyClDecl GhcPs
-> Hsc (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleTyClDecl
Config
config
ModuleName
moduleName
TyClDecl GhcPs
tyClDecl1
([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [LImportDecl GhcPs]
lImportDecls
, (HsDecl GhcPs -> HsDecl GhcPs) -> LHsDecl GhcPs -> LHsDecl GhcPs
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
Ghc.mapLoc (HsDecl GhcPs -> HsDecl GhcPs -> HsDecl GhcPs
forall a b. a -> b -> a
const (HsDecl GhcPs -> HsDecl GhcPs -> HsDecl GhcPs)
-> HsDecl GhcPs -> HsDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
Ghc.TyClD XTyClD GhcPs
xTyClD TyClDecl GhcPs
tyClDecl2) LHsDecl GhcPs
lHsDecl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
lHsDecls
)
SrcSpanLess (LHsDecl GhcPs)
_ -> ([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [LHsDecl GhcPs
lHsDecl])
handleTyClDecl
:: Config.Config
-> Ghc.ModuleName
-> Ghc.TyClDecl Ghc.GhcPs
-> Ghc.Hsc
( Ghc.TyClDecl Ghc.GhcPs
, ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
)
handleTyClDecl :: Config
-> ModuleName
-> TyClDecl GhcPs
-> Hsc (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleTyClDecl Config
config ModuleName
moduleName TyClDecl GhcPs
tyClDecl = case TyClDecl GhcPs
tyClDecl of
Ghc.DataDecl XDataDecl GhcPs
tcdDExt Located (IdP GhcPs)
tcdLName LHsQTyVars GhcPs
tcdTyVars LexicalFixity
tcdFixity HsDataDefn GhcPs
tcdDataDefn -> do
(HsDataDefn GhcPs
hsDataDefn, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)) <- Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDataDefn
Config
config
ModuleName
moduleName
Located (IdP GhcPs)
tcdLName
LHsQTyVars GhcPs
tcdTyVars
HsDataDefn GhcPs
tcdDataDefn
(TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( XDataDecl GhcPs
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> HsDataDefn GhcPs
-> TyClDecl GhcPs
forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
Ghc.DataDecl XDataDecl GhcPs
tcdDExt Located (IdP GhcPs)
tcdLName LHsQTyVars GhcPs
tcdTyVars LexicalFixity
tcdFixity HsDataDefn GhcPs
hsDataDefn
, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)
)
TyClDecl GhcPs
_ -> (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyClDecl GhcPs
tyClDecl, ([], []))
handleHsDataDefn
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> Ghc.HsDataDefn Ghc.GhcPs
-> Ghc.Hsc
( Ghc.HsDataDefn Ghc.GhcPs
, ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])
)
handleHsDataDefn :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDataDefn Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars HsDataDefn GhcPs
hsDataDefn =
case HsDataDefn GhcPs
hsDataDefn of
Ghc.HsDataDefn XCHsDataDefn GhcPs
dd_ext NewOrData
dd_ND LHsContext GhcPs
dd_ctxt Maybe (Located CType)
dd_cType Maybe (LHsKind GhcPs)
dd_kindSig [LConDecl GhcPs]
dd_cons HsDeriving GhcPs
dd_derivs
-> do
(HsDeriving GhcPs
hsDeriving, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)) <- Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDeriving
Config
config
ModuleName
moduleName
Located (IdP GhcPs)
lIdP
LHsQTyVars GhcPs
lHsQTyVars
[LConDecl GhcPs]
dd_cons
HsDeriving GhcPs
dd_derivs
(HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( XCHsDataDefn GhcPs
-> NewOrData
-> LHsContext GhcPs
-> Maybe (Located CType)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> HsDataDefn GhcPs
forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
Ghc.HsDataDefn
XCHsDataDefn GhcPs
dd_ext
NewOrData
dd_ND
LHsContext GhcPs
dd_ctxt
Maybe (Located CType)
dd_cType
Maybe (LHsKind GhcPs)
dd_kindSig
[LConDecl GhcPs]
dd_cons
HsDeriving GhcPs
hsDeriving
, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)
)
HsDataDefn GhcPs
_ -> (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDataDefn GhcPs
hsDataDefn, ([], []))
handleHsDeriving
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> [Ghc.LConDecl Ghc.GhcPs]
-> Ghc.HsDeriving Ghc.GhcPs
-> Ghc.Hsc
( Ghc.HsDeriving Ghc.GhcPs
, ( [Ghc.LImportDecl Ghc.GhcPs]
, [Ghc.LHsDecl Ghc.GhcPs]
)
)
handleHsDeriving :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDeriving Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls HsDeriving GhcPs
hsDeriving = do
([LHsDerivingClause GhcPs]
lHsDerivingClauses, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)) <-
Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClauses Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls
([LHsDerivingClause GhcPs]
-> Hsc
([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs])))
-> [LHsDerivingClause GhcPs]
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall a b. (a -> b) -> a -> b
$ HsDeriving GhcPs -> SrcSpanLess (HsDeriving GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc HsDeriving GhcPs
hsDeriving
(HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( ([LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs])
-> HsDeriving GhcPs -> HsDeriving GhcPs
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
Ghc.mapLoc ([LHsDerivingClause GhcPs]
-> [LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs]
forall a b. a -> b -> a
const [LHsDerivingClause GhcPs]
lHsDerivingClauses) HsDeriving GhcPs
hsDeriving
, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)
)
handleLHsDerivingClauses
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> [Ghc.LConDecl Ghc.GhcPs]
-> [Ghc.LHsDerivingClause Ghc.GhcPs]
-> Ghc.Hsc
( [Ghc.LHsDerivingClause Ghc.GhcPs]
, ( [Ghc.LImportDecl Ghc.GhcPs]
, [Ghc.LHsDecl Ghc.GhcPs]
)
)
handleLHsDerivingClauses :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClauses Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [LHsDerivingClause GhcPs]
lHsDerivingClauses
= do
[(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))]
tuples <- (LHsDerivingClause GhcPs
-> Hsc
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs])))
-> [LHsDerivingClause GhcPs]
-> Hsc
[(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> LHsDerivingClause GhcPs
-> Hsc
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClause Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls)
[LHsDerivingClause GhcPs]
lHsDerivingClauses
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc
([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs])))
-> (([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
-> ([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs])))
-> ([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe (LHsDerivingClause GhcPs)] -> [LHsDerivingClause GhcPs])
-> ([([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
-> ([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap
[Maybe (LHsDerivingClause GhcPs)] -> [LHsDerivingClause GhcPs]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
(([[LImportDecl GhcPs]] -> [LImportDecl GhcPs])
-> ([[LHsDecl GhcPs]] -> [LHsDecl GhcPs])
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap [[LImportDecl GhcPs]] -> [LImportDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat [[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat (([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]]))
-> [([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
forall a b. [(a, b)] -> ([a], [b])
unzip)
(([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
-> Hsc
([LHsDerivingClause GhcPs],
([LImportDecl GhcPs], [LHsDecl GhcPs])))
-> ([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
-> Hsc
([LHsDerivingClause GhcPs], ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall a b. (a -> b) -> a -> b
$ [(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))]
-> ([Maybe (LHsDerivingClause GhcPs)],
[([LImportDecl GhcPs], [LHsDecl GhcPs])])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))]
tuples
handleLHsDerivingClause
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> [Ghc.LConDecl Ghc.GhcPs]
-> Ghc.LHsDerivingClause Ghc.GhcPs
-> Ghc.Hsc
( Maybe (Ghc.LHsDerivingClause Ghc.GhcPs)
, ( [Ghc.LImportDecl Ghc.GhcPs]
, [Ghc.LHsDecl Ghc.GhcPs]
)
)
handleLHsDerivingClause :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> LHsDerivingClause GhcPs
-> Hsc
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClause Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls LHsDerivingClause GhcPs
lHsDerivingClause
= case LHsDerivingClause GhcPs -> SrcSpanLess (LHsDerivingClause GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsDerivingClause GhcPs
lHsDerivingClause of
Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys
| Just [CommandLineOption]
options <- Maybe (LDerivStrategy GhcPs) -> Maybe [CommandLineOption]
parseDerivingStrategy Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy -> do
([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls) <-
Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> [LHsSigType GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigTypes Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [CommandLineOption]
options
([LHsSigType GhcPs] -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> [LHsSigType GhcPs] -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ Located [LHsSigType GhcPs]
-> SrcSpanLess (Located [LHsSigType GhcPs])
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located [LHsSigType GhcPs]
deriv_clause_tys
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LHsDerivingClause GhcPs)
forall a. Maybe a
Nothing, ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls))
SrcSpanLess (LHsDerivingClause GhcPs)
_ -> (Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> Hsc
(Maybe (LHsDerivingClause GhcPs),
([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsDerivingClause GhcPs -> Maybe (LHsDerivingClause GhcPs)
forall a. a -> Maybe a
Just LHsDerivingClause GhcPs
lHsDerivingClause, ([], []))
parseDerivingStrategy
:: Maybe (Ghc.LDerivStrategy Ghc.GhcPs) -> Maybe [String]
parseDerivingStrategy :: Maybe (LDerivStrategy GhcPs) -> Maybe [CommandLineOption]
parseDerivingStrategy Maybe (LDerivStrategy GhcPs)
mLDerivStrategy = do
LDerivStrategy GhcPs
lDerivStrategy <- Maybe (LDerivStrategy GhcPs)
mLDerivStrategy
LHsSigType GhcPs
lHsSigType <- case LDerivStrategy GhcPs -> SrcSpanLess (LDerivStrategy GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LDerivStrategy GhcPs
lDerivStrategy of
Ghc.ViaStrategy x -> LHsSigType GhcPs -> Maybe (LHsSigType GhcPs)
forall a. a -> Maybe a
Just LHsSigType GhcPs
XViaStrategy GhcPs
x
SrcSpanLess (LDerivStrategy GhcPs)
_ -> Maybe (LHsSigType GhcPs)
forall a. Maybe a
Nothing
LHsKind GhcPs
lHsType <- case LHsSigType GhcPs
lHsSigType of
Ghc.HsIB XHsIB GhcPs (LHsKind GhcPs)
_ LHsKind GhcPs
x -> LHsKind GhcPs -> Maybe (LHsKind GhcPs)
forall a. a -> Maybe a
Just LHsKind GhcPs
x
LHsSigType GhcPs
_ -> Maybe (LHsKind GhcPs)
forall a. Maybe a
Nothing
HsTyLit
hsTyLit <- case LHsKind GhcPs -> SrcSpanLess (LHsKind GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsKind GhcPs
lHsType of
Ghc.HsTyLit _ x -> HsTyLit -> Maybe HsTyLit
forall a. a -> Maybe a
Just HsTyLit
x
SrcSpanLess (LHsKind GhcPs)
_ -> Maybe HsTyLit
forall a. Maybe a
Nothing
FastString
fastString <- case HsTyLit
hsTyLit of
Ghc.HsStrTy SourceText
_ FastString
x -> FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
x
HsTyLit
_ -> Maybe FastString
forall a. Maybe a
Nothing
case CommandLineOption -> [CommandLineOption]
words (CommandLineOption -> [CommandLineOption])
-> CommandLineOption -> [CommandLineOption]
forall a b. (a -> b) -> a -> b
$ FastString -> CommandLineOption
Ghc.unpackFS FastString
fastString of
CommandLineOption
"Evoke" : [CommandLineOption]
x -> [CommandLineOption] -> Maybe [CommandLineOption]
forall a. a -> Maybe a
Just [CommandLineOption]
x
[CommandLineOption]
_ -> Maybe [CommandLineOption]
forall a. Maybe a
Nothing
handleLHsSigTypes
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> [Ghc.LConDecl Ghc.GhcPs]
-> [String]
-> [Ghc.LHsSigType Ghc.GhcPs]
-> Ghc.Hsc
( [Ghc.LImportDecl Ghc.GhcPs]
, [Ghc.LHsDecl Ghc.GhcPs]
)
handleLHsSigTypes :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> [LHsSigType GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigTypes Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [CommandLineOption]
options [LHsSigType GhcPs]
lHsSigTypes
= do
[([LImportDecl GhcPs], [LHsDecl GhcPs])]
tuples <- (LHsSigType GhcPs -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> [LHsSigType GhcPs]
-> Hsc [([LImportDecl GhcPs], [LHsDecl GhcPs])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> LHsSigType GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigType Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [CommandLineOption]
options)
[LHsSigType GhcPs]
lHsSigTypes
([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> (([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[LImportDecl GhcPs]] -> [LImportDecl GhcPs])
-> ([[LHsDecl GhcPs]] -> [LHsDecl GhcPs])
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap [[LImportDecl GhcPs]] -> [LImportDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat [[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall a. Monoid a => [a] -> a
mconcat (([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ [([LImportDecl GhcPs], [LHsDecl GhcPs])]
-> ([[LImportDecl GhcPs]], [[LHsDecl GhcPs]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([LImportDecl GhcPs], [LHsDecl GhcPs])]
tuples
handleLHsSigType
:: Config.Config
-> Ghc.ModuleName
-> Ghc.LIdP Ghc.GhcPs
-> Ghc.LHsQTyVars Ghc.GhcPs
-> [Ghc.LConDecl Ghc.GhcPs]
-> [String]
-> Ghc.LHsSigType Ghc.GhcPs
-> Ghc.Hsc
( [Ghc.LImportDecl Ghc.GhcPs]
, [Ghc.LHsDecl Ghc.GhcPs]
)
handleLHsSigType :: Config
-> ModuleName
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> LHsSigType GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigType Config
config ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [CommandLineOption]
options LHsSigType GhcPs
lHsSigType
= do
let
srcSpan :: SrcSpan
srcSpan = case LHsSigType GhcPs
lHsSigType of
Ghc.HsIB XHsIB GhcPs (LHsKind GhcPs)
_ LHsKind GhcPs
x -> LHsKind GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
Ghc.getLoc LHsKind GhcPs
x
LHsSigType GhcPs
_ -> Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
Ghc.getLoc Located (IdP GhcPs)
Located RdrName
lIdP
([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls) <- case LHsSigType GhcPs -> Maybe Generator
getGenerator LHsSigType GhcPs
lHsSigType of
Just Generator
generate ->
Generator
generate ModuleName
moduleName Located (IdP GhcPs)
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [CommandLineOption]
options SrcSpan
srcSpan
Maybe Generator
Nothing -> SrcSpan -> MsgDoc -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
-> MsgDoc -> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> MsgDoc
Ghc.text CommandLineOption
"unsupported type class"
Bool
verbose <- Config -> Hsc Bool
isVerbose Config
config
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when Bool
verbose (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dynFlags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
Ghc.getDynFlags
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
CommandLineOption -> IO ()
putStrLn (CommandLineOption -> IO ()) -> CommandLineOption -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> CommandLineOption
forall a. Int -> a -> [a]
replicate Int
80 Char
'-'
(LImportDecl GhcPs -> IO ()) -> [LImportDecl GhcPs] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandLineOption -> IO ()
putStrLn (CommandLineOption -> IO ())
-> (LImportDecl GhcPs -> CommandLineOption)
-> LImportDecl GhcPs
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> MsgDoc -> CommandLineOption
Ghc.showSDocDump DynFlags
dynFlags (MsgDoc -> CommandLineOption)
-> (LImportDecl GhcPs -> MsgDoc)
-> LImportDecl GhcPs
-> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
Ghc.ppr) [LImportDecl GhcPs]
lImportDecls
(LHsDecl GhcPs -> IO ()) -> [LHsDecl GhcPs] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandLineOption -> IO ()
putStrLn (CommandLineOption -> IO ())
-> (LHsDecl GhcPs -> CommandLineOption) -> LHsDecl GhcPs -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> MsgDoc -> CommandLineOption
Ghc.showSDocDump DynFlags
dynFlags (MsgDoc -> CommandLineOption)
-> (LHsDecl GhcPs -> MsgDoc) -> LHsDecl GhcPs -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDecl GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
Ghc.ppr) [LHsDecl GhcPs]
lHsDecls
([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs]
lHsDecls)
isVerbose :: Config.Config -> Ghc.Hsc Bool
isVerbose :: Config -> Hsc Bool
isVerbose Config
config = do
DynFlags
dynFlags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
Ghc.getDynFlags
Bool -> Hsc Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Hsc Bool) -> Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
Config.verbose Config
config Bool -> Bool -> Bool
|| DumpFlag -> DynFlags -> Bool
Ghc.dopt DumpFlag
Ghc.Opt_D_dump_deriv DynFlags
dynFlags
getGenerator :: Ghc.LHsSigType Ghc.GhcPs -> Maybe Common.Generator
getGenerator :: LHsSigType GhcPs -> Maybe Generator
getGenerator LHsSigType GhcPs
lHsSigType = do
CommandLineOption
className <- LHsSigType GhcPs -> Maybe CommandLineOption
getClassName LHsSigType GhcPs
lHsSigType
CommandLineOption
-> [(CommandLineOption,
ModuleName
-> Located RdrName
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> SrcSpan
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))]
-> Maybe
(ModuleName
-> Located RdrName
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> SrcSpan
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CommandLineOption
className [(CommandLineOption, Generator)]
[(CommandLineOption,
ModuleName
-> Located RdrName
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [CommandLineOption]
-> SrcSpan
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs]))]
generators
generators :: [(String, Common.Generator)]
generators :: [(CommandLineOption, Generator)]
generators =
[ (CommandLineOption
"Arbitrary", Generator
Arbitrary.generate)
, (CommandLineOption
"FromJSON", Generator
FromJSON.generate)
, (CommandLineOption
"ToJSON", Generator
ToJSON.generate)
, (CommandLineOption
"ToSchema", Generator
ToSchema.generate)
]
getClassName :: Ghc.LHsSigType Ghc.GhcPs -> Maybe String
getClassName :: LHsSigType GhcPs -> Maybe CommandLineOption
getClassName LHsSigType GhcPs
lHsSigType = do
LHsKind GhcPs
lHsType <- case LHsSigType GhcPs
lHsSigType of
Ghc.HsIB XHsIB GhcPs (LHsKind GhcPs)
_ LHsKind GhcPs
x -> LHsKind GhcPs -> Maybe (LHsKind GhcPs)
forall a. a -> Maybe a
Just LHsKind GhcPs
x
LHsSigType GhcPs
_ -> Maybe (LHsKind GhcPs)
forall a. Maybe a
Nothing
Located RdrName
lIdP <- case LHsKind GhcPs -> SrcSpanLess (LHsKind GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsKind GhcPs
lHsType of
Ghc.HsTyVar _ _ x -> Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just Located (IdP GhcPs)
Located RdrName
x
SrcSpanLess (LHsKind GhcPs)
_ -> Maybe (Located RdrName)
forall a. Maybe a
Nothing
case Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located RdrName
lIdP of
Ghc.Unqual x -> CommandLineOption -> Maybe CommandLineOption
forall a. a -> Maybe a
Just (CommandLineOption -> Maybe CommandLineOption)
-> CommandLineOption -> Maybe CommandLineOption
forall a b. (a -> b) -> a -> b
$ OccName -> CommandLineOption
Ghc.occNameString OccName
x
SrcSpanLess (Located RdrName)
_ -> Maybe CommandLineOption
forall a. Maybe a
Nothing