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 :: Generator
generate ModuleName
moduleName LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
options SrcSpan
srcSpan = do
  Type
type_ <- LIdP GhcPs
-> LHsQTyVars GhcPs -> [LConDecl GhcPs] -> SrcSpan -> Hsc Type
Type.make LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls SrcSpan
srcSpan
  case Type -> [Constructor]
Type.constructors Type
type_ of
    [Constructor
_] -> () -> Hsc ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Constructor]
_ -> SrcSpan -> MsgDoc -> Hsc ()
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc ()) -> MsgDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"requires exactly one constructor"

  String -> Hsc String
modifyFieldName <-
    [String -> Hsc String] -> String -> Hsc String
forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
Common.applyAll
      ([String -> Hsc String] -> String -> Hsc String)
-> Hsc [String -> Hsc String] -> Hsc (String -> Hsc String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OptDescr (String -> Hsc String)]
-> [String] -> SrcSpan -> Hsc [String -> Hsc String]
forall a. [OptDescr a] -> [String] -> SrcSpan -> Hsc [a]
Options.parse (SrcSpan -> [OptDescr (String -> Hsc String)]
Common.fieldNameOptions SrcSpan
srcSpan) [String]
options SrcSpan
srcSpan

  [((Field, String), Located RdrName)]
fields <-
    (Field -> Hsc ((Field, String), Located RdrName))
-> [Field] -> Hsc [((Field, String), Located RdrName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> (String -> Hsc String)
-> Field
-> Hsc ((Field, String), LIdP GhcPs)
fromField SrcSpan
srcSpan String -> Hsc String
modifyFieldName)
    ([Field] -> Hsc [((Field, String), Located RdrName)])
-> ([Constructor] -> [Field])
-> [Constructor]
-> Hsc [((Field, String), Located RdrName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> OccName) -> [Field] -> [Field]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Field -> OccName
Field.name
    ([Field] -> [Field])
-> ([Constructor] -> [Field]) -> [Constructor] -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constructor -> [Field]) -> [Constructor] -> [Field]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
    ([Constructor] -> Hsc [((Field, String), Located RdrName)])
-> [Constructor] -> Hsc [((Field, String), Located RdrName)]
forall a b. (a -> b) -> a -> b
$ Type -> [Constructor]
Type.constructors Type
type_

  ModuleName
applicative <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.controlApplicative
  ModuleName
lens <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.controlLens
  ModuleName
hashMap <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataHashMapStrictInsOrd
  ModuleName
dataMaybe <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataMaybe
  ModuleName
monoid <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataMonoid
  ModuleName
proxy <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataProxy
  ModuleName
swagger <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataSwagger
  ModuleName
text <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataText
  Located RdrName
ignored <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan String
"_proxy_"
  let
    lImportDecls :: [LImportDecl GhcPs]
lImportDecls = SrcSpan -> [(ModuleName, ModuleName)] -> [LImportDecl GhcPs]
Hs.importDecls
      SrcSpan
srcSpan
      [ (ModuleName
Module.controlApplicative, ModuleName
applicative)
      , (ModuleName
Module.controlLens, ModuleName
lens)
      , (ModuleName
Module.dataHashMapStrictInsOrd, ModuleName
hashMap)
      , (ModuleName
Module.dataMaybe, ModuleName
dataMaybe)
      , (ModuleName
Module.dataMonoid, ModuleName
monoid)
      , (ModuleName
Module.dataProxy, ModuleName
proxy)
      , (ModuleName
Module.dataSwagger, ModuleName
swagger)
      , (ModuleName
Module.dataText, ModuleName
text)
      ]

    toBind :: Field -> Located RdrName -> LStmt GhcPs (LHsExpr GhcPs)
toBind Field
field Located RdrName
var =
      SrcSpan
-> LPat GhcPs -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.bindStmt SrcSpan
srcSpan (SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan LIdP GhcPs
Located RdrName
var)
        (LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs))
