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 :: 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
_] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Constructor]
_ -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ String -> SDoc
Ghc.text String
"requires exactly one constructor"

  String -> Hsc String
modifyFieldName <-
    forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
Common.applyAll
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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), GenLocated SrcSpanAnnN RdrName)]
fields <-
    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)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Field -> OccName
Field.name
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
      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
string <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataString
  ModuleName
swagger <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataSwagger
  GenLocated SrcSpanAnnN 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.dataString, ModuleName
string),
            (ModuleName
Module.dataSwagger, ModuleName
swagger)
          ]

      toBind :: Field
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
toBind Field
field GenLocated SrcSpanAnnN RdrName
var =
        SrcSpan
-> LPat GhcPs -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.bindStmt SrcSpan
srcSpan (SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var)
          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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"declareSchemaRef")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
Ghc.ExprWithTySig
            forall a. EpAnn a
Ghc.noAnn
            (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
proxy forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"Proxy")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
Ghc.HsWC NoExtField
Ghc.noExtField
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
Ghc.HsSig NoExtField
Ghc.noExtField forall flag. HsOuterTyVarBndrs flag GhcPs
Ghc.mkHsOuterImplicit
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
            NoExtField
Ghc.noExtField
            (SrcSpan -> ModuleName -> OccName -> LHsType GhcPs
Hs.qualTyVar SrcSpan
srcSpan ModuleName
proxy forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkClsOcc String
"Proxy")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XParTy pass -> LHsType pass -> HsType pass
Ghc.HsParTy forall a. EpAnn a
Ghc.noAnn
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall a b. (a -> b) -> a -> b
$ Field -> HsType GhcPs
Field.type_ Field
field -- TODO: This requires `ScopedTypeVariables`.
      bindStmts :: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindStmts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Field
field, String
_), GenLocated SrcSpanAnnN RdrName
var) -> Field
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
toBind Field
field GenLocated SrcSpanAnnN RdrName
var) [((Field, String), GenLocated SrcSpanAnnN RdrName)]
fields

      setType :: GenLocated SrcSpanAnnA (HsExpr 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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"type_")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"?~")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
swagger
          forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"SwaggerObject"

      setProperties :: GenLocated SrcSpanAnnA (HsExpr 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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"properties")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
".~")
          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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"fromList")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LHsExpr GhcPs] -> LHsExpr GhcPs
Hs.explicitList SrcSpan
srcSpan
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \((Field
_, String
name), GenLocated SrcSpanAnnN RdrName
var) ->
                SrcSpan -> [HsTupArg GhcPs] -> LHsExpr GhcPs
Hs.explicitTuple SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    LHsExpr GhcPs -> HsTupArg GhcPs
Hs.tupArg
                    [ SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
string forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"fromString")
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
                        forall a b. (a -> b) -> a -> b
$ String -> HsLit GhcPs
Hs.string String
name,
                      SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var
                    ]
            )
            [((Field, String), GenLocated SrcSpanAnnN RdrName)]
fields

      setRequired :: GenLocated SrcSpanAnnA (HsExpr 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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"required")
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
lens forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
".~")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LHsExpr GhcPs] -> LHsExpr GhcPs
Hs.explicitList SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
string forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"fromString")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
Hs.string
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
            )
          forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Bool
Field.isOptional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Field, String), GenLocated SrcSpanAnnN RdrName)]
fields

      lastStmt :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lastStmt =
        SrcSpan -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.lastStmt SrcSpan
srcSpan
          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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pure")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
          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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"NamedSchema")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
                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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkDataOcc String
"Just")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
                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
string forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"fromString")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLit GhcPs -> LHsExpr GhcPs
Hs.lit SrcSpan
srcSpan
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
Hs.string
                forall a b. (a -> b) -> a -> b
$ ModuleName -> Type -> String
Type.qualifiedName ModuleName
moduleName Type
type_
            )
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.par SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> ModuleName -> [LHsExpr GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
makePipeline SrcSpan
srcSpan ModuleName
lens [GenLocated SrcSpanAnnA (HsExpr GhcPs)
setType, GenLocated SrcSpanAnnA (HsExpr GhcPs)
setProperties, GenLocated SrcSpanAnnA (HsExpr GhcPs)
setRequired]
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
monoid
          forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"mempty"

      lHsBind :: GenLocated SrcSpanAnnA (HsBindLR GhcPs 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 GenLocated SrcSpanAnnN RdrName
ignored]
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
Hs.doExpr SrcSpan
srcSpan
          forall a b. (a -> b) -> a -> b
$ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindStmts
            forall a. Semigroup a => a -> a -> a
<> [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr 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")
          [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lHsBind]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl 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 forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString OccName
fieldName
  GenLocated SrcSpanAnnN RdrName
var <-
    SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> String
"_") forall a b. (a -> b) -> a -> b
$
      OccName -> String
Ghc.occNameString
        OccName
fieldName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Field
field, String
name), GenLocated SrcSpanAnnN 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 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 forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"&") LHsExpr GhcPs
h