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 GHC.Plugins 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/9.2.4/docs/html/users_guide/extending_ghc.html#compiler-plugins>.
plugin :: Ghc.Plugin
plugin :: Plugin
plugin =
  Plugin
Ghc.defaultPlugin
    { parsedResultAction :: [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
Ghc.parsedResultAction = [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction,
      pluginRecompile :: [String] -> IO PluginRecompile
Ghc.pluginRecompile = [String] -> 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 :: [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction [String]
commandLineOptions ModSummary
modSummary HsParsedModule
hsParsedModule = do
  let lHsModule1 :: Located HsModule
lHsModule1 = HsParsedModule -> Located HsModule
Ghc.hpm_module HsParsedModule
hsParsedModule
      srcSpan :: SrcSpan
srcSpan = forall l e. GenLocated l e -> l
Ghc.getLoc Located HsModule
lHsModule1
  [Flag]
flags <- forall a. [OptDescr a] -> [String] -> SrcSpan -> Hsc [a]
Options.parse [OptDescr Flag]
Flag.options [String]
commandLineOptions SrcSpan
srcSpan
  let config :: Config
config = forall (t :: * -> *). Foldable t => t Flag -> Config
Config.fromFlags [Flag]
flags
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Config -> Bool
Config.help Config
config)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
Ghc.vcat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SDoc
Ghc.text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    forall a b. (a -> b) -> a -> b
$ forall a. String -> [OptDescr a] -> String
Console.usageInfo (String
"Evoke version " forall a. Semigroup a => a -> a -> a
<> String
version) [OptDescr Flag]
Flag.options
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Config -> Bool
Config.version Config
config) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$
    String -> SDoc
Ghc.text
      String
version

  let moduleName :: ModuleName
moduleName = forall unit. GenModule unit -> ModuleName
Ghc.moduleName forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
Ghc.ms_mod ModSummary
modSummary
  Located HsModule
lHsModule2 <- Config -> ModuleName -> Located HsModule -> Hsc (Located HsModule)
handleLHsModule Config
config ModuleName
moduleName Located HsModule
lHsModule1
  forall (f :: * -> *) a. Applicative f => a -> f a
pure HsParsedModule
hsParsedModule {hpm_module :: Located HsModule
Ghc.hpm_module = Located HsModule
lHsModule2}

-- | This package's version number as a string.
version :: String
version :: String
version = Version -> String
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.Hsc LHsModule
handleLHsModule :: Config -> ModuleName -> Located HsModule -> Hsc (Located HsModule)
handleLHsModule Config
config ModuleName
moduleName Located HsModule
lHsModule = do
  HsModule
hsModule <- Config -> ModuleName -> HsModule -> Hsc HsModule
handleHsModule Config
config ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc Located HsModule
lHsModule
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
Ghc.mapLoc (forall a b. a -> b -> a
const HsModule
hsModule) Located HsModule
lHsModule

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

-- | See 'handleLHsModule' and 'handleLHsSigType'.
handleHsModule ::
  Config.Config ->
  Ghc.ModuleName ->
  Ghc.HsModule ->
  Ghc.Hsc Ghc.HsModule
handleHsModule :: Config -> ModuleName -> HsModule -> Hsc HsModule
handleHsModule Config
config ModuleName
moduleName HsModule
hsModule = do
  ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls) <-
    Config
-> ModuleName
-> [LHsDecl GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsDecls Config
config ModuleName
moduleName forall a b. (a -> b) -> a -> b
$
      HsModule -> [LHsDecl GhcPs]
Ghc.hsmodDecls HsModule
hsModule
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    HsModule
hsModule
      { hsmodImports :: [LImportDecl GhcPs]
Ghc.hsmodImports = HsModule -> [LImportDecl GhcPs]
Ghc.hsmodImports HsModule
hsModule forall a. Semigroup a => a -> a -> a
<> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls,
        hsmodDecls :: [LHsDecl GhcPs]
Ghc.hsmodDecls = [GenLocated SrcSpanAnnA (HsDecl 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
  [([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
tuples <- 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap forall a. Monoid a => [a] -> a
mconcat forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
  [GenLocated SrcSpanAnnA (HsDecl 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 forall l e. GenLocated l e -> e
Ghc.unLoc LHsDecl GhcPs
lHsDecl of
  Ghc.TyClD XTyClD GhcPs
xTyClD TyClDecl GhcPs
tyClDecl1 -> do
    (TyClDecl GhcPs
tyClDecl2, ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)) <-
      Config
-> ModuleName
-> TyClDecl GhcPs
-> Hsc (TyClDecl GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleTyClDecl
        Config
config
        ModuleName
moduleName
        TyClDecl GhcPs
tyClDecl1
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls,
        forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
Ghc.mapLoc (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
Ghc.TyClD XTyClD GhcPs
xTyClD TyClDecl GhcPs
tyClDecl2) LHsDecl GhcPs
lHsDecl forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls
      )
  HsDecl 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 LIdP GhcPs
tcdLName LHsQTyVars GhcPs
tcdTyVars LexicalFixity
tcdFixity HsDataDefn GhcPs
tcdDataDefn -> do
    (HsDataDefn GhcPs
hsDataDefn, ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)) <-
      Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDataDefn
        Config
config
        ModuleName
moduleName
        LIdP GhcPs
tcdLName
        LHsQTyVars GhcPs
tcdTyVars
        HsDataDefn GhcPs
tcdDataDefn
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall pass.
XDataDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
Ghc.DataDecl XDataDecl GhcPs
tcdDExt LIdP GhcPs
tcdLName LHsQTyVars GhcPs
tcdTyVars LexicalFixity
tcdFixity HsDataDefn GhcPs
hsDataDefn,
        ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)
      )
  TyClDecl 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
-> Hsc (HsDataDefn GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDataDefn Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars HsDataDefn GhcPs
hsDataDefn =
  case HsDataDefn GhcPs
hsDataDefn of
    Ghc.HsDataDefn XCHsDataDefn GhcPs
dd_ext NewOrData
dd_ND Maybe (LHsContext GhcPs)
dd_ctxt Maybe (XRec GhcPs CType)
dd_cType Maybe (LHsKind GhcPs)
dd_kindSig [LConDecl GhcPs]
dd_cons HsDeriving GhcPs
dd_derivs ->
      do
        ([GenLocated SrcSpan (HsDerivingClause GhcPs)]
hsDeriving, ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)) <-
          Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDeriving
            Config
config
            ModuleName
moduleName
            LIdP GhcPs
lIdP
            LHsQTyVars GhcPs
lHsQTyVars
            [LConDecl GhcPs]
dd_cons
            HsDeriving GhcPs
dd_derivs
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( forall pass.
XCHsDataDefn pass
-> NewOrData
-> Maybe (LHsContext pass)
-> Maybe (XRec pass CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
Ghc.HsDataDefn
              XCHsDataDefn GhcPs
dd_ext
              NewOrData
dd_ND
              Maybe (LHsContext GhcPs)
dd_ctxt
              Maybe (XRec GhcPs CType)
dd_cType
              Maybe (LHsKind GhcPs)
dd_kindSig
              [LConDecl GhcPs]
dd_cons
              [GenLocated SrcSpan (HsDerivingClause GhcPs)]
hsDeriving,
            ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)
          )

-- | 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleHsDeriving Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls HsDeriving GhcPs
hsDeriving = do
  ([GenLocated SrcSpan (HsDerivingClause GhcPs)]
lHsDerivingClauses, ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)) <-
    Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClauses Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls HsDeriving GhcPs
hsDeriving
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( [GenLocated SrcSpan (HsDerivingClause GhcPs)]
lHsDerivingClauses,
      ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> Hsc (HsDeriving GhcPs, ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClauses Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls HsDeriving GhcPs
lHsDerivingClauses =
  do
    [(Maybe (GenLocated SrcSpan (HsDerivingClause GhcPs)),
  ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
   [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))]
tuples <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        (Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> LHsDerivingClause GhcPs
-> Hsc
     (Maybe (LHsDerivingClause GhcPs),
      ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClause Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls)
        HsDeriving GhcPs
lHsDerivingClauses
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap
        forall a. [Maybe a] -> [a]
Maybe.catMaybes
        (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap forall a. Monoid a => [a] -> a
mconcat forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip)
      forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe (GenLocated SrcSpan (HsDerivingClause GhcPs)),
  ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
   [GenLocated SrcSpanAnnA (HsDecl 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> LHsDerivingClause GhcPs
-> Hsc
     (Maybe (LHsDerivingClause GhcPs),
      ([LImportDecl GhcPs], [LHsDecl GhcPs]))
handleLHsDerivingClause Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls LHsDerivingClause GhcPs
lHsDerivingClause =
  case forall l e. GenLocated l e -> e
Ghc.unLoc LHsDerivingClause GhcPs
lHsDerivingClause of
    Ghc.HsDerivingClause XCHsDerivingClause GhcPs
_ Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy LDerivClauseTys GhcPs
deriv_clause_tys
      | Just [String]
options <- Maybe (LDerivStrategy GhcPs) -> Maybe [String]
parseDerivingStrategy Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy -> do
          ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls) <-
            Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [String]
-> [LHsSigType GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigTypes Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivClauseTys GhcPs -> [LHsSigType GhcPs]
toLHsSigTypes
              forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LDerivClauseTys GhcPs
deriv_clause_tys
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls))
    HsDerivingClause GhcPs
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just LHsDerivingClause GhcPs
lHsDerivingClause, ([], []))

toLHsSigTypes :: Ghc.DerivClauseTys Ghc.GhcPs -> [Ghc.LHsSigType Ghc.GhcPs]
toLHsSigTypes :: DerivClauseTys GhcPs -> [LHsSigType GhcPs]
toLHsSigTypes DerivClauseTys GhcPs
derivClauseTys = case DerivClauseTys GhcPs
derivClauseTys of
  Ghc.DctSingle XDctSingle GhcPs
_ LHsSigType GhcPs
lHsSigType -> [LHsSigType GhcPs
lHsSigType]
  Ghc.DctMulti XDctMulti GhcPs
_ [LHsSigType GhcPs]
lHsSigTypes -> [LHsSigType GhcPs]
lHsSigTypes

-- | 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 [String]
parseDerivingStrategy Maybe (LDerivStrategy GhcPs)
mLDerivStrategy = do
  GenLocated SrcSpan (DerivStrategy GhcPs)
lDerivStrategy <- Maybe (LDerivStrategy GhcPs)
mLDerivStrategy
  HsSigType GhcPs
lHsSigType <- case forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpan (DerivStrategy GhcPs)
lDerivStrategy of
    Ghc.ViaStrategy (Ghc.XViaStrategyPs EpAnn [AddEpAnn]
_ LHsSigType GhcPs
x) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LHsSigType GhcPs
x
    DerivStrategy GhcPs
_ -> forall a. Maybe a
Nothing
  GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType <- case HsSigType GhcPs
lHsSigType of
    Ghc.HsSig XHsSig GhcPs
_ HsOuterSigTyVarBndrs GhcPs
_ LHsKind GhcPs
x -> forall a. a -> Maybe a
Just LHsKind GhcPs
x
  HsTyLit
hsTyLit <- case forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType of
    Ghc.HsTyLit XTyLit GhcPs
_ HsTyLit
x -> forall a. a -> Maybe a
Just HsTyLit
x
    HsType GhcPs
_ -> forall a. Maybe a
Nothing
  FastString
fastString <- case HsTyLit
hsTyLit of
    Ghc.HsStrTy SourceText
_ FastString
x -> forall a. a -> Maybe a
Just FastString
x
    HsTyLit
_ -> forall a. Maybe a
Nothing
  case String -> [String]
words forall a b. (a -> b) -> a -> b
$ FastString -> String
Ghc.unpackFS FastString
fastString of
    String
"Evoke" : [String]
x -> forall a. a -> Maybe a
Just [String]
x
    [String]
_ -> 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [String]
-> [LHsSigType GhcPs]
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigTypes Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options [LHsSigType GhcPs]
lHsSigTypes =
  do
    [([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)])]
tuples <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        (Config
-> ModuleName
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [String]
-> LHsSigType GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigType Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options)
        [LHsSigType GhcPs]
lHsSigTypes
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap forall a. Monoid a => [a] -> a
mconcat forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
  [GenLocated SrcSpanAnnA (HsDecl 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
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LConDecl GhcPs]
-> [String]
-> LHsSigType GhcPs
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
handleLHsSigType Config
config ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options LHsSigType GhcPs
lHsSigType =
  do
    let srcSpan :: SrcSpan
srcSpan = forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> l
Ghc.getLoc LHsSigType GhcPs
lHsSigType
    ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls) <- case LHsSigType GhcPs -> Maybe Generator
getGenerator LHsSigType GhcPs
lHsSigType of
      Just Generator
generate ->
        Generator
generate ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options SrcSpan
srcSpan
      Maybe Generator
Nothing -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ String -> SDoc
Ghc.text String
"unsupported type class"

    Bool
verbose <- Config -> Hsc Bool
isVerbose Config
config
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when Bool
verbose forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
80 Char
'-'
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
Ghc.showSDocDump SDocContext
Ghc.defaultSDocContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
Ghc.ppr) [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
Ghc.showSDocDump SDocContext
Ghc.defaultSDocContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
Ghc.ppr) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls

    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
lHsDecls)

isVerbose :: Config.Config -> Ghc.Hsc Bool
isVerbose :: Config -> Hsc Bool
isVerbose Config
config = do
  DynFlags
dynFlags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
Ghc.getDynFlags
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  String
className <- LHsSigType GhcPs -> Maybe String
getClassName LHsSigType GhcPs
lHsSigType
  forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
className [(String, Generator)]
generators

generators :: [(String, Common.Generator)]
generators :: [(String, Generator)]
generators =
  [ (String
"Arbitrary", Generator
Arbitrary.generate),
    (String
"FromJSON", Generator
FromJSON.generate),
    (String
"ToJSON", Generator
ToJSON.generate),
    (String
"ToSchema", Generator
ToSchema.generate)
  ]

-- | Extracts the class name out of a type signature.
getClassName :: Ghc.LHsSigType Ghc.GhcPs -> Maybe String
getClassName :: LHsSigType GhcPs -> Maybe String
getClassName LHsSigType GhcPs
lHsSigType = do
  GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType <- case forall l e. GenLocated l e -> e
Ghc.unLoc LHsSigType GhcPs
lHsSigType of
    Ghc.HsSig XHsSig GhcPs
_ HsOuterSigTyVarBndrs GhcPs
_ LHsKind GhcPs
x -> forall a. a -> Maybe a
Just LHsKind GhcPs
x
  GenLocated SrcSpanAnnN RdrName
lIdP <- case forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType of
    Ghc.HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
x -> forall a. a -> Maybe a
Just LIdP GhcPs
x
    HsType GhcPs
_ -> forall a. Maybe a
Nothing
  case forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnN RdrName
lIdP of
    Ghc.Unqual OccName
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString OccName
x
    RdrName
_ -> forall a. Maybe a
Nothing