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

-- | The compiler plugin. You can enable this plugin with the following pragma:
--
-- > {-# OPTIONS_GHC -fplugin=Evoke #-}
--
-- This plugin accepts some options. Pass @-fplugin-opt=Evoke:--help@ to see
-- what they are. For example:
--
-- > {-# OPTIONS_GHC -fplugin=Evoke -fplugin-opt=Evoke:--help #-}
--
-- Once this plugin is enabled, you can use it by deriving instances like this:
--
-- > data Person = Person
-- >   { name :: String
-- >   , age :: Int
-- >   } deriving ToJSON via "Evoke"
--
-- The GHC user's guide has more detail about compiler plugins in general:
-- <https://downloads.haskell.org/~ghc/8.10.4/docs/html/users_guide/extending_ghc.html#compiler-plugins>.
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
  }

-- | This is the main entry point for the plugin. It receives the command line
-- options, module summary, and parsed module from GHC. Ultimately it produces
-- a new parsed module to replace the old one.
--
-- From a high level, this function parses the command line options to build a
-- config, then hands things off to the next function ('handleLHsModule').
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 }

-- | This package's version number as a string.
version :: String
version :: CommandLineOption
version = Version -> CommandLineOption
Version.showVersion Version
This.version

-- | This is the start of the plumbing functions. Our goal is to take the
-- parsed module, find any relevant deriving clauses, and replace them with
-- generated instances. This means we need to walk the tree of the parsed
-- module looking for relevant deriving clauses. When we find them, we're going
-- to remove them and emit new declarations (and imports), which need to be
-- inserted back into the parsed module tree.
--
-- All of these functions are plumbing. If you want to skip to the interesting
-- part, go to 'handleLHsSigType'.
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

-- | Most GHC types have type aliases for their located versions. For some
-- reason the module type doesn't.
type LHsModule pass = Ghc.Located (Ghc.HsModule pass)

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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
    }

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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])

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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, ([], []))

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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, ([], []))

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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)
    )

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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, ([], []))

-- | This plugin only fires on specific deriving strategies. In particular it
-- looks for clauses like this:
--
-- > deriving C via "Evoke ..."
--
-- This function is responsible for analyzing a deriving strategy to determine
-- if the plugin should fire or not.
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

-- | See 'handleLHsModule' and 'handleLHsSigType'.
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

-- | This is the main workhorse of the plugin. By the time things get here,
-- everything has already been plumbed correctly. (See 'handleLHsModule' for
-- details.) This function is responsible for actually generating the instance.
-- If we don't know how to generate an instance for the requested class, an
-- error will be thrown. If the user requested verbose output, the generated
-- instance will be printed.
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)
  ]

-- | Extracts the class name out of a type signature.
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