-> (HsType GhcPs -> LHsExpr GhcPs)
-> HsType GhcPs
-> LStmt GhcPs (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app
            SrcSpan
srcSpan
            (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"declareSchemaRef")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsType GhcPs -> LHsExpr GhcPs) -> HsType GhcPs -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsType GhcPs -> LHsExpr GhcPs) -> HsType GhcPs -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsExpr GhcPs -> LHsExpr GhcPs)
-> (HsType GhcPs -> HsExpr GhcPs) -> HsType GhcPs -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
Ghc.ExprWithTySig
            NoExtField
XExprWithTySig GhcPs
Ghc.noExtField
            (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
proxy (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"Proxy")
        (HsWildCardBndrs
   GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
 -> HsExpr GhcPs)
-> (HsType GhcPs
    -> HsWildCardBndrs
         GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))))
-> HsType GhcPs
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsWC
  GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
-> HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))
-> HsWildCardBndrs
     GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
Ghc.HsWC NoExtField
XHsWC
  GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
Ghc.noExtField
        (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))
 -> HsWildCardBndrs
      GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))))
-> (HsType GhcPs
    -> HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
-> HsType GhcPs
-> HsWildCardBndrs
     GhcPs (HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsIB GhcPs (GenLocated SrcSpan (HsType GhcPs))
-> GenLocated SrcSpan (HsType GhcPs)
-> HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))
forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
Ghc.HsIB NoExtField
XHsIB GhcPs (GenLocated SrcSpan (HsType GhcPs))
Ghc.noExtField
        (GenLocated SrcSpan (HsType GhcPs)
 -> HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs)))
-> (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs
-> HsImplicitBndrs GhcPs (GenLocated SrcSpan (HsType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> (HsType GhcPs -> HsType GhcPs)
-> HsType GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XAppTy GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
-> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
            NoExtField
XAppTy GhcPs
Ghc.noExtField
            (SrcSpan
-> ModuleName -> OccName -> GenLocated SrcSpan (HsType GhcPs)
Hs.qualTyVar SrcSpan
srcSpan ModuleName
proxy (OccName -> GenLocated SrcSpan (HsType GhcPs))
-> OccName -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkClsOcc String
"Proxy")
        (GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> (HsType GhcPs -> HsType GhcPs)
-> HsType GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XParTy GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
Ghc.HsParTy NoExtField
XParTy GhcPs
Ghc.noExtField
        (GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsType GhcPs -> LStmt GhcPs (LHsExpr GhcPs))
-> HsType GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Field -> HsType GhcPs
Field.type_ Field
field -- TODO: This requires `ScopedTypeVariables`.

    bindStmts :: [LStmt GhcPs (LHsExpr GhcPs)]
bindStmts = (((Field, String), Located RdrName) -> LStmt GhcPs (LHsExpr GhcPs))
-> [((Field, String), Located RdrName)]
-> [LStmt GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Field
field, String
_), Located RdrName
var) -> Field -> Located RdrName -> LStmt GhcPs (LHsExpr GhcPs)
toBind Field
field Located RdrName
var) [((Field, String), Located RdrName)]
fields

    setType :: LHsExpr GhcPs
setType =
      SrcSpan
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.opApp
          SrcSpan
srcSpan
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"type_")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"?~")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger
        (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"SwaggerObject"

    setProperties :: LHsExpr GhcPs
setProperties =
      SrcSpan
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.opApp
          SrcSpan
srcSpan
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"properties")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
".~")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
hashMap (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"fromList")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LHsExpr GhcPs] -> LHsExpr GhcPs
Hs.explicitList SrcSpan
srcSpan
        ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (((Field, String), Located RdrName) -> LHsExpr GhcPs)
