packages feed

evoke 0.2022.5.2 → 0.2022.5.19

raw patch · 34 files changed

+1868/−1876 lines, 34 filesdep ~HUnitdep ~aesondep ~base

Dependency ranges changed: HUnit, aeson, base, ghc, insert-ordered-containers, lens, swagger2, text

Files

LICENSE.txt view
@@ -1,4 +1,4 @@-Copyright (c) 2021 Taylor Fausak+Copyright (c) 2022 Taylor Fausak  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
evoke.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10  name: evoke-version: 0.2022.5.2+version: 0.2022.5.19 synopsis: A GHC plugin to derive instances. description: Evoke is a GHC plugin to derive instances. @@ -18,8 +18,8 @@  library   build-depends:-    base >= 4.14 && < 4.15-    , ghc >= 8.10.1 && < 8.11+    base >= 4.15.0 && < 4.16+    , ghc >= 9.0.1 && < 9.1     , text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.1   default-language: Haskell2010   exposed-modules:@@ -48,22 +48,22 @@     -Wno-prepositive-qualified-module     -Wno-safe     -Wno-unsafe-  hs-source-dirs: src/lib+  hs-source-dirs: source/library   other-modules: Paths_evoke  test-suite test   build-depends:     base-    , aeson+    , aeson >= 2.0.3 && < 2.1     , evoke-    , HUnit >= 1.6.1 && < 1.7-    , insert-ordered-containers >= 0.2.3 && < 0.3-    , lens >= 4.19.2 && < 4.20+    , HUnit >= 1.6.2 && < 1.7+    , insert-ordered-containers >= 0.2.5 && < 0.3+    , lens >= 5.1 && < 5.2     , QuickCheck >= 2.14.2 && < 2.15-    , swagger2 >= 2.6 && < 2.7-    , text >= 1.2.3 && < 1.3+    , swagger2 >= 2.8.2 && < 2.9+    , text >= 1.2.5 && < 1.3   default-language: Haskell2010   ghc-options: -rtsopts -threaded-  hs-source-dirs: src/test+  hs-source-dirs: source/test-suite   main-is: Main.hs   type: exitcode-stdio-1.0
+ source/library/Evoke.hs view
@@ -0,0 +1,387 @@+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/8.10.4/docs/html/users_guide/extending_ghc.html#compiler-plugins>.+plugin :: Ghc.Plugin+plugin = Ghc.defaultPlugin+  { Ghc.parsedResultAction = parsedResultAction+  , Ghc.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 commandLineOptions modSummary hsParsedModule = do+  let+    lHsModule1 = Ghc.hpm_module hsParsedModule+    srcSpan = Ghc.getLoc lHsModule1+  flags <- Options.parse Flag.options commandLineOptions srcSpan+  let config = Config.fromFlags flags+  Monad.when (Config.help config)+    . Hsc.throwError srcSpan+    . Ghc.vcat+    . fmap Ghc.text+    . lines+    $ Console.usageInfo ("Evoke version " <> version) Flag.options+  Monad.when (Config.version config) . Hsc.throwError srcSpan $ Ghc.text+    version++  let moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary+  lHsModule2 <- handleLHsModule config moduleName lHsModule1+  pure hsParsedModule { Ghc.hpm_module = lHsModule2 }++-- | This package's version number as a string.+version :: String+version = Version.showVersion 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 lHsModule = do+  hsModule <- handleHsModule config moduleName $ Ghc.unLoc lHsModule+  pure $ Ghc.mapLoc (const 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 = do+  (lImportDecls, lHsDecls) <- handleLHsDecls config moduleName+    $ Ghc.hsmodDecls hsModule+  pure hsModule+    { Ghc.hsmodImports = Ghc.hsmodImports hsModule <> lImportDecls+    , Ghc.hsmodDecls = 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 lHsDecls = do+  tuples <- mapM (handleLHsDecl config moduleName) lHsDecls+  pure . Bifunctor.bimap mconcat mconcat $ unzip 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 = case Ghc.unLoc lHsDecl of+  Ghc.TyClD xTyClD tyClDecl1 -> do+    (tyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl+      config+      moduleName+      tyClDecl1+    pure+      ( lImportDecls+      , Ghc.mapLoc (const $ Ghc.TyClD xTyClD tyClDecl2) lHsDecl : lHsDecls+      )+  _ -> pure ([], [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 = case tyClDecl of+  Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity tcdDataDefn -> do+    (hsDataDefn, (lImportDecls, lHsDecls)) <- handleHsDataDefn+      config+      moduleName+      tcdLName+      tcdTyVars+      tcdDataDefn+    pure+      ( Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity hsDataDefn+      , (lImportDecls, lHsDecls)+      )+  _ -> pure (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 lHsQTyVars hsDataDefn =+  case hsDataDefn of+    Ghc.HsDataDefn dd_ext dd_ND dd_ctxt dd_cType dd_kindSig dd_cons dd_derivs+      -> do+        (hsDeriving, (lImportDecls, lHsDecls)) <- handleHsDeriving+          config+          moduleName+          lIdP+          lHsQTyVars+          dd_cons+          dd_derivs+        pure+          ( Ghc.HsDataDefn+            dd_ext+            dd_ND+            dd_ctxt+            dd_cType+            dd_kindSig+            dd_cons+            hsDeriving+          , (lImportDecls, 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 lHsQTyVars lConDecls hsDeriving = do+  (lHsDerivingClauses, (lImportDecls, lHsDecls)) <-+    handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls+      $ Ghc.unLoc hsDeriving+  pure+    ( Ghc.mapLoc (const lHsDerivingClauses) hsDeriving+    , (lImportDecls, 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 lHsQTyVars lConDecls lHsDerivingClauses+  = do+    tuples <- mapM+      (handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls)+      lHsDerivingClauses+    pure+      . Bifunctor.bimap+          Maybe.catMaybes+          (Bifunctor.bimap mconcat mconcat . unzip)+      $ unzip 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 lHsQTyVars lConDecls lHsDerivingClause+  = case Ghc.unLoc lHsDerivingClause of+    Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys+      | Just options <- parseDerivingStrategy deriv_clause_strategy -> do+        (lImportDecls, lHsDecls) <-+          handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options+            $ Ghc.unLoc deriv_clause_tys+        pure (Nothing, (lImportDecls, lHsDecls))+    _ -> pure (Just 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 mLDerivStrategy = do+  lDerivStrategy <- mLDerivStrategy+  lHsSigType <- case Ghc.unLoc lDerivStrategy of+    Ghc.ViaStrategy x -> Just x+    _ -> Nothing+  lHsType <- case lHsSigType of+    Ghc.HsIB _ x -> Just x+  hsTyLit <- case Ghc.unLoc lHsType of+    Ghc.HsTyLit _ x -> Just x+    _ -> Nothing+  fastString <- case hsTyLit of+    Ghc.HsStrTy _ x -> Just x+    _ -> Nothing+  case words $ Ghc.unpackFS fastString of+    "Evoke" : x -> Just x+    _ -> 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 lHsQTyVars lConDecls options lHsSigTypes+  = do+    tuples <- mapM+      (handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options)+      lHsSigTypes+    pure . Bifunctor.bimap mconcat mconcat $ unzip 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 lHsQTyVars lConDecls options lHsSigType+  = do+    let+      srcSpan = case lHsSigType of+        Ghc.HsIB _ x -> Ghc.getLoc x+    (lImportDecls, lHsDecls) <- case getGenerator lHsSigType of+      Just generate ->+        generate moduleName lIdP lHsQTyVars lConDecls options srcSpan+      Nothing -> Hsc.throwError srcSpan $ Ghc.text "unsupported type class"++    verbose <- isVerbose config+    Monad.when verbose $ do+      dynFlags <- Ghc.getDynFlags+      IO.liftIO $ do+        putStrLn $ replicate 80 '-'+        mapM_ (putStrLn . Ghc.showSDocDump dynFlags . Ghc.ppr) lImportDecls+        mapM_ (putStrLn . Ghc.showSDocDump dynFlags . Ghc.ppr) lHsDecls++    pure (lImportDecls, lHsDecls)++isVerbose :: Config.Config -> Ghc.Hsc Bool+isVerbose config = do+  dynFlags <- Ghc.getDynFlags+  pure $ Config.verbose config || Ghc.dopt Ghc.Opt_D_dump_deriv dynFlags++getGenerator :: Ghc.LHsSigType Ghc.GhcPs -> Maybe Common.Generator+getGenerator lHsSigType = do+  className <- getClassName lHsSigType+  lookup className generators++generators :: [(String, Common.Generator)]+generators =+  [ ("Arbitrary", Arbitrary.generate)+  , ("FromJSON", FromJSON.generate)+  , ("ToJSON", ToJSON.generate)+  , ("ToSchema", ToSchema.generate)+  ]++-- | Extracts the class name out of a type signature.+getClassName :: Ghc.LHsSigType Ghc.GhcPs -> Maybe String+getClassName lHsSigType = do+  lHsType <- case lHsSigType of+    Ghc.HsIB _ x -> Just x+  lIdP <- case Ghc.unLoc lHsType of+    Ghc.HsTyVar _ _ x -> Just x+    _ -> Nothing+  case Ghc.unLoc lIdP of+    Ghc.Unqual x -> Just $ Ghc.occNameString x+    _ -> Nothing
+ source/library/Evoke/Constant/Module.hs view
@@ -0,0 +1,44 @@+module Evoke.Constant.Module+  ( controlApplicative+  , controlLens+  , dataAeson+  , dataHashMapStrictInsOrd+  , dataMaybe+  , dataMonoid+  , dataProxy+  , dataString+  , dataSwagger+  , testQuickCheck+  ) where++import qualified GHC.Unit.Module as Ghc++controlApplicative :: Ghc.ModuleName+controlApplicative = Ghc.mkModuleName "Control.Applicative"++controlLens :: Ghc.ModuleName+controlLens = Ghc.mkModuleName "Control.Lens"++dataAeson :: Ghc.ModuleName+dataAeson = Ghc.mkModuleName "Data.Aeson"++dataHashMapStrictInsOrd :: Ghc.ModuleName+dataHashMapStrictInsOrd = Ghc.mkModuleName "Data.HashMap.Strict.InsOrd"++dataMaybe :: Ghc.ModuleName+dataMaybe = Ghc.mkModuleName "Data.Maybe"++dataMonoid :: Ghc.ModuleName+dataMonoid = Ghc.mkModuleName "Data.Monoid"++dataProxy :: Ghc.ModuleName+dataProxy = Ghc.mkModuleName "Data.Proxy"++dataString :: Ghc.ModuleName+dataString = Ghc.mkModuleName "Data.String"++dataSwagger :: Ghc.ModuleName+dataSwagger = Ghc.mkModuleName "Data.Swagger"++testQuickCheck :: Ghc.ModuleName+testQuickCheck = Ghc.mkModuleName "Test.QuickCheck"
+ source/library/Evoke/Generator/Arbitrary.hs view
@@ -0,0 +1,82 @@+module Evoke.Generator.Arbitrary+  ( generate+  ) where++import qualified Data.List as List+import qualified Evoke.Constant.Module as Module+import qualified Evoke.Generator.Common as Common+import qualified Evoke.Hs as Hs+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Type.Constructor as Constructor+import qualified Evoke.Type.Field as Field+import qualified Evoke.Type.Type as Type+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++generate :: Common.Generator+generate _ lIdP lHsQTyVars lConDecls _ srcSpan = do+  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan+  constructor <- case Type.constructors type_ of+    [x] -> pure x+    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"+  fields <-+    mapM (fromField srcSpan)+    . List.sortOn Field.name+    . concatMap Constructor.fields+    $ Type.constructors type_++  applicative <- Common.makeRandomModule Module.controlApplicative+  quickCheck <- Common.makeRandomModule Module.testQuickCheck+  let+    lImportDecls = Hs.importDecls+      srcSpan+      [ (Module.controlApplicative, applicative)+      , (Module.testQuickCheck, quickCheck)+      ]++    bindStmts = fmap+      (\(_, var) ->+        Hs.bindStmt srcSpan (Hs.varPat srcSpan var)+          . Hs.qualVar srcSpan quickCheck+          $ Ghc.mkVarOcc "arbitrary"+      )+      fields++    lastStmt =+      Hs.lastStmt srcSpan+        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")+        . Hs.recordCon srcSpan (Ghc.L srcSpan $ Constructor.name constructor)+        . Hs.recFields+        $ fmap+            (\(field, var) ->+              Hs.recField+                  srcSpan+                  (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field)+                $ Hs.var srcSpan var+            )+            fields++    lHsBind =+      Common.makeLHsBind srcSpan (Ghc.mkVarOcc "arbitrary") []+        . Hs.doExpr srcSpan+        $ bindStmts+        <> [lastStmt]++    lHsDecl = Common.makeInstanceDeclaration+      srcSpan+      type_+      quickCheck+      (Ghc.mkClsOcc "Arbitrary")+      [lHsBind]++  pure (lImportDecls, [lHsDecl])++fromField+  :: Ghc.SrcSpan -> Field.Field -> Ghc.Hsc (Field.Field, Ghc.LIdP Ghc.GhcPs)+fromField srcSpan field = do+  var <-+    Common.makeRandomVariable srcSpan+    . (<> "_")+    . Ghc.occNameString+    $ Field.name field+  pure (field, var)
+ source/library/Evoke/Generator/Common.hs view
@@ -0,0 +1,326 @@+module Evoke.Generator.Common+  ( Generator+  , applyAll+  , fieldNameOptions+  , makeInstanceDeclaration+  , makeLHsBind+  , makeRandomModule+  , makeRandomVariable+  ) where++import qualified GHC.Data.Bag as Ghc+import qualified Control.Monad.IO.Class as IO+import qualified Data.Char as Char+import qualified Data.IORef as IORef+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Evoke.Hs as Hs+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Type.Constructor as Constructor+import qualified Evoke.Type.Field as Field+import qualified Evoke.Type.Type as Type+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc+import qualified System.Console.GetOpt as Console+import qualified System.IO.Unsafe as Unsafe+import qualified Text.Printf as Printf++type Generator+  = Ghc.ModuleName+  -> Ghc.LIdP Ghc.GhcPs+  -> Ghc.LHsQTyVars Ghc.GhcPs+  -> [Ghc.LConDecl Ghc.GhcPs]+  -> [String]+  -> Ghc.SrcSpan+  -> Ghc.Hsc+       ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])++fieldNameOptions+  :: Ghc.SrcSpan -> [Console.OptDescr (String -> Ghc.Hsc String)]+fieldNameOptions srcSpan =+  [ Console.Option [] ["kebab"] (Console.NoArg $ pure . kebab) ""+  , Console.Option [] ["camel"] (Console.NoArg $ pure . lower) ""+  , Console.Option [] ["snake"] (Console.NoArg $ pure . snake) ""+  , Console.Option [] ["prefix", "strip"] (Console.ReqArg (stripPrefix srcSpan) "PREFIX" ) ""+  , Console.Option [] ["suffix"] (Console.ReqArg (stripSuffix srcSpan) "SUFFIX" ) ""+  , Console.Option [] ["title"] (Console.NoArg $ pure . upper) ""+  , Console.Option [] ["rename"] (Console.ReqArg (rename srcSpan) "OLD:NEW") ""+  ]++stripPrefix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String+stripPrefix srcSpan prefix s1 = case List.stripPrefix prefix s1 of+  Nothing ->+    Hsc.throwError srcSpan+      . Ghc.text+      $ show prefix+      <> " is not a prefix of "+      <> show s1+  Just s2 -> pure s2++stripSuffix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String+stripSuffix srcSpan suffix s1 = case Text.stripSuffix (Text.pack suffix) (Text.pack s1) of+  Nothing ->+    Hsc.throwError srcSpan+      . Ghc.text+      $ show suffix+      <> " is not a suffix of "+      <> show s1+  Just s2 -> pure $ Text.unpack s2++rename :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String+rename loc arg str =+  case Text.splitOn (Text.singleton ':') $ Text.pack arg of+    [old, new] | not (Text.null old || Text.null new) ->+      pure $ if Text.pack str == old+        then Text.unpack new+        else str+    _ -> Hsc.throwError loc . Ghc.text $ show arg <> " is invalid"++-- | Applies all the monadic functions in order beginning with some starting+-- value.+applyAll :: Monad m => [a -> m a] -> a -> m a+applyAll fs x = case fs of+  [] -> pure x+  f : gs -> do+    y <- f x+    applyAll gs y++-- | Converts the first character into upper case.+upper :: String -> String+upper = overFirst Char.toUpper++-- | Converts the first character into lower case.+lower :: String -> String+lower = overFirst Char.toLower++overFirst :: (a -> a) -> [a] -> [a]+overFirst f xs = case xs of+  x : ys -> f x : ys+  _ -> xs++-- | Converts the string into kebab case.+--+-- >>> kebab "DoReMi"+-- "do-re-mi"+kebab :: String -> String+kebab = camelTo '-'++-- | Converts the string into snake case.+--+-- >>> snake "DoReMi"+-- "do_re_mi"+snake :: String -> String+snake = camelTo '_'++camelTo :: Char -> String -> String+camelTo char =+  let+    go wasUpper string = case string of+      "" -> ""+      first : rest -> if Char.isUpper first+        then if wasUpper+          then Char.toLower first : go True rest+          else char : Char.toLower first : go True rest+        else first : go False rest+  in go True++makeLHsType+  :: Ghc.SrcSpan+  -> Ghc.ModuleName+  -> Ghc.OccName+  -> Type.Type+  -> Ghc.LHsType Ghc.GhcPs+makeLHsType srcSpan moduleName className =+  Ghc.L srcSpan+    . Ghc.HsAppTy+        Ghc.noExtField+        (Ghc.L srcSpan+        . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted+        . Ghc.L srcSpan+        $ Ghc.Qual moduleName className+        )+    . toLHsType srcSpan++toLHsType :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs+toLHsType srcSpan type_ =+  let+    ext :: Ghc.NoExtField+    ext = Ghc.noExtField++    loc :: a -> Ghc.Located a+    loc = Ghc.L srcSpan++    initial :: Ghc.LHsType Ghc.GhcPs+    initial = loc . Ghc.HsTyVar ext Ghc.NotPromoted . loc $ Type.name type_++    combine+      :: Ghc.LHsType Ghc.GhcPs -> Ghc.IdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs+    combine x =+      loc . Ghc.HsAppTy ext x . loc . Ghc.HsTyVar ext Ghc.NotPromoted . loc++    bare :: Ghc.LHsType Ghc.GhcPs+    bare = List.foldl' combine initial $ Type.variables type_+  in case Type.variables type_ of+    [] -> bare+    _ -> loc $ Ghc.HsParTy ext bare++makeHsContext+  :: Ghc.SrcSpan+  -> Ghc.ModuleName+  -> Ghc.OccName+  -> Type.Type+  -> [Ghc.LHsType Ghc.GhcPs]+makeHsContext srcSpan moduleName className =+  fmap+      (Ghc.L srcSpan+      . Ghc.HsAppTy+          Ghc.noExtField+          (Ghc.L srcSpan+          . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted+          . Ghc.L srcSpan+          $ Ghc.Qual moduleName className+          )+      . Ghc.L srcSpan+      . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted+      . Ghc.L srcSpan+      . Ghc.Unqual+      )+    . List.nub+    . Maybe.mapMaybe+        (\field -> case Field.type_ field of+          Ghc.HsTyVar _ _ lRdrName -> case Ghc.unLoc lRdrName of+            Ghc.Unqual occName | Ghc.isTvOcc occName -> Just occName+            _ -> Nothing+          _ -> Nothing+        )+    . concatMap Constructor.fields+    . Type.constructors++makeHsImplicitBndrs+  :: Ghc.SrcSpan+  -> Type.Type+  -> Ghc.ModuleName+  -> Ghc.OccName+  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)+makeHsImplicitBndrs srcSpan type_ moduleName className =+  let+    withoutContext = makeLHsType srcSpan moduleName className type_+    context = makeHsContext srcSpan moduleName className type_+    withContext = if null context+      then withoutContext+      else Ghc.L srcSpan+        $ Ghc.HsQualTy Ghc.noExtField (Ghc.L srcSpan context) withoutContext+  in Ghc.HsIB Ghc.noExtField withContext++-- | Makes a random variable name using the given prefix.+makeRandomVariable :: Ghc.SrcSpan -> String -> Ghc.Hsc (Ghc.LIdP Ghc.GhcPs)+makeRandomVariable srcSpan prefix = do+  n <- bumpCounter+  pure . Ghc.L srcSpan . Ghc.Unqual . Ghc.mkVarOcc $ Printf.printf+    "%s%d"+    prefix+    n++-- | Makes a random module name. This will convert any periods to underscores+-- and add a unique suffix.+--+-- >>> makeRandomModule "Data.Aeson"+-- "Data_Aeson_1"+makeRandomModule :: Ghc.ModuleName -> Ghc.Hsc Ghc.ModuleName+makeRandomModule moduleName = do+  n <- bumpCounter+  pure . Ghc.mkModuleName $ Printf.printf+    "%s_%d"+    (underscoreAll moduleName)+    n++underscoreAll :: Ghc.ModuleName -> String+underscoreAll = fmap underscoreOne . Ghc.moduleNameString++underscoreOne :: Char -> Char+underscoreOne c = case c of+  '.' -> '_'+  _ -> c++makeInstanceDeclaration+  :: Ghc.SrcSpan+  -> Type.Type+  -> Ghc.ModuleName+  -> Ghc.OccName+  -> [Ghc.LHsBind Ghc.GhcPs]+  -> Ghc.LHsDecl Ghc.GhcPs+makeInstanceDeclaration srcSpan type_ moduleName occName lHsBinds =+  let hsImplicitBndrs = makeHsImplicitBndrs srcSpan type_ moduleName occName+  in makeLHsDecl srcSpan hsImplicitBndrs lHsBinds++makeLHsDecl+  :: Ghc.SrcSpan+  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)+  -> [Ghc.LHsBind Ghc.GhcPs]+  -> Ghc.LHsDecl Ghc.GhcPs+makeLHsDecl srcSpan hsImplicitBndrs lHsBinds =+  Ghc.L srcSpan+    . Ghc.InstD Ghc.noExtField+    . Ghc.ClsInstD Ghc.noExtField+    $ Ghc.ClsInstDecl+        Ghc.noExtField+        hsImplicitBndrs+        (Ghc.listToBag lHsBinds)+        []+        []+        []+        Nothing++makeLHsBind+  :: Ghc.SrcSpan+  -> Ghc.OccName+  -> [Ghc.LPat Ghc.GhcPs]+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsBind Ghc.GhcPs+makeLHsBind srcSpan occName pats =+  Hs.funBind srcSpan occName . makeMatchGroup srcSpan occName pats++makeMatchGroup+  :: Ghc.SrcSpan+  -> Ghc.OccName+  -> [Ghc.LPat Ghc.GhcPs]+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+makeMatchGroup srcSpan occName lPats hsExpr = Ghc.MG+  Ghc.noExtField+  (Ghc.L srcSpan [Ghc.L srcSpan $ makeMatch srcSpan occName lPats hsExpr])+  Ghc.Generated++makeMatch+  :: Ghc.SrcSpan+  -> Ghc.OccName+  -> [Ghc.LPat Ghc.GhcPs]+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+makeMatch srcSpan occName lPats =+  Ghc.Match+      Ghc.noExtField+      (Ghc.FunRhs+        (Ghc.L srcSpan $ Ghc.Unqual occName)+        Ghc.Prefix+        Ghc.NoSrcStrict+      )+      lPats+    . makeGRHSs srcSpan++makeGRHSs+  :: Ghc.SrcSpan+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+makeGRHSs srcSpan hsExpr =+  Ghc.GRHSs Ghc.noExtField [Hs.grhs srcSpan hsExpr]+    . Ghc.L srcSpan+    $ Ghc.EmptyLocalBinds Ghc.noExtField++bumpCounter :: IO.MonadIO m => m Word+bumpCounter = IO.liftIO . IORef.atomicModifyIORef' counterRef $ \ n -> (n + 1, n)++counterRef :: IORef.IORef Word+counterRef = Unsafe.unsafePerformIO $ IORef.newIORef 0+{-# NOINLINE counterRef #-}
+ source/library/Evoke/Generator/FromJSON.hs view
@@ -0,0 +1,120 @@+module Evoke.Generator.FromJSON+  ( generate+  ) where++import qualified Data.List as List+import qualified Evoke.Constant.Module as Module+import qualified Evoke.Generator.Common as Common+import qualified Evoke.Hs as Hs+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Options as Options+import qualified Evoke.Type.Constructor as Constructor+import qualified Evoke.Type.Field as Field+import qualified Evoke.Type.Type as Type+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++generate :: Common.Generator+generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do+  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan+  constructor <- case Type.constructors type_ of+    [x] -> pure x+    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"+  modifyFieldName <-+    Common.applyAll+      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan++  fields <-+    mapM (fromField srcSpan modifyFieldName)+    . List.sortOn Field.name+    . concatMap Constructor.fields+    $ Type.constructors type_++  applicative <- Common.makeRandomModule Module.controlApplicative+  aeson <- Common.makeRandomModule Module.dataAeson+  string <- Common.makeRandomModule Module.dataString+  object <- Common.makeRandomVariable srcSpan "object_"+  let+    lImportDecls = Hs.importDecls+      srcSpan+      [ (Module.controlApplicative, applicative)+      , (Module.dataAeson, aeson)+      , (Module.dataString, string)+      ]++    bindStmts = fmap+      (\(field, (name, var)) ->+        Hs.bindStmt srcSpan (Hs.varPat srcSpan var)+          . Hs.opApp+              srcSpan+              (Hs.var srcSpan object)+              (Hs.qualVar srcSpan aeson+              . Ghc.mkVarOcc+              $ if Field.isOptional field then ".:?" else ".:"+              )+          . Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString")+          . Hs.lit srcSpan+          $ Hs.string name+      )+      fields++    lastStmt =+      Hs.lastStmt srcSpan+        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")+        . Hs.recordCon srcSpan (Ghc.L srcSpan $ Constructor.name constructor)+        . Hs.recFields+        $ fmap+            (\(field, (_, var)) ->+              Hs.recField+                  srcSpan+                  (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field)+                $ Hs.var srcSpan var+            )+            fields++    lHsBind =+      Common.makeLHsBind srcSpan (Ghc.mkVarOcc "parseJSON") []+        . Hs.app+            srcSpan+            (Hs.app+                srcSpan+                (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "withObject")+            . Hs.lit srcSpan+            . Hs.string+            $ Type.qualifiedName moduleName type_+            )+        . Hs.par srcSpan+        . Hs.lam srcSpan+        . Hs.mg+        $ Ghc.L+            srcSpan+            [ Hs.match srcSpan Ghc.LambdaExpr [Hs.varPat srcSpan object]+                $ Hs.grhss+                    srcSpan+                    [ Hs.grhs srcSpan+                      . Hs.doExpr srcSpan+                      $ bindStmts+                      <> [lastStmt]+                    ]+            ]++    lHsDecl = Common.makeInstanceDeclaration+      srcSpan+      type_+      aeson+      (Ghc.mkClsOcc "FromJSON")+      [lHsBind]++  pure (lImportDecls, [lHsDecl])++fromField+  :: Ghc.SrcSpan+  -> (String -> Ghc.Hsc String)+  -> Field.Field+  -> Ghc.Hsc (Field.Field, (String, Ghc.LIdP Ghc.GhcPs))+fromField srcSpan modifyFieldName field = do+  let fieldName = Field.name field+  name <- modifyFieldName $ Ghc.occNameString fieldName+  var <- Common.makeRandomVariable srcSpan . (<> "_") $ Ghc.occNameString+    fieldName+  pure (field, (name, var))
+ source/library/Evoke/Generator/ToJSON.hs view
@@ -0,0 +1,93 @@+module Evoke.Generator.ToJSON+  ( generate+  ) where++import qualified Data.List as List+import qualified Evoke.Constant.Module as Module+import qualified Evoke.Generator.Common as Common+import qualified Evoke.Hs as Hs+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Options as Options+import qualified Evoke.Type.Constructor as Constructor+import qualified Evoke.Type.Field as Field+import qualified Evoke.Type.Type as Type+import qualified GHC.Plugins as Ghc++generate :: Common.Generator+generate _ lIdP lHsQTyVars lConDecls options srcSpan = do+  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan+  case Type.constructors type_ of+    [_] -> pure ()+    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"++  modifyFieldName <-+    Common.applyAll+      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan++  fieldNames <-+    mapM (fromField modifyFieldName)+    . List.sort+    . fmap Field.name+    . concatMap Constructor.fields+    $ Type.constructors type_++  aeson <- Common.makeRandomModule Module.dataAeson+  monoid <- Common.makeRandomModule Module.dataMonoid+  string <- Common.makeRandomModule Module.dataString+  var1 <- Common.makeRandomVariable srcSpan "var_"+  var2 <- Common.makeRandomVariable srcSpan "var_"+  let+    lImportDecls = Hs.importDecls+      srcSpan+      [ (Module.dataAeson, aeson)+      , (Module.dataMonoid, monoid)+      , (Module.dataString, string)+      ]++    toPair lRdrName (occName, fieldName) =+      Hs.opApp+          srcSpan+          (Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString")+          . Hs.lit srcSpan+          $ Hs.string fieldName+          )+          (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc ".=")+        . Hs.app srcSpan (Hs.var srcSpan $ Hs.unqual srcSpan occName)+        $ Hs.var srcSpan lRdrName++    lHsExprs lRdrName = fmap (toPair lRdrName) fieldNames++    toJSON =+      Common.makeLHsBind+          srcSpan+          (Ghc.mkVarOcc "toJSON")+          [Hs.varPat srcSpan var1]+        . Hs.app srcSpan (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "object")+        . Hs.explicitList srcSpan+        $ lHsExprs var1++    toEncoding =+      Common.makeLHsBind+          srcSpan+          (Ghc.mkVarOcc "toEncoding")+          [Hs.varPat srcSpan var2]+        . Hs.app srcSpan (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "pairs")+        . Hs.par srcSpan+        . Hs.app srcSpan (Hs.qualVar srcSpan monoid $ Ghc.mkVarOcc "mconcat")+        . Hs.explicitList srcSpan+        $ lHsExprs var2++    lHsDecl = Common.makeInstanceDeclaration+      srcSpan+      type_+      aeson+      (Ghc.mkClsOcc "ToJSON")+      [toJSON, toEncoding]++  pure (lImportDecls, [lHsDecl])++fromField+  :: (String -> Ghc.Hsc String) -> Ghc.OccName -> Ghc.Hsc (Ghc.OccName, String)+fromField modifyFieldName occName = do+  fieldName <- modifyFieldName $ Ghc.occNameString occName+  pure (occName, fieldName)
+ source/library/Evoke/Generator/ToSchema.hs view
@@ -0,0 +1,183 @@+module Evoke.Generator.ToSchema+  ( generate+  ) where++import qualified Data.List as List+import qualified Evoke.Constant.Module as Module+import qualified Evoke.Generator.Common as Common+import qualified Evoke.Hs as Hs+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Options as Options+import qualified Evoke.Type.Constructor as Constructor+import qualified Evoke.Type.Field as Field+import qualified Evoke.Type.Type as Type+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++generate :: Common.Generator+generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do+  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan+  case Type.constructors type_ of+    [_] -> pure ()+    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"++  modifyFieldName <-+    Common.applyAll+      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan++  fields <-+    mapM (fromField srcSpan modifyFieldName)+    . List.sortOn Field.name+    . concatMap Constructor.fields+    $ Type.constructors type_++  applicative <- Common.makeRandomModule Module.controlApplicative+  lens <- Common.makeRandomModule Module.controlLens+  hashMap <- Common.makeRandomModule Module.dataHashMapStrictInsOrd+  dataMaybe <- Common.makeRandomModule Module.dataMaybe+  monoid <- Common.makeRandomModule Module.dataMonoid+  proxy <- Common.makeRandomModule Module.dataProxy+  string <- Common.makeRandomModule Module.dataString+  swagger <- Common.makeRandomModule Module.dataSwagger+  ignored <- Common.makeRandomVariable srcSpan "_proxy_"+  let+    lImportDecls = Hs.importDecls+      srcSpan+      [ (Module.controlApplicative, applicative)+      , (Module.controlLens, lens)+      , (Module.dataHashMapStrictInsOrd, hashMap)+      , (Module.dataMaybe, dataMaybe)+      , (Module.dataMonoid, monoid)+      , (Module.dataProxy, proxy)+      , (Module.dataString, string)+      , (Module.dataSwagger, swagger)+      ]++    toBind field var =+      Hs.bindStmt srcSpan (Hs.varPat srcSpan var)+        . Hs.app+            srcSpan+            (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "declareSchemaRef")+        . Hs.par srcSpan+        . Ghc.L srcSpan+        . Ghc.ExprWithTySig+            Ghc.noExtField+            (Hs.qualVar srcSpan proxy $ Ghc.mkDataOcc "Proxy")+        . Ghc.HsWC Ghc.noExtField+        . Ghc.HsIB Ghc.noExtField+        . Ghc.L srcSpan+        . Ghc.HsAppTy+            Ghc.noExtField+            (Hs.qualTyVar srcSpan proxy $ Ghc.mkClsOcc "Proxy")+        . Ghc.L srcSpan+        . Ghc.HsParTy Ghc.noExtField+        . Ghc.L srcSpan+        $ Field.type_ field -- TODO: This requires `ScopedTypeVariables`.++    bindStmts = fmap (\((field, _), var) -> toBind field var) fields++    setType =+      Hs.opApp+          srcSpan+          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "type_")+          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc "?~")+        . Hs.qualVar srcSpan swagger+        $ Ghc.mkDataOcc "SwaggerObject"++    setProperties =+      Hs.opApp+          srcSpan+          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "properties")+          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc ".~")+        . Hs.app srcSpan (Hs.qualVar srcSpan hashMap $ Ghc.mkVarOcc "fromList")+        . Hs.explicitList srcSpan+        $ fmap+            (\((_, name), var) -> Hs.explicitTuple srcSpan $ fmap+              (Hs.tupArg srcSpan)+              [ Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString")+              . Hs.lit srcSpan+              $ Hs.string name+              , Hs.var srcSpan var+              ]+            )+            fields++    setRequired =+      Hs.opApp+          srcSpan+          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "required")+          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc ".~")+        . Hs.explicitList srcSpan+        . fmap+            (Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString")+            . Hs.lit srcSpan+            . Hs.string+            . snd+            . fst+            )+        $ filter (not . Field.isOptional . fst . fst) fields++    lastStmt =+      Hs.lastStmt srcSpan+        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")+        . Hs.par srcSpan+        . Hs.app+            srcSpan+            (Hs.app+                srcSpan+                (Hs.qualVar srcSpan swagger $ Ghc.mkDataOcc "NamedSchema")+            . Hs.par srcSpan+            . Hs.app+                srcSpan+                (Hs.qualVar srcSpan dataMaybe $ Ghc.mkDataOcc "Just")+            . Hs.par srcSpan+            . Hs.app srcSpan (Hs.qualVar srcSpan string $ Ghc.mkVarOcc "fromString")+            . Hs.lit srcSpan+            . Hs.string+            $ Type.qualifiedName moduleName type_+            )+        . Hs.par srcSpan+        . makePipeline srcSpan lens [setType, setProperties, setRequired]+        . Hs.qualVar srcSpan monoid+        $ Ghc.mkVarOcc "mempty"++    lHsBind =+      Common.makeLHsBind+          srcSpan+          (Ghc.mkVarOcc "declareNamedSchema")+          [Hs.varPat srcSpan ignored]+        . Hs.doExpr srcSpan+        $ bindStmts+        <> [lastStmt]++    lHsDecl = Common.makeInstanceDeclaration+      srcSpan+      type_+      swagger+      (Ghc.mkClsOcc "ToSchema")+      [lHsBind]++  pure (lImportDecls, [lHsDecl])++fromField+  :: Ghc.SrcSpan+  -> (String -> Ghc.Hsc String)+  -> Field.Field+  -> Ghc.Hsc ((Field.Field, String), Ghc.LIdP Ghc.GhcPs)+fromField srcSpan modifyFieldName field = do+  let fieldName = Field.name field+  name <- modifyFieldName $ Ghc.occNameString fieldName+  var <- Common.makeRandomVariable srcSpan . (<> "_") $ Ghc.occNameString+    fieldName+  pure ((field, name), var)++makePipeline+  :: Ghc.SrcSpan+  -> Ghc.ModuleName+  -> [Ghc.LHsExpr Ghc.GhcPs]+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+makePipeline srcSpan m es e = case es of+  [] -> e+  h : t -> makePipeline srcSpan m t+    $ Hs.opApp srcSpan e (Hs.qualVar srcSpan m $ Ghc.mkVarOcc "&") h
+ source/library/Evoke/Hs.hs view
@@ -0,0 +1,197 @@+module Evoke.Hs+  ( app+  , bindStmt+  , doExpr+  , explicitList+  , explicitTuple+  , fieldOcc+  , funBind+  , grhs+  , grhss+  , importDecls+  , lam+  , lastStmt+  , lit+  , match+  , mg+  , opApp+  , par+  , qual+  , qualTyVar+  , qualVar+  , recField+  , recFields+  , recordCon+  , string+  , tupArg+  , tyVar+  , unqual+  , var+  , varPat+  ) where++import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++app+  :: Ghc.SrcSpan+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+app s f = Ghc.L s . Ghc.HsApp Ghc.noExtField f++bindStmt+  :: Ghc.SrcSpan+  -> Ghc.LPat Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+bindStmt s p e =+  Ghc.L s $ Ghc.BindStmt Ghc.noExtField p e++doExpr :: Ghc.SrcSpan -> [Ghc.ExprLStmt Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs+doExpr s = Ghc.L s . Ghc.HsDo Ghc.noExtField (Ghc.DoExpr Nothing) . Ghc.L s++explicitList+  :: Ghc.SrcSpan -> [Ghc.LHsExpr Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs+explicitList s = Ghc.L s . Ghc.ExplicitList Ghc.noExtField Nothing++explicitTuple+  :: Ghc.SrcSpan -> [Ghc.LHsTupArg Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs+explicitTuple s xs = Ghc.L s $ Ghc.ExplicitTuple Ghc.noExtField xs Ghc.Boxed++fieldOcc :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LFieldOcc Ghc.GhcPs+fieldOcc s = Ghc.L s . Ghc.FieldOcc Ghc.noExtField++funBind+  :: Ghc.SrcSpan+  -> Ghc.OccName+  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+  -> Ghc.LHsBind Ghc.GhcPs+funBind s f g =+  Ghc.L s $ Ghc.FunBind Ghc.noExtField (unqual s f) g []++grhs+  :: Ghc.SrcSpan+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+grhs s = Ghc.L s . Ghc.GRHS Ghc.noExtField []++grhss+  :: Ghc.SrcSpan+  -> [Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]+  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+grhss s xs =+  Ghc.GRHSs Ghc.noExtField xs . Ghc.L s $ Ghc.EmptyLocalBinds Ghc.noExtField++importDecl+  :: Ghc.SrcSpan+  -> Ghc.ModuleName+  -> Ghc.ModuleName+  -> Ghc.LImportDecl Ghc.GhcPs+importDecl s m n = Ghc.L s $ Ghc.ImportDecl+  Ghc.noExtField+  Ghc.NoSourceText+  (Ghc.L s m)+  Nothing+  Ghc.NotBoot+  False+  Ghc.QualifiedPre+  False+  (Just $ Ghc.L s n)+  Nothing++importDecls+  :: Ghc.SrcSpan+  -> [(Ghc.ModuleName, Ghc.ModuleName)]+  -> [Ghc.LImportDecl Ghc.GhcPs]+importDecls = fmap . uncurry . importDecl++lam+  :: Ghc.SrcSpan+  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+  -> Ghc.LHsExpr Ghc.GhcPs+lam s = Ghc.L s . Ghc.HsLam Ghc.noExtField++lastStmt+  :: Ghc.SrcSpan+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+lastStmt s e = Ghc.L s $ Ghc.LastStmt Ghc.noExtField e Nothing noSyntaxExpr++lit :: Ghc.SrcSpan -> Ghc.HsLit Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+lit s = Ghc.L s . Ghc.HsLit Ghc.noExtField++noSyntaxExpr :: Ghc.SyntaxExpr Ghc.GhcPs+noSyntaxExpr = Ghc.noSyntaxExpr++match+  :: Ghc.SrcSpan+  -> Ghc.HsMatchContext (Ghc.NoGhcTc Ghc.GhcPs)+  -> [Ghc.LPat Ghc.GhcPs]+  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+  -> Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+match s c ps = Ghc.L s . Ghc.Match Ghc.noExtField c ps++mg+  :: Ghc.Located [Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]+  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+mg ms = Ghc.MG Ghc.noExtField ms Ghc.Generated++opApp+  :: Ghc.SrcSpan+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+opApp s l o = Ghc.L s . Ghc.OpApp Ghc.noExtField l o++par :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+par s = Ghc.L s . Ghc.HsPar Ghc.noExtField++qual :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs+qual s m = Ghc.L s . Ghc.mkRdrQual m++qualTyVar+  :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsType Ghc.GhcPs+qualTyVar s m = tyVar s . qual s m++qualVar+  :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsExpr Ghc.GhcPs+qualVar s m = var s . qual s m++recFields+  :: [Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]+  -> Ghc.HsRecFields Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+recFields = flip Ghc.HsRecFields Nothing++recField+  :: Ghc.SrcSpan+  -> Ghc.LFieldOcc Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+  -> Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+recField s f e = Ghc.L s $ Ghc.HsRecField f e False++recordCon+  :: Ghc.SrcSpan+  -> Ghc.LIdP Ghc.GhcPs+  -> Ghc.HsRecordBinds Ghc.GhcPs+  -> Ghc.LHsExpr Ghc.GhcPs+recordCon s c = Ghc.L s . Ghc.RecordCon Ghc.noExtField c++string :: String -> Ghc.HsLit Ghc.GhcPs+string = Ghc.HsString Ghc.NoSourceText . Ghc.mkFastString++tupArg :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsTupArg Ghc.GhcPs+tupArg s = Ghc.L s . Ghc.Present Ghc.noExtField++tyVar :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs+tyVar s = Ghc.L s . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted++unqual :: Ghc.SrcSpan -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs+unqual s = Ghc.L s . Ghc.mkRdrUnqual++var :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+var s = Ghc.L s . Ghc.HsVar Ghc.noExtField++varPat :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LPat Ghc.GhcPs+varPat s = Ghc.L s . Ghc.VarPat Ghc.noExtField
+ source/library/Evoke/Hsc.hs view
@@ -0,0 +1,25 @@+module Evoke.Hsc+  ( addWarning+  , throwError+  ) where++import qualified GHC.Data.Bag as Ghc+import qualified Control.Monad.IO.Class as IO+import qualified GHC.Utils.Error as Ghc+import qualified GHC.Plugins as Ghc++-- | Adds a warning, which only causes compilation to fail if @-Werror@ is+-- enabled.+addWarning :: Ghc.SrcSpan -> Ghc.MsgDoc -> Ghc.Hsc ()+addWarning srcSpan msgDoc = do+  dynFlags <- Ghc.getDynFlags+  IO.liftIO+    . Ghc.printOrThrowWarnings dynFlags+    . Ghc.unitBag+    $ Ghc.mkPlainWarnMsg dynFlags srcSpan msgDoc++-- | Throws an error, which will cause compilation to fail.+throwError :: Ghc.SrcSpan -> Ghc.MsgDoc -> Ghc.Hsc a+throwError srcSpan msgDoc = do+  dynFlags <- Ghc.getDynFlags+  Ghc.throwOneError $ Ghc.mkPlainErrMsg dynFlags srcSpan msgDoc
+ source/library/Evoke/Options.hs view
@@ -0,0 +1,39 @@+module Evoke.Options+  ( parse+  ) where++import qualified Control.Monad as Monad+import qualified Evoke.Hsc as Hsc+import qualified GHC.Plugins as Ghc+import qualified System.Console.GetOpt as Console++-- | Parses command line options. Adds warnings and throws errors as+-- appropriate. Returns the list of parsed options.+parse :: [Console.OptDescr a] -> [String] -> Ghc.SrcSpan -> Ghc.Hsc [a]+parse optDescrs strings srcSpan = do+  let+    (xs, args, opts, errs) = Console.getOpt' Console.Permute optDescrs strings+  Monad.forM_ opts+    $ Hsc.addWarning srcSpan+    . Ghc.text+    . mappend "unknown option: "+    . quote+  Monad.forM_ args+    $ Hsc.addWarning srcSpan+    . Ghc.text+    . mappend "unexpected argument: "+    . quote+  Monad.unless (null errs)+    . Hsc.throwError srcSpan+    . Ghc.vcat+    . fmap Ghc.text+    . lines+    $ mconcat errs+  pure xs++-- | Quotes a string using GHC's weird quoting format.+--+-- >>> quote "thing"+-- "`thing'"+quote :: String -> String+quote string = "`" <> string <> "'"
+ source/library/Evoke/Type/Config.hs view
@@ -0,0 +1,26 @@+module Evoke.Type.Config+  ( Config(..)+  , fromFlags+  ) where++import qualified Data.List as List+import qualified Evoke.Type.Flag as Flag++data Config = Config+  { help :: Bool+  , verbose :: Bool+  , version :: Bool+  }+  deriving (Eq, Show)++initial :: Config+initial = Config { help = False, verbose = False, version = False }++fromFlags :: Foldable t => t Flag.Flag -> Config+fromFlags = List.foldl' applyFlag initial++applyFlag :: Config -> Flag.Flag -> Config+applyFlag config flag = case flag of+  Flag.Help -> config { help = True }+  Flag.Verbose -> config { verbose = True }+  Flag.Version -> config { version = True }
+ source/library/Evoke/Type/Constructor.hs view
@@ -0,0 +1,30 @@+module Evoke.Type.Constructor+  ( Constructor(..)+  , make+  ) where++import qualified Control.Monad as Monad+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Type.Field as Field+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++data Constructor = Constructor+  { name :: Ghc.IdP Ghc.GhcPs+  , fields :: [Field.Field]+  }++make :: Ghc.SrcSpan -> Ghc.LConDecl Ghc.GhcPs -> Ghc.Hsc Constructor+make srcSpan lConDecl = do+  (lIdP, hsConDeclDetails) <- case Ghc.unLoc lConDecl of+    Ghc.ConDeclH98 _ x _ _ _ y _ -> pure (x, y)+    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LConDecl"+  lConDeclFields <- case hsConDeclDetails of+    Ghc.RecCon x -> pure x+    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported HsConDeclDetails"+  theFields <-+    fmap concat . Monad.forM (Ghc.unLoc lConDeclFields) $ \lConDeclField -> do+      (lFieldOccs, lHsType) <- case Ghc.unLoc lConDeclField of+        Ghc.ConDeclField _ x y _ -> pure (x, y)+      mapM (Field.make srcSpan lHsType) lFieldOccs+  pure Constructor { name = Ghc.unLoc lIdP, fields = theFields }
+ source/library/Evoke/Type/Field.hs view
@@ -0,0 +1,36 @@+module Evoke.Type.Field+  ( Field(..)+  , make+  , isOptional+  ) where++import qualified Evoke.Hsc as Hsc+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++data Field = Field+  { name :: Ghc.OccName+  , type_ :: Ghc.HsType Ghc.GhcPs+  }++make+  :: Ghc.SrcSpan+  -> Ghc.LHsType Ghc.GhcPs+  -> Ghc.LFieldOcc Ghc.GhcPs+  -> Ghc.Hsc Field+make srcSpan lHsType lFieldOcc = do+  lRdrName <- case Ghc.unLoc lFieldOcc of+    Ghc.FieldOcc _ x -> pure x+  occName <- case Ghc.unLoc lRdrName of+    Ghc.Unqual x -> pure x+    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported RdrName"+  pure Field { name = occName, type_ = Ghc.unLoc lHsType }++isOptional :: Field -> Bool+isOptional field = case type_ field of+  Ghc.HsAppTy _ lHsType _ -> case Ghc.unLoc lHsType of+    Ghc.HsTyVar _ _ lIdP -> case Ghc.unLoc lIdP of+      Ghc.Unqual occName -> Ghc.occNameString occName == "Maybe"+      _ -> False+    _ -> False+  _ -> False
+ source/library/Evoke/Type/Flag.hs view
@@ -0,0 +1,31 @@+module Evoke.Type.Flag+  ( Flag(..)+  , options+  ) where++import qualified System.Console.GetOpt as Console++data Flag+  = Help+  | Verbose+  | Version+  deriving (Eq, Show)++options :: [Console.OptDescr Flag]+options =+  [ Console.Option+    ['h', '?']+    ["help"]+    (Console.NoArg Help)+    "shows this help message and exits"+  , Console.Option+    ['v']+    ["version"]+    (Console.NoArg Version)+    "shows the version number and exits"+  , Console.Option+    []+    ["verbose"]+    (Console.NoArg Verbose)+    "outputs derived instances"+  ]
+ source/library/Evoke/Type/Type.hs view
@@ -0,0 +1,44 @@+module Evoke.Type.Type+  ( Type(..)+  , make+  , qualifiedName+  ) where++import qualified Control.Monad as Monad+import qualified Evoke.Hsc as Hsc+import qualified Evoke.Type.Constructor as Constructor+import qualified GHC.Hs as Ghc+import qualified GHC.Plugins as Ghc++data Type = Type+  { name :: Ghc.IdP Ghc.GhcPs+  , variables :: [Ghc.IdP Ghc.GhcPs]+  , constructors :: [Constructor.Constructor]+  }++make+  :: Ghc.LIdP Ghc.GhcPs+  -> Ghc.LHsQTyVars Ghc.GhcPs+  -> [Ghc.LConDecl Ghc.GhcPs]+  -> Ghc.SrcSpan+  -> Ghc.Hsc Type+make lIdP lHsQTyVars lConDecls srcSpan = do+  lHsTyVarBndrs <- case lHsQTyVars of+    Ghc.HsQTvs _ hsq_explicit -> pure hsq_explicit+  theVariables <- Monad.forM lHsTyVarBndrs $ \lHsTyVarBndr ->+    case Ghc.unLoc lHsTyVarBndr of+      Ghc.UserTyVar _ _ var -> pure $ Ghc.unLoc var+      _ -> Hsc.throwError srcSpan $ Ghc.text "unknown LHsTyVarBndr"+  theConstructors <- mapM (Constructor.make srcSpan) lConDecls+  pure Type+    { name = Ghc.unLoc lIdP+    , variables = theVariables+    , constructors = theConstructors+    }++qualifiedName :: Ghc.ModuleName -> Type -> String+qualifiedName moduleName type_ = mconcat+  [ Ghc.moduleNameString moduleName+  , "."+  , Ghc.occNameString . Ghc.rdrNameOcc $ name type_+  ]
+ source/test-suite/Main.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -fplugin=Evoke #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.QQ.Simple as Aeson+import qualified Data.Proxy as Proxy+import qualified Data.Swagger as Swagger+import qualified Test.HUnit as Unit+import qualified Test.QuickCheck as QuickCheck++main :: IO ()+main = Unit.runTestTTAndExit $ Unit.test+  [ testToJSON T1C1 { t1c1f1 = 1 } [Aeson.aesonQQ| { "t1c1f1": 1 } |]+  , testToJSON+    T2C1 { t2c1f1 = 2, t2c1f2 = 3 }+    [Aeson.aesonQQ| { "t2c1f1": 2, "t2c1f2": 3 } |]+  , testToJSON T3C1 { t3c1f1aA = 4 } [Aeson.aesonQQ| { "t3c1f1a_a": 4 } |]+  , testToJSON T4C1 { t4c1f1aA = 5 } [Aeson.aesonQQ| { "t4c1f1a-a": 5 } |]+  , testToJSON T5C1 { t5c1f1 = 6 } [Aeson.aesonQQ| { "T5c1f1": 6 } |]+  , testToJSON T6C1 { t6c1f1 = 7 } [Aeson.aesonQQ| { "f1": 7 } |]+  , testToJSON T7C1 { t7c1f1 = 8 } [Aeson.aesonQQ| { "F1": 8 } |]+  , testToJSON T8C1 { t8c1f1 = 9 } [Aeson.aesonQQ| { "f1": 9 } |]+  , testToJSON+    (T9C1 { t9c1f1 = 10 } :: T9 X)+    [Aeson.aesonQQ| { "t9c1f1": 10 } |]+  , testToJSON+    T10C1 { t10c1f1 = 11 :: Int }+    [Aeson.aesonQQ| { "t10c1f1": 11 } |]+  , testToJSON T11C1 { t11c1f1A = 12 } [Aeson.aesonQQ| { "a": 12 } |]+  , testToJSON+    (T12C1 { t12c1f1 = 13, t12c1f2 = 14 } :: T12 X Int X Int X)+    [Aeson.aesonQQ| { "t12c1f1": 13, "t12c1f2": 14 } |]+  , testToJSON+    T13C1 { t13c1f1 = 15, t13c1f2 = 16 }+    [Aeson.aesonQQ| { "t13c1f1": 15, "t13c1f2": 16 } |]+  , testToJSON T14C1 { t14c1f1 = Just 17 } [Aeson.aesonQQ| { "t14c1f1": 17 } |]+  , testToJSON T15C1 { t15c1f1 = 18 } [Aeson.aesonQQ| { "t15c1": 18 } |]+  , testToJSON T16C1 { t16c1f1 = 19 } [Aeson.aesonQQ| { "one": 19 } |]+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T1)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T2)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T3)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T4)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T5)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T6)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T7)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T8)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T9 X))+  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T10 Int))+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T11)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T12 X Int X Int X))+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T13)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T14)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T15)+  , checkInstances (Proxy.Proxy :: Proxy.Proxy T16)+  ]++checkInstances+  :: ( QuickCheck.Arbitrary a+     , Eq a+     , Aeson.FromJSON a+     , Show a+     , Aeson.ToJSON a+     , Swagger.ToSchema a+     )+  => Proxy.Proxy a+  -> Unit.Test+checkInstances proxy = Unit.TestCase $ do+  value <- QuickCheck.generate QuickCheck.arbitrary+  Aeson.decode (Aeson.encode value) Unit.@?= Just value+  let json = Aeson.toJSON $ Proxy.asProxyTypeOf value proxy+  Aeson.fromJSON json Unit.@?= Aeson.Success value+  Swagger.validateJSON mempty (Swagger.toSchema proxy) json Unit.@?= []++testToJSON :: Aeson.ToJSON a => a -> Aeson.Value -> Unit.Test+testToJSON = (Unit.~?=) . Aeson.toJSON++-- custom void type with no instances+data X++-- one field+newtype T1 = T1C1+  { t1c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- multiple fields+data T2 = T2C1+  { t2c1f1 :: Int+  , t2c1f2 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- snake case+newtype T3 = T3C1+  { t3c1f1aA :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --snake"++-- kebab case+newtype T4 = T4C1+  { t4c1f1aA :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --kebab"++-- capitalized+newtype T5 = T5C1+  { t5c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --title"++-- stripped prefix+newtype T6 = T6C1+  { t6c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t6c1"++-- stripped then capitalized+newtype T7 = T7C1+  { t7c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t7c1 --title"++-- capitalized then stripped+newtype T8 = T8C1+  { t8c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --title --prefix T8c1"++-- phantom type+newtype T9 a = T9C1+  { t9c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- type variable+newtype T10 a = T10C1+  { t10c1f1 :: a+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- lower cased+newtype T11 = T11C1+  { t11c1f1A :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t11c1f1 --camel"++-- multiple type variables+data T12 a b c d e = T12C1+  { t12c1f1 :: d+  , t12c1f2 :: b+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- multiple fields with one signature+data T13 = T13C1+  { t13c1f1, t13c1f2 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- optional field+newtype T14 = T14C1+  { t14c1f1 :: Maybe Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"++-- stripped suffix+newtype T15 = T15C1+  { t15c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --suffix f1"++-- renamed+newtype T16 = T16C1+  { t16c1f1 :: Int+  }+  deriving (Eq, Show)+  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --rename t16c1f1:one"
− src/lib/Evoke.hs 
@@ -1,391 +0,0 @@-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 = Ghc.defaultPlugin-  { Ghc.parsedResultAction = parsedResultAction-  , Ghc.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 commandLineOptions modSummary hsParsedModule = do-  let-    lHsModule1 = Ghc.hpm_module hsParsedModule-    srcSpan = Ghc.getLoc lHsModule1-  flags <- Options.parse Flag.options commandLineOptions srcSpan-  let config = Config.fromFlags flags-  Monad.when (Config.help config)-    . Hsc.throwError srcSpan-    . Ghc.vcat-    . fmap Ghc.text-    . lines-    $ Console.usageInfo ("Evoke version " <> version) Flag.options-  Monad.when (Config.version config) . Hsc.throwError srcSpan $ Ghc.text-    version--  let moduleName = Ghc.moduleName $ Ghc.ms_mod modSummary-  lHsModule2 <- handleLHsModule config moduleName lHsModule1-  pure hsParsedModule { Ghc.hpm_module = lHsModule2 }---- | This package's version number as a string.-version :: String-version = Version.showVersion 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 lHsModule = do-  hsModule <- handleHsModule config moduleName $ Ghc.unLoc lHsModule-  pure $ Ghc.mapLoc (const hsModule) 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 = do-  (lImportDecls, lHsDecls) <- handleLHsDecls config moduleName-    $ Ghc.hsmodDecls hsModule-  pure hsModule-    { Ghc.hsmodImports = Ghc.hsmodImports hsModule <> lImportDecls-    , Ghc.hsmodDecls = 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 lHsDecls = do-  tuples <- mapM (handleLHsDecl config moduleName) lHsDecls-  pure . Bifunctor.bimap mconcat mconcat $ unzip 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 = case Ghc.unLoc lHsDecl of-  Ghc.TyClD xTyClD tyClDecl1 -> do-    (tyClDecl2, (lImportDecls, lHsDecls)) <- handleTyClDecl-      config-      moduleName-      tyClDecl1-    pure-      ( lImportDecls-      , Ghc.mapLoc (const $ Ghc.TyClD xTyClD tyClDecl2) lHsDecl : lHsDecls-      )-  _ -> pure ([], [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 = case tyClDecl of-  Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity tcdDataDefn -> do-    (hsDataDefn, (lImportDecls, lHsDecls)) <- handleHsDataDefn-      config-      moduleName-      tcdLName-      tcdTyVars-      tcdDataDefn-    pure-      ( Ghc.DataDecl tcdDExt tcdLName tcdTyVars tcdFixity hsDataDefn-      , (lImportDecls, lHsDecls)-      )-  _ -> pure (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 lHsQTyVars hsDataDefn =-  case hsDataDefn of-    Ghc.HsDataDefn dd_ext dd_ND dd_ctxt dd_cType dd_kindSig dd_cons dd_derivs-      -> do-        (hsDeriving, (lImportDecls, lHsDecls)) <- handleHsDeriving-          config-          moduleName-          lIdP-          lHsQTyVars-          dd_cons-          dd_derivs-        pure-          ( Ghc.HsDataDefn-            dd_ext-            dd_ND-            dd_ctxt-            dd_cType-            dd_kindSig-            dd_cons-            hsDeriving-          , (lImportDecls, lHsDecls)-          )-    _ -> pure (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 lIdP lHsQTyVars lConDecls hsDeriving = do-  (lHsDerivingClauses, (lImportDecls, lHsDecls)) <--    handleLHsDerivingClauses config moduleName lIdP lHsQTyVars lConDecls-      $ Ghc.unLoc hsDeriving-  pure-    ( Ghc.mapLoc (const lHsDerivingClauses) hsDeriving-    , (lImportDecls, 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 lHsQTyVars lConDecls lHsDerivingClauses-  = do-    tuples <- mapM-      (handleLHsDerivingClause config moduleName lIdP lHsQTyVars lConDecls)-      lHsDerivingClauses-    pure-      . Bifunctor.bimap-          Maybe.catMaybes-          (Bifunctor.bimap mconcat mconcat . unzip)-      $ unzip 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 lHsQTyVars lConDecls lHsDerivingClause-  = case Ghc.unLoc lHsDerivingClause of-    Ghc.HsDerivingClause _ deriv_clause_strategy deriv_clause_tys-      | Just options <- parseDerivingStrategy deriv_clause_strategy -> do-        (lImportDecls, lHsDecls) <--          handleLHsSigTypes config moduleName lIdP lHsQTyVars lConDecls options-            $ Ghc.unLoc deriv_clause_tys-        pure (Nothing, (lImportDecls, lHsDecls))-    _ -> pure (Just 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 mLDerivStrategy = do-  lDerivStrategy <- mLDerivStrategy-  lHsSigType <- case Ghc.unLoc lDerivStrategy of-    Ghc.ViaStrategy x -> Just x-    _ -> Nothing-  lHsType <- case lHsSigType of-    Ghc.HsIB _ x -> Just x-    _ -> Nothing-  hsTyLit <- case Ghc.unLoc lHsType of-    Ghc.HsTyLit _ x -> Just x-    _ -> Nothing-  fastString <- case hsTyLit of-    Ghc.HsStrTy _ x -> Just x-    _ -> Nothing-  case words $ Ghc.unpackFS fastString of-    "Evoke" : x -> Just x-    _ -> 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 lHsQTyVars lConDecls options lHsSigTypes-  = do-    tuples <- mapM-      (handleLHsSigType config moduleName lIdP lHsQTyVars lConDecls options)-      lHsSigTypes-    pure . Bifunctor.bimap mconcat mconcat $ unzip 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 lHsQTyVars lConDecls options lHsSigType-  = do-    let-      srcSpan = case lHsSigType of-        Ghc.HsIB _ x -> Ghc.getLoc x-        _ -> Ghc.getLoc lIdP-    (lImportDecls, lHsDecls) <- case getGenerator lHsSigType of-      Just generate ->-        generate moduleName lIdP lHsQTyVars lConDecls options srcSpan-      Nothing -> Hsc.throwError srcSpan $ Ghc.text "unsupported type class"--    verbose <- isVerbose config-    Monad.when verbose $ do-      dynFlags <- Ghc.getDynFlags-      IO.liftIO $ do-        putStrLn $ replicate 80 '-'-        mapM_ (putStrLn . Ghc.showSDocDump dynFlags . Ghc.ppr) lImportDecls-        mapM_ (putStrLn . Ghc.showSDocDump dynFlags . Ghc.ppr) lHsDecls--    pure (lImportDecls, lHsDecls)--isVerbose :: Config.Config -> Ghc.Hsc Bool-isVerbose config = do-  dynFlags <- Ghc.getDynFlags-  pure $ Config.verbose config || Ghc.dopt Ghc.Opt_D_dump_deriv dynFlags--getGenerator :: Ghc.LHsSigType Ghc.GhcPs -> Maybe Common.Generator-getGenerator lHsSigType = do-  className <- getClassName lHsSigType-  lookup className generators--generators :: [(String, Common.Generator)]-generators =-  [ ("Arbitrary", Arbitrary.generate)-  , ("FromJSON", FromJSON.generate)-  , ("ToJSON", ToJSON.generate)-  , ("ToSchema", ToSchema.generate)-  ]---- | Extracts the class name out of a type signature.-getClassName :: Ghc.LHsSigType Ghc.GhcPs -> Maybe String-getClassName lHsSigType = do-  lHsType <- case lHsSigType of-    Ghc.HsIB _ x -> Just x-    _ -> Nothing-  lIdP <- case Ghc.unLoc lHsType of-    Ghc.HsTyVar _ _ x -> Just x-    _ -> Nothing-  case Ghc.unLoc lIdP of-    Ghc.Unqual x -> Just $ Ghc.occNameString x-    _ -> Nothing
− src/lib/Evoke/Constant/Module.hs 
@@ -1,44 +0,0 @@-module Evoke.Constant.Module-  ( controlApplicative-  , controlLens-  , dataAeson-  , dataHashMapStrictInsOrd-  , dataMaybe-  , dataMonoid-  , dataProxy-  , dataSwagger-  , dataText-  , testQuickCheck-  ) where--import qualified Module as Ghc--controlApplicative :: Ghc.ModuleName-controlApplicative = Ghc.mkModuleName "Control.Applicative"--controlLens :: Ghc.ModuleName-controlLens = Ghc.mkModuleName "Control.Lens"--dataAeson :: Ghc.ModuleName-dataAeson = Ghc.mkModuleName "Data.Aeson"--dataHashMapStrictInsOrd :: Ghc.ModuleName-dataHashMapStrictInsOrd = Ghc.mkModuleName "Data.HashMap.Strict.InsOrd"--dataMaybe :: Ghc.ModuleName-dataMaybe = Ghc.mkModuleName "Data.Maybe"--dataMonoid :: Ghc.ModuleName-dataMonoid = Ghc.mkModuleName "Data.Monoid"--dataProxy :: Ghc.ModuleName-dataProxy = Ghc.mkModuleName "Data.Proxy"--dataSwagger :: Ghc.ModuleName-dataSwagger = Ghc.mkModuleName "Data.Swagger"--dataText :: Ghc.ModuleName-dataText = Ghc.mkModuleName "Data.Text"--testQuickCheck :: Ghc.ModuleName-testQuickCheck = Ghc.mkModuleName "Test.QuickCheck"
− src/lib/Evoke/Generator/Arbitrary.hs 
@@ -1,82 +0,0 @@-module Evoke.Generator.Arbitrary-  ( generate-  ) where--import qualified Data.List as List-import qualified Evoke.Constant.Module as Module-import qualified Evoke.Generator.Common as Common-import qualified Evoke.Hs as Hs-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Type.Constructor as Constructor-import qualified Evoke.Type.Field as Field-import qualified Evoke.Type.Type as Type-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--generate :: Common.Generator-generate _ lIdP lHsQTyVars lConDecls _ srcSpan = do-  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan-  constructor <- case Type.constructors type_ of-    [x] -> pure x-    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"-  fields <--    mapM (fromField srcSpan)-    . List.sortOn Field.name-    . concatMap Constructor.fields-    $ Type.constructors type_--  applicative <- Common.makeRandomModule Module.controlApplicative-  quickCheck <- Common.makeRandomModule Module.testQuickCheck-  let-    lImportDecls = Hs.importDecls-      srcSpan-      [ (Module.controlApplicative, applicative)-      , (Module.testQuickCheck, quickCheck)-      ]--    bindStmts = fmap-      (\(_, var) ->-        Hs.bindStmt srcSpan (Hs.varPat srcSpan var)-          . Hs.qualVar srcSpan quickCheck-          $ Ghc.mkVarOcc "arbitrary"-      )-      fields--    lastStmt =-      Hs.lastStmt srcSpan-        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")-        . Hs.recordCon srcSpan (Ghc.L srcSpan $ Constructor.name constructor)-        . Hs.recFields-        $ fmap-            (\(field, var) ->-              Hs.recField-                  srcSpan-                  (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field)-                $ Hs.var srcSpan var-            )-            fields--    lHsBind =-      Common.makeLHsBind srcSpan (Ghc.mkVarOcc "arbitrary") []-        . Hs.doExpr srcSpan-        $ bindStmts-        <> [lastStmt]--    lHsDecl = Common.makeInstanceDeclaration-      srcSpan-      type_-      quickCheck-      (Ghc.mkClsOcc "Arbitrary")-      [lHsBind]--  pure (lImportDecls, [lHsDecl])--fromField-  :: Ghc.SrcSpan -> Field.Field -> Ghc.Hsc (Field.Field, Ghc.LIdP Ghc.GhcPs)-fromField srcSpan field = do-  var <--    Common.makeRandomVariable srcSpan-    . (<> "_")-    . Ghc.occNameString-    $ Field.name field-  pure (field, var)
− src/lib/Evoke/Generator/Common.hs 
@@ -1,326 +0,0 @@-module Evoke.Generator.Common-  ( Generator-  , applyAll-  , fieldNameOptions-  , makeInstanceDeclaration-  , makeLHsBind-  , makeRandomModule-  , makeRandomVariable-  ) where--import qualified Bag as Ghc-import qualified Control.Monad.IO.Class as IO-import qualified Data.Char as Char-import qualified Data.IORef as IORef-import qualified Data.List as List-import qualified Data.Maybe as Maybe-import qualified Data.Text as Text-import qualified Evoke.Hs as Hs-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Type.Constructor as Constructor-import qualified Evoke.Type.Field as Field-import qualified Evoke.Type.Type as Type-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc-import qualified System.Console.GetOpt as Console-import qualified System.IO.Unsafe as Unsafe-import qualified Text.Printf as Printf--type Generator-  = Ghc.ModuleName-  -> Ghc.LIdP Ghc.GhcPs-  -> Ghc.LHsQTyVars Ghc.GhcPs-  -> [Ghc.LConDecl Ghc.GhcPs]-  -> [String]-  -> Ghc.SrcSpan-  -> Ghc.Hsc-       ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])--fieldNameOptions-  :: Ghc.SrcSpan -> [Console.OptDescr (String -> Ghc.Hsc String)]-fieldNameOptions srcSpan =-  [ Console.Option [] ["kebab"] (Console.NoArg $ pure . kebab) ""-  , Console.Option [] ["camel"] (Console.NoArg $ pure . lower) ""-  , Console.Option [] ["snake"] (Console.NoArg $ pure . snake) ""-  , Console.Option [] ["prefix", "strip"] (Console.ReqArg (stripPrefix srcSpan) "PREFIX" ) ""-  , Console.Option [] ["suffix"] (Console.ReqArg (stripSuffix srcSpan) "SUFFIX" ) ""-  , Console.Option [] ["title"] (Console.NoArg $ pure . upper) ""-  , Console.Option [] ["rename"] (Console.ReqArg (rename srcSpan) "OLD:NEW") ""-  ]--stripPrefix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String-stripPrefix srcSpan prefix s1 = case List.stripPrefix prefix s1 of-  Nothing ->-    Hsc.throwError srcSpan-      . Ghc.text-      $ show prefix-      <> " is not a prefix of "-      <> show s1-  Just s2 -> pure s2--stripSuffix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String-stripSuffix srcSpan suffix s1 = case Text.stripSuffix (Text.pack suffix) (Text.pack s1) of-  Nothing ->-    Hsc.throwError srcSpan-      . Ghc.text-      $ show suffix-      <> " is not a suffix of "-      <> show s1-  Just s2 -> pure $ Text.unpack s2--rename :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String-rename loc arg str =-  case Text.splitOn (Text.singleton ':') $ Text.pack arg of-    [old, new] | not (Text.null old || Text.null new) ->-      pure $ if Text.pack str == old-        then Text.unpack new-        else str-    _ -> Hsc.throwError loc . Ghc.text $ show arg <> " is invalid"---- | Applies all the monadic functions in order beginning with some starting--- value.-applyAll :: Monad m => [a -> m a] -> a -> m a-applyAll fs x = case fs of-  [] -> pure x-  f : gs -> do-    y <- f x-    applyAll gs y---- | Converts the first character into upper case.-upper :: String -> String-upper = overFirst Char.toUpper---- | Converts the first character into lower case.-lower :: String -> String-lower = overFirst Char.toLower--overFirst :: (a -> a) -> [a] -> [a]-overFirst f xs = case xs of-  x : ys -> f x : ys-  _ -> xs---- | Converts the string into kebab case.------ >>> kebab "DoReMi"--- "do-re-mi"-kebab :: String -> String-kebab = camelTo '-'---- | Converts the string into snake case.------ >>> snake "DoReMi"--- "do_re_mi"-snake :: String -> String-snake = camelTo '_'--camelTo :: Char -> String -> String-camelTo char =-  let-    go wasUpper string = case string of-      "" -> ""-      first : rest -> if Char.isUpper first-        then if wasUpper-          then Char.toLower first : go True rest-          else char : Char.toLower first : go True rest-        else first : go False rest-  in go True--makeLHsType-  :: Ghc.SrcSpan-  -> Ghc.ModuleName-  -> Ghc.OccName-  -> Type.Type-  -> Ghc.LHsType Ghc.GhcPs-makeLHsType srcSpan moduleName className =-  Ghc.L srcSpan-    . Ghc.HsAppTy-        Ghc.noExtField-        (Ghc.L srcSpan-        . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted-        . Ghc.L srcSpan-        $ Ghc.Qual moduleName className-        )-    . toLHsType srcSpan--toLHsType :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs-toLHsType srcSpan type_ =-  let-    ext :: Ghc.NoExtField-    ext = Ghc.noExtField--    loc :: a -> Ghc.Located a-    loc = Ghc.L srcSpan--    initial :: Ghc.LHsType Ghc.GhcPs-    initial = loc . Ghc.HsTyVar ext Ghc.NotPromoted . loc $ Type.name type_--    combine-      :: Ghc.LHsType Ghc.GhcPs -> Ghc.IdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs-    combine x =-      loc . Ghc.HsAppTy ext x . loc . Ghc.HsTyVar ext Ghc.NotPromoted . loc--    bare :: Ghc.LHsType Ghc.GhcPs-    bare = List.foldl' combine initial $ Type.variables type_-  in case Type.variables type_ of-    [] -> bare-    _ -> loc $ Ghc.HsParTy ext bare--makeHsContext-  :: Ghc.SrcSpan-  -> Ghc.ModuleName-  -> Ghc.OccName-  -> Type.Type-  -> [Ghc.LHsType Ghc.GhcPs]-makeHsContext srcSpan moduleName className =-  fmap-      (Ghc.L srcSpan-      . Ghc.HsAppTy-          Ghc.noExtField-          (Ghc.L srcSpan-          . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted-          . Ghc.L srcSpan-          $ Ghc.Qual moduleName className-          )-      . Ghc.L srcSpan-      . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted-      . Ghc.L srcSpan-      . Ghc.Unqual-      )-    . List.nub-    . Maybe.mapMaybe-        (\field -> case Field.type_ field of-          Ghc.HsTyVar _ _ lRdrName -> case Ghc.unLoc lRdrName of-            Ghc.Unqual occName | Ghc.isTvOcc occName -> Just occName-            _ -> Nothing-          _ -> Nothing-        )-    . concatMap Constructor.fields-    . Type.constructors--makeHsImplicitBndrs-  :: Ghc.SrcSpan-  -> Type.Type-  -> Ghc.ModuleName-  -> Ghc.OccName-  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)-makeHsImplicitBndrs srcSpan type_ moduleName className =-  let-    withoutContext = makeLHsType srcSpan moduleName className type_-    context = makeHsContext srcSpan moduleName className type_-    withContext = if null context-      then withoutContext-      else Ghc.L srcSpan-        $ Ghc.HsQualTy Ghc.noExtField (Ghc.L srcSpan context) withoutContext-  in Ghc.HsIB Ghc.noExtField withContext---- | Makes a random variable name using the given prefix.-makeRandomVariable :: Ghc.SrcSpan -> String -> Ghc.Hsc (Ghc.LIdP Ghc.GhcPs)-makeRandomVariable srcSpan prefix = do-  n <- bumpCounter-  pure . Ghc.L srcSpan . Ghc.Unqual . Ghc.mkVarOcc $ Printf.printf-    "%s%d"-    prefix-    n---- | Makes a random module name. This will convert any periods to underscores--- and add a unique suffix.------ >>> makeRandomModule "Data.Aeson"--- "Data_Aeson_1"-makeRandomModule :: Ghc.ModuleName -> Ghc.Hsc Ghc.ModuleName-makeRandomModule moduleName = do-  n <- bumpCounter-  pure . Ghc.mkModuleName $ Printf.printf-    "%s_%d"-    (underscoreAll moduleName)-    n--underscoreAll :: Ghc.ModuleName -> String-underscoreAll = fmap underscoreOne . Ghc.moduleNameString--underscoreOne :: Char -> Char-underscoreOne c = case c of-  '.' -> '_'-  _ -> c--makeInstanceDeclaration-  :: Ghc.SrcSpan-  -> Type.Type-  -> Ghc.ModuleName-  -> Ghc.OccName-  -> [Ghc.LHsBind Ghc.GhcPs]-  -> Ghc.LHsDecl Ghc.GhcPs-makeInstanceDeclaration srcSpan type_ moduleName occName lHsBinds =-  let hsImplicitBndrs = makeHsImplicitBndrs srcSpan type_ moduleName occName-  in makeLHsDecl srcSpan hsImplicitBndrs lHsBinds--makeLHsDecl-  :: Ghc.SrcSpan-  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)-  -> [Ghc.LHsBind Ghc.GhcPs]-  -> Ghc.LHsDecl Ghc.GhcPs-makeLHsDecl srcSpan hsImplicitBndrs lHsBinds =-  Ghc.L srcSpan-    . Ghc.InstD Ghc.noExtField-    . Ghc.ClsInstD Ghc.noExtField-    $ Ghc.ClsInstDecl-        Ghc.noExtField-        hsImplicitBndrs-        (Ghc.listToBag lHsBinds)-        []-        []-        []-        Nothing--makeLHsBind-  :: Ghc.SrcSpan-  -> Ghc.OccName-  -> [Ghc.LPat Ghc.GhcPs]-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsBind Ghc.GhcPs-makeLHsBind srcSpan occName pats =-  Hs.funBind srcSpan occName . makeMatchGroup srcSpan occName pats--makeMatchGroup-  :: Ghc.SrcSpan-  -> Ghc.OccName-  -> [Ghc.LPat Ghc.GhcPs]-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-makeMatchGroup srcSpan occName lPats hsExpr = Ghc.MG-  Ghc.noExtField-  (Ghc.L srcSpan [Ghc.L srcSpan $ makeMatch srcSpan occName lPats hsExpr])-  Ghc.Generated--makeMatch-  :: Ghc.SrcSpan-  -> Ghc.OccName-  -> [Ghc.LPat Ghc.GhcPs]-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-makeMatch srcSpan occName lPats =-  Ghc.Match-      Ghc.noExtField-      (Ghc.FunRhs-        (Ghc.L srcSpan $ Ghc.Unqual occName)-        Ghc.Prefix-        Ghc.NoSrcStrict-      )-      lPats-    . makeGRHSs srcSpan--makeGRHSs-  :: Ghc.SrcSpan-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-makeGRHSs srcSpan hsExpr =-  Ghc.GRHSs Ghc.noExtField [Hs.grhs srcSpan hsExpr]-    . Ghc.L srcSpan-    $ Ghc.EmptyLocalBinds Ghc.noExtField--bumpCounter :: IO.MonadIO m => m Word-bumpCounter = IO.liftIO . IORef.atomicModifyIORef' counterRef $ \ n -> (n + 1, n)--counterRef :: IORef.IORef Word-counterRef = Unsafe.unsafePerformIO $ IORef.newIORef 0-{-# NOINLINE counterRef #-}
− src/lib/Evoke/Generator/FromJSON.hs 
@@ -1,120 +0,0 @@-module Evoke.Generator.FromJSON-  ( generate-  ) where--import qualified Data.List as List-import qualified Evoke.Constant.Module as Module-import qualified Evoke.Generator.Common as Common-import qualified Evoke.Hs as Hs-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Options as Options-import qualified Evoke.Type.Constructor as Constructor-import qualified Evoke.Type.Field as Field-import qualified Evoke.Type.Type as Type-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--generate :: Common.Generator-generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do-  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan-  constructor <- case Type.constructors type_ of-    [x] -> pure x-    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"-  modifyFieldName <--    Common.applyAll-      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan--  fields <--    mapM (fromField srcSpan modifyFieldName)-    . List.sortOn Field.name-    . concatMap Constructor.fields-    $ Type.constructors type_--  applicative <- Common.makeRandomModule Module.controlApplicative-  aeson <- Common.makeRandomModule Module.dataAeson-  text <- Common.makeRandomModule Module.dataText-  object <- Common.makeRandomVariable srcSpan "object_"-  let-    lImportDecls = Hs.importDecls-      srcSpan-      [ (Module.controlApplicative, applicative)-      , (Module.dataAeson, aeson)-      , (Module.dataText, text)-      ]--    bindStmts = fmap-      (\(field, (name, var)) ->-        Hs.bindStmt srcSpan (Hs.varPat srcSpan var)-          . Hs.opApp-              srcSpan-              (Hs.var srcSpan object)-              (Hs.qualVar srcSpan aeson-              . Ghc.mkVarOcc-              $ if Field.isOptional field then ".:?" else ".:"-              )-          . Hs.app srcSpan (Hs.qualVar srcSpan text $ Ghc.mkVarOcc "pack")-          . Hs.lit srcSpan-          $ Hs.string name-      )-      fields--    lastStmt =-      Hs.lastStmt srcSpan-        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")-        . Hs.recordCon srcSpan (Ghc.L srcSpan $ Constructor.name constructor)-        . Hs.recFields-        $ fmap-            (\(field, (_, var)) ->-              Hs.recField-                  srcSpan-                  (Hs.fieldOcc srcSpan . Hs.unqual srcSpan $ Field.name field)-                $ Hs.var srcSpan var-            )-            fields--    lHsBind =-      Common.makeLHsBind srcSpan (Ghc.mkVarOcc "parseJSON") []-        . Hs.app-            srcSpan-            (Hs.app-                srcSpan-                (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "withObject")-            . Hs.lit srcSpan-            . Hs.string-            $ Type.qualifiedName moduleName type_-            )-        . Hs.par srcSpan-        . Hs.lam srcSpan-        . Hs.mg-        $ Ghc.L-            srcSpan-            [ Hs.match srcSpan Ghc.LambdaExpr [Hs.varPat srcSpan object]-                $ Hs.grhss-                    srcSpan-                    [ Hs.grhs srcSpan-                      . Hs.doExpr srcSpan-                      $ bindStmts-                      <> [lastStmt]-                    ]-            ]--    lHsDecl = Common.makeInstanceDeclaration-      srcSpan-      type_-      aeson-      (Ghc.mkClsOcc "FromJSON")-      [lHsBind]--  pure (lImportDecls, [lHsDecl])--fromField-  :: Ghc.SrcSpan-  -> (String -> Ghc.Hsc String)-  -> Field.Field-  -> Ghc.Hsc (Field.Field, (String, Ghc.LIdP Ghc.GhcPs))-fromField srcSpan modifyFieldName field = do-  let fieldName = Field.name field-  name <- modifyFieldName $ Ghc.occNameString fieldName-  var <- Common.makeRandomVariable srcSpan . (<> "_") $ Ghc.occNameString-    fieldName-  pure (field, (name, var))
− src/lib/Evoke/Generator/ToJSON.hs 
@@ -1,93 +0,0 @@-module Evoke.Generator.ToJSON-  ( generate-  ) where--import qualified Data.List as List-import qualified Evoke.Constant.Module as Module-import qualified Evoke.Generator.Common as Common-import qualified Evoke.Hs as Hs-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Options as Options-import qualified Evoke.Type.Constructor as Constructor-import qualified Evoke.Type.Field as Field-import qualified Evoke.Type.Type as Type-import qualified GhcPlugins as Ghc--generate :: Common.Generator-generate _ lIdP lHsQTyVars lConDecls options srcSpan = do-  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan-  case Type.constructors type_ of-    [_] -> pure ()-    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"--  modifyFieldName <--    Common.applyAll-      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan--  fieldNames <--    mapM (fromField modifyFieldName)-    . List.sort-    . fmap Field.name-    . concatMap Constructor.fields-    $ Type.constructors type_--  aeson <- Common.makeRandomModule Module.dataAeson-  monoid <- Common.makeRandomModule Module.dataMonoid-  text <- Common.makeRandomModule Module.dataText-  var1 <- Common.makeRandomVariable srcSpan "var_"-  var2 <- Common.makeRandomVariable srcSpan "var_"-  let-    lImportDecls = Hs.importDecls-      srcSpan-      [ (Module.dataAeson, aeson)-      , (Module.dataMonoid, monoid)-      , (Module.dataText, text)-      ]--    toPair lRdrName (occName, fieldName) =-      Hs.opApp-          srcSpan-          (Hs.app srcSpan (Hs.qualVar srcSpan text $ Ghc.mkVarOcc "pack")-          . Hs.lit srcSpan-          $ Hs.string fieldName-          )-          (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc ".=")-        . Hs.app srcSpan (Hs.var srcSpan $ Hs.unqual srcSpan occName)-        $ Hs.var srcSpan lRdrName--    lHsExprs lRdrName = fmap (toPair lRdrName) fieldNames--    toJSON =-      Common.makeLHsBind-          srcSpan-          (Ghc.mkVarOcc "toJSON")-          [Hs.varPat srcSpan var1]-        . Hs.app srcSpan (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "object")-        . Hs.explicitList srcSpan-        $ lHsExprs var1--    toEncoding =-      Common.makeLHsBind-          srcSpan-          (Ghc.mkVarOcc "toEncoding")-          [Hs.varPat srcSpan var2]-        . Hs.app srcSpan (Hs.qualVar srcSpan aeson $ Ghc.mkVarOcc "pairs")-        . Hs.par srcSpan-        . Hs.app srcSpan (Hs.qualVar srcSpan monoid $ Ghc.mkVarOcc "mconcat")-        . Hs.explicitList srcSpan-        $ lHsExprs var2--    lHsDecl = Common.makeInstanceDeclaration-      srcSpan-      type_-      aeson-      (Ghc.mkClsOcc "ToJSON")-      [toJSON, toEncoding]--  pure (lImportDecls, [lHsDecl])--fromField-  :: (String -> Ghc.Hsc String) -> Ghc.OccName -> Ghc.Hsc (Ghc.OccName, String)-fromField modifyFieldName occName = do-  fieldName <- modifyFieldName $ Ghc.occNameString occName-  pure (occName, fieldName)
− src/lib/Evoke/Generator/ToSchema.hs 
@@ -1,183 +0,0 @@-module Evoke.Generator.ToSchema-  ( generate-  ) where--import qualified Data.List as List-import qualified Evoke.Constant.Module as Module-import qualified Evoke.Generator.Common as Common-import qualified Evoke.Hs as Hs-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Options as Options-import qualified Evoke.Type.Constructor as Constructor-import qualified Evoke.Type.Field as Field-import qualified Evoke.Type.Type as Type-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--generate :: Common.Generator-generate moduleName lIdP lHsQTyVars lConDecls options srcSpan = do-  type_ <- Type.make lIdP lHsQTyVars lConDecls srcSpan-  case Type.constructors type_ of-    [_] -> pure ()-    _ -> Hsc.throwError srcSpan $ Ghc.text "requires exactly one constructor"--  modifyFieldName <--    Common.applyAll-      <$> Options.parse (Common.fieldNameOptions srcSpan) options srcSpan--  fields <--    mapM (fromField srcSpan modifyFieldName)-    . List.sortOn Field.name-    . concatMap Constructor.fields-    $ Type.constructors type_--  applicative <- Common.makeRandomModule Module.controlApplicative-  lens <- Common.makeRandomModule Module.controlLens-  hashMap <- Common.makeRandomModule Module.dataHashMapStrictInsOrd-  dataMaybe <- Common.makeRandomModule Module.dataMaybe-  monoid <- Common.makeRandomModule Module.dataMonoid-  proxy <- Common.makeRandomModule Module.dataProxy-  swagger <- Common.makeRandomModule Module.dataSwagger-  text <- Common.makeRandomModule Module.dataText-  ignored <- Common.makeRandomVariable srcSpan "_proxy_"-  let-    lImportDecls = Hs.importDecls-      srcSpan-      [ (Module.controlApplicative, applicative)-      , (Module.controlLens, lens)-      , (Module.dataHashMapStrictInsOrd, hashMap)-      , (Module.dataMaybe, dataMaybe)-      , (Module.dataMonoid, monoid)-      , (Module.dataProxy, proxy)-      , (Module.dataSwagger, swagger)-      , (Module.dataText, text)-      ]--    toBind field var =-      Hs.bindStmt srcSpan (Hs.varPat srcSpan var)-        . Hs.app-            srcSpan-            (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "declareSchemaRef")-        . Hs.par srcSpan-        . Ghc.L srcSpan-        . Ghc.ExprWithTySig-            Ghc.noExtField-            (Hs.qualVar srcSpan proxy $ Ghc.mkDataOcc "Proxy")-        . Ghc.HsWC Ghc.noExtField-        . Ghc.HsIB Ghc.noExtField-        . Ghc.L srcSpan-        . Ghc.HsAppTy-            Ghc.noExtField-            (Hs.qualTyVar srcSpan proxy $ Ghc.mkClsOcc "Proxy")-        . Ghc.L srcSpan-        . Ghc.HsParTy Ghc.noExtField-        . Ghc.L srcSpan-        $ Field.type_ field -- TODO: This requires `ScopedTypeVariables`.--    bindStmts = fmap (\((field, _), var) -> toBind field var) fields--    setType =-      Hs.opApp-          srcSpan-          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "type_")-          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc "?~")-        . Hs.qualVar srcSpan swagger-        $ Ghc.mkDataOcc "SwaggerObject"--    setProperties =-      Hs.opApp-          srcSpan-          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "properties")-          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc ".~")-        . Hs.app srcSpan (Hs.qualVar srcSpan hashMap $ Ghc.mkVarOcc "fromList")-        . Hs.explicitList srcSpan-        $ fmap-            (\((_, name), var) -> Hs.explicitTuple srcSpan $ fmap-              (Hs.tupArg srcSpan)-              [ Hs.app srcSpan (Hs.qualVar srcSpan text $ Ghc.mkVarOcc "pack")-              . Hs.lit srcSpan-              $ Hs.string name-              , Hs.var srcSpan var-              ]-            )-            fields--    setRequired =-      Hs.opApp-          srcSpan-          (Hs.qualVar srcSpan swagger $ Ghc.mkVarOcc "required")-          (Hs.qualVar srcSpan lens $ Ghc.mkVarOcc ".~")-        . Hs.explicitList srcSpan-        . fmap-            (Hs.app srcSpan (Hs.qualVar srcSpan text $ Ghc.mkVarOcc "pack")-            . Hs.lit srcSpan-            . Hs.string-            . snd-            . fst-            )-        $ filter (not . Field.isOptional . fst . fst) fields--    lastStmt =-      Hs.lastStmt srcSpan-        . Hs.app srcSpan (Hs.qualVar srcSpan applicative $ Ghc.mkVarOcc "pure")-        . Hs.par srcSpan-        . Hs.app-            srcSpan-            (Hs.app-                srcSpan-                (Hs.qualVar srcSpan swagger $ Ghc.mkDataOcc "NamedSchema")-            . Hs.par srcSpan-            . Hs.app-                srcSpan-                (Hs.qualVar srcSpan dataMaybe $ Ghc.mkDataOcc "Just")-            . Hs.par srcSpan-            . Hs.app srcSpan (Hs.qualVar srcSpan text $ Ghc.mkVarOcc "pack")-            . Hs.lit srcSpan-            . Hs.string-            $ Type.qualifiedName moduleName type_-            )-        . Hs.par srcSpan-        . makePipeline srcSpan lens [setType, setProperties, setRequired]-        . Hs.qualVar srcSpan monoid-        $ Ghc.mkVarOcc "mempty"--    lHsBind =-      Common.makeLHsBind-          srcSpan-          (Ghc.mkVarOcc "declareNamedSchema")-          [Hs.varPat srcSpan ignored]-        . Hs.doExpr srcSpan-        $ bindStmts-        <> [lastStmt]--    lHsDecl = Common.makeInstanceDeclaration-      srcSpan-      type_-      swagger-      (Ghc.mkClsOcc "ToSchema")-      [lHsBind]--  pure (lImportDecls, [lHsDecl])--fromField-  :: Ghc.SrcSpan-  -> (String -> Ghc.Hsc String)-  -> Field.Field-  -> Ghc.Hsc ((Field.Field, String), Ghc.LIdP Ghc.GhcPs)-fromField srcSpan modifyFieldName field = do-  let fieldName = Field.name field-  name <- modifyFieldName $ Ghc.occNameString fieldName-  var <- Common.makeRandomVariable srcSpan . (<> "_") $ Ghc.occNameString-    fieldName-  pure ((field, name), var)--makePipeline-  :: Ghc.SrcSpan-  -> Ghc.ModuleName-  -> [Ghc.LHsExpr Ghc.GhcPs]-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-makePipeline srcSpan m es e = case es of-  [] -> e-  h : t -> makePipeline srcSpan m t-    $ Hs.opApp srcSpan e (Hs.qualVar srcSpan m $ Ghc.mkVarOcc "&") h
− src/lib/Evoke/Hs.hs 
@@ -1,198 +0,0 @@-module Evoke.Hs-  ( app-  , bindStmt-  , doExpr-  , explicitList-  , explicitTuple-  , fieldOcc-  , funBind-  , grhs-  , grhss-  , importDecls-  , lam-  , lastStmt-  , lit-  , match-  , mg-  , opApp-  , par-  , qual-  , qualTyVar-  , qualVar-  , recField-  , recFields-  , recordCon-  , string-  , tupArg-  , tyVar-  , unqual-  , var-  , varPat-  ) where--import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc-import qualified TcEvidence as Ghc--app-  :: Ghc.SrcSpan-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-app s f = Ghc.L s . Ghc.HsApp Ghc.noExtField f--bindStmt-  :: Ghc.SrcSpan-  -> Ghc.LPat Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-bindStmt s p e =-  Ghc.L s $ Ghc.BindStmt Ghc.noExtField p e noSyntaxExpr noSyntaxExpr--doExpr :: Ghc.SrcSpan -> [Ghc.ExprLStmt Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs-doExpr s = Ghc.L s . Ghc.HsDo Ghc.noExtField Ghc.DoExpr . Ghc.L s--explicitList-  :: Ghc.SrcSpan -> [Ghc.LHsExpr Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs-explicitList s = Ghc.L s . Ghc.ExplicitList Ghc.noExtField Nothing--explicitTuple-  :: Ghc.SrcSpan -> [Ghc.LHsTupArg Ghc.GhcPs] -> Ghc.LHsExpr Ghc.GhcPs-explicitTuple s xs = Ghc.L s $ Ghc.ExplicitTuple Ghc.noExtField xs Ghc.Boxed--fieldOcc :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LFieldOcc Ghc.GhcPs-fieldOcc s = Ghc.L s . Ghc.FieldOcc Ghc.noExtField--funBind-  :: Ghc.SrcSpan-  -> Ghc.OccName-  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-  -> Ghc.LHsBind Ghc.GhcPs-funBind s f g =-  Ghc.L s $ Ghc.FunBind Ghc.noExtField (unqual s f) g Ghc.WpHole []--grhs-  :: Ghc.SrcSpan-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-grhs s = Ghc.L s . Ghc.GRHS Ghc.noExtField []--grhss-  :: Ghc.SrcSpan-  -> [Ghc.LGRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]-  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-grhss s xs =-  Ghc.GRHSs Ghc.noExtField xs . Ghc.L s $ Ghc.EmptyLocalBinds Ghc.noExtField--importDecl-  :: Ghc.SrcSpan-  -> Ghc.ModuleName-  -> Ghc.ModuleName-  -> Ghc.LImportDecl Ghc.GhcPs-importDecl s m n = Ghc.L s $ Ghc.ImportDecl-  Ghc.noExtField-  Ghc.NoSourceText-  (Ghc.L s m)-  Nothing-  False-  False-  Ghc.QualifiedPre-  False-  (Just $ Ghc.L s n)-  Nothing--importDecls-  :: Ghc.SrcSpan-  -> [(Ghc.ModuleName, Ghc.ModuleName)]-  -> [Ghc.LImportDecl Ghc.GhcPs]-importDecls = fmap . uncurry . importDecl--lam-  :: Ghc.SrcSpan-  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-  -> Ghc.LHsExpr Ghc.GhcPs-lam s = Ghc.L s . Ghc.HsLam Ghc.noExtField--lastStmt-  :: Ghc.SrcSpan-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LStmt Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-lastStmt s e = Ghc.L s $ Ghc.LastStmt Ghc.noExtField e False noSyntaxExpr--lit :: Ghc.SrcSpan -> Ghc.HsLit Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs-lit s = Ghc.L s . Ghc.HsLit Ghc.noExtField--noSyntaxExpr :: Ghc.SyntaxExpr Ghc.GhcPs-noSyntaxExpr = Ghc.SyntaxExpr Ghc.noExpr [] Ghc.WpHole--match-  :: Ghc.SrcSpan-  -> Ghc.HsMatchContext Ghc.RdrName-  -> [Ghc.LPat Ghc.GhcPs]-  -> Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-  -> Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-match s c ps = Ghc.L s . Ghc.Match Ghc.noExtField c ps--mg-  :: Ghc.Located [Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]-  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-mg ms = Ghc.MG Ghc.noExtField ms Ghc.Generated--opApp-  :: Ghc.SrcSpan-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-opApp s l o = Ghc.L s . Ghc.OpApp Ghc.noExtField l o--par :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs-par s = Ghc.L s . Ghc.HsPar Ghc.noExtField--qual :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs-qual s m = Ghc.L s . Ghc.mkRdrQual m--qualTyVar-  :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsType Ghc.GhcPs-qualTyVar s m = tyVar s . qual s m--qualVar-  :: Ghc.SrcSpan -> Ghc.ModuleName -> Ghc.OccName -> Ghc.LHsExpr Ghc.GhcPs-qualVar s m = var s . qual s m--recFields-  :: [Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]-  -> Ghc.HsRecFields Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-recFields = flip Ghc.HsRecFields Nothing--recField-  :: Ghc.SrcSpan-  -> Ghc.LFieldOcc Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-  -> Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)-recField s f e = Ghc.L s $ Ghc.HsRecField f e False--recordCon-  :: Ghc.SrcSpan-  -> Ghc.LIdP Ghc.GhcPs-  -> Ghc.HsRecordBinds Ghc.GhcPs-  -> Ghc.LHsExpr Ghc.GhcPs-recordCon s c = Ghc.L s . Ghc.RecordCon Ghc.noExtField c--string :: String -> Ghc.HsLit Ghc.GhcPs-string = Ghc.HsString Ghc.NoSourceText . Ghc.mkFastString--tupArg :: Ghc.SrcSpan -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsTupArg Ghc.GhcPs-tupArg s = Ghc.L s . Ghc.Present Ghc.noExtField--tyVar :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs-tyVar s = Ghc.L s . Ghc.HsTyVar Ghc.noExtField Ghc.NotPromoted--unqual :: Ghc.SrcSpan -> Ghc.OccName -> Ghc.LIdP Ghc.GhcPs-unqual s = Ghc.L s . Ghc.mkRdrUnqual--var :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs-var s = Ghc.L s . Ghc.HsVar Ghc.noExtField--varPat :: Ghc.SrcSpan -> Ghc.LIdP Ghc.GhcPs -> Ghc.LPat Ghc.GhcPs-varPat s = Ghc.L s . Ghc.VarPat Ghc.noExtField
− src/lib/Evoke/Hsc.hs 
@@ -1,25 +0,0 @@-module Evoke.Hsc-  ( addWarning-  , throwError-  ) where--import qualified Bag as Ghc-import qualified Control.Monad.IO.Class as IO-import qualified ErrUtils as Ghc-import qualified GhcPlugins as Ghc---- | Adds a warning, which only causes compilation to fail if @-Werror@ is--- enabled.-addWarning :: Ghc.SrcSpan -> Ghc.MsgDoc -> Ghc.Hsc ()-addWarning srcSpan msgDoc = do-  dynFlags <- Ghc.getDynFlags-  IO.liftIO-    . Ghc.printOrThrowWarnings dynFlags-    . Ghc.unitBag-    $ Ghc.mkPlainWarnMsg dynFlags srcSpan msgDoc---- | Throws an error, which will cause compilation to fail.-throwError :: Ghc.SrcSpan -> Ghc.MsgDoc -> Ghc.Hsc a-throwError srcSpan msgDoc = do-  dynFlags <- Ghc.getDynFlags-  Ghc.throwOneError $ Ghc.mkPlainErrMsg dynFlags srcSpan msgDoc
− src/lib/Evoke/Options.hs 
@@ -1,39 +0,0 @@-module Evoke.Options-  ( parse-  ) where--import qualified Control.Monad as Monad-import qualified Evoke.Hsc as Hsc-import qualified GhcPlugins as Ghc-import qualified System.Console.GetOpt as Console---- | Parses command line options. Adds warnings and throws errors as--- appropriate. Returns the list of parsed options.-parse :: [Console.OptDescr a] -> [String] -> Ghc.SrcSpan -> Ghc.Hsc [a]-parse optDescrs strings srcSpan = do-  let-    (xs, args, opts, errs) = Console.getOpt' Console.Permute optDescrs strings-  Monad.forM_ opts-    $ Hsc.addWarning srcSpan-    . Ghc.text-    . mappend "unknown option: "-    . quote-  Monad.forM_ args-    $ Hsc.addWarning srcSpan-    . Ghc.text-    . mappend "unexpected argument: "-    . quote-  Monad.unless (null errs)-    . Hsc.throwError srcSpan-    . Ghc.vcat-    . fmap Ghc.text-    . lines-    $ mconcat errs-  pure xs---- | Quotes a string using GHC's weird quoting format.------ >>> quote "thing"--- "`thing'"-quote :: String -> String-quote string = "`" <> string <> "'"
− src/lib/Evoke/Type/Config.hs 
@@ -1,26 +0,0 @@-module Evoke.Type.Config-  ( Config(..)-  , fromFlags-  ) where--import qualified Data.List as List-import qualified Evoke.Type.Flag as Flag--data Config = Config-  { help :: Bool-  , verbose :: Bool-  , version :: Bool-  }-  deriving (Eq, Show)--initial :: Config-initial = Config { help = False, verbose = False, version = False }--fromFlags :: Foldable t => t Flag.Flag -> Config-fromFlags = List.foldl' applyFlag initial--applyFlag :: Config -> Flag.Flag -> Config-applyFlag config flag = case flag of-  Flag.Help -> config { help = True }-  Flag.Verbose -> config { verbose = True }-  Flag.Version -> config { version = True }
− src/lib/Evoke/Type/Constructor.hs 
@@ -1,31 +0,0 @@-module Evoke.Type.Constructor-  ( Constructor(..)-  , make-  ) where--import qualified Control.Monad as Monad-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Type.Field as Field-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--data Constructor = Constructor-  { name :: Ghc.IdP Ghc.GhcPs-  , fields :: [Field.Field]-  }--make :: Ghc.SrcSpan -> Ghc.LConDecl Ghc.GhcPs -> Ghc.Hsc Constructor-make srcSpan lConDecl = do-  (lIdP, hsConDeclDetails) <- case Ghc.unLoc lConDecl of-    Ghc.ConDeclH98 _ x _ _ _ y _ -> pure (x, y)-    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LConDecl"-  lConDeclFields <- case hsConDeclDetails of-    Ghc.RecCon x -> pure x-    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported HsConDeclDetails"-  theFields <--    fmap concat . Monad.forM (Ghc.unLoc lConDeclFields) $ \lConDeclField -> do-      (lFieldOccs, lHsType) <- case Ghc.unLoc lConDeclField of-        Ghc.ConDeclField _ x y _ -> pure (x, y)-        _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LConDeclField"-      mapM (Field.make srcSpan lHsType) lFieldOccs-  pure Constructor { name = Ghc.unLoc lIdP, fields = theFields }
− src/lib/Evoke/Type/Field.hs 
@@ -1,37 +0,0 @@-module Evoke.Type.Field-  ( Field(..)-  , make-  , isOptional-  ) where--import qualified Evoke.Hsc as Hsc-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--data Field = Field-  { name :: Ghc.OccName-  , type_ :: Ghc.HsType Ghc.GhcPs-  }--make-  :: Ghc.SrcSpan-  -> Ghc.LHsType Ghc.GhcPs-  -> Ghc.LFieldOcc Ghc.GhcPs-  -> Ghc.Hsc Field-make srcSpan lHsType lFieldOcc = do-  lRdrName <- case Ghc.unLoc lFieldOcc of-    Ghc.FieldOcc _ x -> pure x-    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LFieldOcc"-  occName <- case Ghc.unLoc lRdrName of-    Ghc.Unqual x -> pure x-    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported RdrName"-  pure Field { name = occName, type_ = Ghc.unLoc lHsType }--isOptional :: Field -> Bool-isOptional field = case type_ field of-  Ghc.HsAppTy _ lHsType _ -> case Ghc.unLoc lHsType of-    Ghc.HsTyVar _ _ lIdP -> case Ghc.unLoc lIdP of-      Ghc.Unqual occName -> Ghc.occNameString occName == "Maybe"-      _ -> False-    _ -> False-  _ -> False
− src/lib/Evoke/Type/Flag.hs 
@@ -1,31 +0,0 @@-module Evoke.Type.Flag-  ( Flag(..)-  , options-  ) where--import qualified System.Console.GetOpt as Console--data Flag-  = Help-  | Verbose-  | Version-  deriving (Eq, Show)--options :: [Console.OptDescr Flag]-options =-  [ Console.Option-    ['h', '?']-    ["help"]-    (Console.NoArg Help)-    "shows this help message and exits"-  , Console.Option-    ['v']-    ["version"]-    (Console.NoArg Version)-    "shows the version number and exits"-  , Console.Option-    []-    ["verbose"]-    (Console.NoArg Verbose)-    "outputs derived instances"-  ]
− src/lib/Evoke/Type/Type.hs 
@@ -1,45 +0,0 @@-module Evoke.Type.Type-  ( Type(..)-  , make-  , qualifiedName-  ) where--import qualified Control.Monad as Monad-import qualified Evoke.Hsc as Hsc-import qualified Evoke.Type.Constructor as Constructor-import qualified GHC.Hs as Ghc-import qualified GhcPlugins as Ghc--data Type = Type-  { name :: Ghc.IdP Ghc.GhcPs-  , variables :: [Ghc.IdP Ghc.GhcPs]-  , constructors :: [Constructor.Constructor]-  }--make-  :: Ghc.LIdP Ghc.GhcPs-  -> Ghc.LHsQTyVars Ghc.GhcPs-  -> [Ghc.LConDecl Ghc.GhcPs]-  -> Ghc.SrcSpan-  -> Ghc.Hsc Type-make lIdP lHsQTyVars lConDecls srcSpan = do-  lHsTyVarBndrs <- case lHsQTyVars of-    Ghc.HsQTvs _ hsq_explicit -> pure hsq_explicit-    _ -> Hsc.throwError srcSpan $ Ghc.text "unsupported LHsQTyVars"-  theVariables <- Monad.forM lHsTyVarBndrs $ \lHsTyVarBndr ->-    case Ghc.unLoc lHsTyVarBndr of-      Ghc.UserTyVar _ var -> pure $ Ghc.unLoc var-      _ -> Hsc.throwError srcSpan $ Ghc.text "unknown LHsTyVarBndr"-  theConstructors <- mapM (Constructor.make srcSpan) lConDecls-  pure Type-    { name = Ghc.unLoc lIdP-    , variables = theVariables-    , constructors = theConstructors-    }--qualifiedName :: Ghc.ModuleName -> Type -> String-qualifiedName moduleName type_ = mconcat-  [ Ghc.moduleNameString moduleName-  , "."-  , Ghc.occNameString . Ghc.rdrNameOcc $ name type_-  ]
− src/test/Main.hs 
@@ -1,193 +0,0 @@-{-# OPTIONS_GHC -fplugin=Evoke #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}--import qualified Data.Aeson as Aeson-import qualified Data.Aeson.QQ.Simple as Aeson-import qualified Data.Proxy as Proxy-import qualified Data.Swagger as Swagger-import qualified Test.HUnit as Unit-import qualified Test.QuickCheck as QuickCheck--main :: IO ()-main = Unit.runTestTTAndExit $ Unit.test-  [ testToJSON T1C1 { t1c1f1 = 1 } [Aeson.aesonQQ| { "t1c1f1": 1 } |]-  , testToJSON-    T2C1 { t2c1f1 = 2, t2c1f2 = 3 }-    [Aeson.aesonQQ| { "t2c1f1": 2, "t2c1f2": 3 } |]-  , testToJSON T3C1 { t3c1f1aA = 4 } [Aeson.aesonQQ| { "t3c1f1a_a": 4 } |]-  , testToJSON T4C1 { t4c1f1aA = 5 } [Aeson.aesonQQ| { "t4c1f1a-a": 5 } |]-  , testToJSON T5C1 { t5c1f1 = 6 } [Aeson.aesonQQ| { "T5c1f1": 6 } |]-  , testToJSON T6C1 { t6c1f1 = 7 } [Aeson.aesonQQ| { "f1": 7 } |]-  , testToJSON T7C1 { t7c1f1 = 8 } [Aeson.aesonQQ| { "F1": 8 } |]-  , testToJSON T8C1 { t8c1f1 = 9 } [Aeson.aesonQQ| { "f1": 9 } |]-  , testToJSON-    (T9C1 { t9c1f1 = 10 } :: T9 X)-    [Aeson.aesonQQ| { "t9c1f1": 10 } |]-  , testToJSON-    T10C1 { t10c1f1 = 11 :: Int }-    [Aeson.aesonQQ| { "t10c1f1": 11 } |]-  , testToJSON T11C1 { t11c1f1A = 12 } [Aeson.aesonQQ| { "a": 12 } |]-  , testToJSON-    (T12C1 { t12c1f1 = 13, t12c1f2 = 14 } :: T12 X Int X Int X)-    [Aeson.aesonQQ| { "t12c1f1": 13, "t12c1f2": 14 } |]-  , testToJSON-    T13C1 { t13c1f1 = 15, t13c1f2 = 16 }-    [Aeson.aesonQQ| { "t13c1f1": 15, "t13c1f2": 16 } |]-  , testToJSON T14C1 { t14c1f1 = Just 17 } [Aeson.aesonQQ| { "t14c1f1": 17 } |]-  , testToJSON T15C1 { t15c1f1 = 18 } [Aeson.aesonQQ| { "t15c1": 18 } |]-  , testToJSON T16C1 { t16c1f1 = 19 } [Aeson.aesonQQ| { "one": 19 } |]-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T1)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T2)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T3)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T4)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T5)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T6)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T7)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T8)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T9 X))-  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T10 Int))-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T11)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy (T12 X Int X Int X))-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T13)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T14)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T15)-  , checkInstances (Proxy.Proxy :: Proxy.Proxy T16)-  ]--checkInstances-  :: ( QuickCheck.Arbitrary a-     , Eq a-     , Aeson.FromJSON a-     , Show a-     , Aeson.ToJSON a-     , Swagger.ToSchema a-     )-  => Proxy.Proxy a-  -> Unit.Test-checkInstances proxy = Unit.TestCase $ do-  value <- QuickCheck.generate QuickCheck.arbitrary-  Aeson.decode (Aeson.encode value) Unit.@?= Just value-  let json = Aeson.toJSON $ Proxy.asProxyTypeOf value proxy-  Aeson.fromJSON json Unit.@?= Aeson.Success value-  Swagger.validateJSON mempty (Swagger.toSchema proxy) json Unit.@?= []--testToJSON :: Aeson.ToJSON a => a -> Aeson.Value -> Unit.Test-testToJSON = (Unit.~?=) . Aeson.toJSON---- custom void type with no instances-data X---- one field-newtype T1 = T1C1-  { t1c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- multiple fields-data T2 = T2C1-  { t2c1f1 :: Int-  , t2c1f2 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- snake case-newtype T3 = T3C1-  { t3c1f1aA :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --snake"---- kebab case-newtype T4 = T4C1-  { t4c1f1aA :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --kebab"---- capitalized-newtype T5 = T5C1-  { t5c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --title"---- stripped prefix-newtype T6 = T6C1-  { t6c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t6c1"---- stripped then capitalized-newtype T7 = T7C1-  { t7c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t7c1 --title"---- capitalized then stripped-newtype T8 = T8C1-  { t8c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --title --prefix T8c1"---- phantom type-newtype T9 a = T9C1-  { t9c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- type variable-newtype T10 a = T10C1-  { t10c1f1 :: a-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- lower cased-newtype T11 = T11C1-  { t11c1f1A :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --prefix t11c1f1 --camel"---- multiple type variables-data T12 a b c d e = T12C1-  { t12c1f1 :: d-  , t12c1f2 :: b-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- multiple fields with one signature-data T13 = T13C1-  { t13c1f1, t13c1f2 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- optional field-newtype T14 = T14C1-  { t14c1f1 :: Maybe Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke"---- stripped suffix-newtype T15 = T15C1-  { t15c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --suffix f1"---- renamed-newtype T16 = T16C1-  { t16c1f1 :: Int-  }-  deriving (Eq, Show)-  deriving (Arbitrary, FromJSON, ToJSON, ToSchema) via "Evoke --rename t16c1f1:one"