-> [((Field, String), Located RdrName)] -> [LHsExpr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\((Field
_, String
name), Located RdrName
var) -> SrcSpan -> [LHsTupArg GhcPs] -> LHsExpr GhcPs
Hs.explicitTuple SrcSpan
srcSpan ([LHsTupArg GhcPs] -> LHsExpr GhcPs)
-> [LHsTupArg GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> LHsTupArg GhcPs)
-> [LHsExpr GhcPs] -> [LHsTupArg GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              (SrcSpan -> LHsExpr GhcPs -> LHsTupArg GhcPs
Hs.tupArg SrcSpan
srcSpan)
              [ SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
text (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pack")
              (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsLit GhcPs -> LHsExpr GhcPs) -> HsLit GhcPs -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
              (HsLit GhcPs -> LHsExpr GhcPs) -> HsLit GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> HsLit GhcPs
Hs.string String
name
              , SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan LIdP GhcPs
Located RdrName
var
              ]
            )
            [((Field, String), Located RdrName)]
fields

    setRequired :: LHsExpr GhcPs
setRequired =
      SrcSpan
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.opApp
          SrcSpan
srcSpan
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"required")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
".~")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> ([((Field, String), Located RdrName)] -> LHsExpr GhcPs)
-> [((Field, String), Located RdrName)]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LHsExpr GhcPs] -> LHsExpr GhcPs
Hs.explicitList SrcSpan
srcSpan
        ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> ([((Field, String), Located RdrName)] -> [LHsExpr GhcPs])
-> [((Field, String), Located RdrName)]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Field, String), Located RdrName) -> LHsExpr GhcPs)
-> [((Field, String), Located RdrName)] -> [LHsExpr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
text (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pack")
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (((Field, String), Located RdrName) -> LHsExpr GhcPs)
-> ((Field, String), Located RdrName)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
            (HsLit GhcPs -> LHsExpr GhcPs)
-> (((Field, String), Located RdrName) -> HsLit GhcPs)
-> ((Field, String), Located RdrName)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
Hs.string
            (String -> HsLit GhcPs)
-> (((Field, String), Located RdrName) -> String)
-> ((Field, String), Located RdrName)
-> HsLit GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field, String) -> String
forall a b. (a, b) -> b
snd
            ((Field, String) -> String)
-> (((Field, String), Located RdrName) -> (Field, String))
-> ((Field, String), Located RdrName)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Field, String), Located RdrName) -> (Field, String)
forall a b. (a, b) -> a
fst
            )
        ([((Field, String), Located RdrName)] -> LHsExpr GhcPs)
-> [((Field, String), Located RdrName)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (((Field, String), Located RdrName) -> Bool)
-> [((Field, String), Located RdrName)]
-> [((Field, String), Located RdrName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (((Field, String), Located RdrName) -> Bool)
-> ((Field, String), Located RdrName)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Bool
Field.isOptional (Field -> Bool)
-> (((Field, String), Located RdrName) -> Field)
-> ((Field, String), Located RdrName)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field, String) -> Field
forall a b. (a, b) -> a
fst ((Field, String) -> Field)
-> (((Field, String), Located RdrName) -> (Field, String))
-> ((Field, String), Located RdrName)
-> Field
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Field, String), Located RdrName) -> (Field, String)
forall a b. (a, b) -> a
fst) [((Field, String), Located RdrName)]
fields

    lastStmt :: LStmt GhcPs (LHsExpr GhcPs)
lastStmt =
      SrcSpan -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.lastStmt SrcSpan
srcSpan
        (LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs))
-> (OccName -> LHsExpr GhcPs)
-> OccName
-> LStmt GhcPs (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
applicative (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pure")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app
            SrcSpan
srcSpan
            (SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app
                SrcSpan
srcSpan
                (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"NamedSchema")
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app
                SrcSpan
srcSpan
                (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
dataMaybe (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"Just")
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
text (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pack")
            (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
            (HsLit GhcPs -> LHsExpr GhcPs)
-> (String -> HsLit GhcPs) -> String -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
Hs.string
            (String -> LHsExpr GhcPs) -> String -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ModuleName -> Type -> String
Type.qualifiedName ModuleName
moduleName Type
type_
            )
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> ModuleName -> [LHsExpr GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
makePipeline SrcSpan
srcSpan ModuleName
lens [LHsExpr GhcPs
setType, LHsExpr GhcPs
setProperties, LHsExpr GhcPs
setRequired]
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
monoid
        (OccName -> LStmt GhcPs (LHsExpr GhcPs))
-> OccName -> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"mempty"

    lHsBind :: LHsBind GhcPs
lHsBind =
      SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind
          SrcSpan
srcSpan
          (String -> OccName
Ghc.mkVarOcc String
"declareNamedSchema")
          [SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan LIdP GhcPs
Located RdrName
ignored]
        (LHsExpr GhcPs -> LHsBind GhcPs)
-> ([LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
Hs.doExpr SrcSpan
srcSpan
        ([LStmt GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$ [LStmt GhcPs (LHsExpr GhcPs)]
bindStmts
        [LStmt GhcPs (LHsExpr GhcPs)]
-> [LStmt GhcPs (LHsExpr GhcPs)] -> [LStmt GhcPs (LHsExpr GhcPs)]
forall a. Semigroup a => a -> a -> a
<> [LStmt GhcPs (LHsExpr GhcPs)
lastStmt]

    lHsDecl :: LHsDecl GhcPs
lHsDecl = SrcSpan
-> Type
-> ModuleName
-> OccName
-> [LHsBind GhcPs]
-> LHsDecl GhcPs
Common.makeInstanceDeclaration
      SrcSpan
srcSpan
      Type
type_
      ModuleName
swagger
      (String -> OccName
Ghc.mkClsOcc String
"ToSchema")
      [LHsBind GhcPs
lHsBind]

  ([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LImportDecl GhcPs]
lImportDecls, [LHsDecl GhcPs
lHsDecl])

fromField
  :: Ghc.SrcSpan
  -> (String -> Ghc.Hsc String)
  -> Field.Field
  -> Ghc.Hsc ((Field.Field, String), Ghc.LIdP Ghc.GhcPs)
fromField :: SrcSpan
-> (String -> Hsc String)
-> Field
-> Hsc ((Field, String), LIdP GhcPs)
fromField SrcSpan
srcSpan String -> Hsc String
modifyFieldName Field
field = do
  let fieldName :: OccName
fieldName = Field -> OccName
Field.name Field
field
  String
name <- String -> Hsc String
modifyFieldName (String -> Hsc String) -> String -> Hsc String
forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString OccName
fieldName
  Located RdrName
var <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan (String -> Hsc (Located RdrName))
-> (String -> String) -> String -> Hsc (Located RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_") (String -> Hsc (Located RdrName))
-> String -> Hsc (Located RdrName)
forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString
    OccName
fieldName
  ((Field, String), Located RdrName)
-> Hsc ((Field, String), Located RdrName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Field
field, String
name), Located RdrName
var)

makePipeline
  :: Ghc.SrcSpan
  -> Ghc.ModuleName
  -> [Ghc.LHsExpr Ghc.GhcPs]
  -> Ghc.LHsExpr Ghc.GhcPs
  -> Ghc.LHsExpr Ghc.GhcPs
makePipeline :: SrcSpan
-> ModuleName -> [LHsExpr GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
makePipeline SrcSpan
srcSpan ModuleName
m [LHsExpr GhcPs]
es LHsExpr GhcPs
e = case [LHsExpr GhcPs]
es of
  [] -> LHsExpr GhcPs
e
  LHsExpr GhcPs
h : [LHsExpr GhcPs]
t -> SrcSpan
-> ModuleName -> [LHsExpr GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
makePipeline SrcSpan
srcSpan ModuleName
m [LHsExpr GhcPs]
t
    (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.opApp SrcSpan
srcSpan LHsExpr GhcPs
e (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
m (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"&") LHsExpr GhcPs
h