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 :: 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
  Constructor
constructor <- case Type -> [Constructor]
Type.constructors Type
type_ of
    [Constructor
x] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor
x
    [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
aeson <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataAeson
  ModuleName
string <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataString
  GenLocated SrcSpanAnnN RdrName
object <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan String
"object_"
  let lImportDecls :: [LImportDecl GhcPs]
lImportDecls =
        SrcSpan -> [(ModuleName, ModuleName)] -> [LImportDecl GhcPs]
Hs.importDecls
          SrcSpan
srcSpan
          [ (ModuleName
Module.controlApplicative, ModuleName
applicative),
            (ModuleName
Module.dataAeson, ModuleName
aeson),
            (ModuleName
Module.dataString, ModuleName
string)
          ]

      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
name, 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 -> LHsExpr GhcPs
Hs.opApp
                  SrcSpan
srcSpan
                  (SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
object)
                  ( SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
aeson
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
Ghc.mkVarOcc
                      forall a b. (a -> b) -> a -> b
$ if Field -> Bool
Field.isOptional Field
field then String
".:?" else 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
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
          )
          [(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 -> LIdP GhcPs -> HsRecordBinds GhcPs -> LHsExpr GhcPs
Hs.recordCon SrcSpan
srcSpan (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
$ Constructor -> IdP GhcPs
Constructor.name Constructor
constructor)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsRecordBinds GhcPs
Hs.recFields
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(Field
field, (String
_, GenLocated SrcSpanAnnN RdrName
var)) ->
                SrcSpan
-> LFieldOcc GhcPs
-> LHsExpr GhcPs
-> LHsRecField GhcPs (LHsExpr GhcPs)
Hs.recField
                  SrcSpan
srcSpan
                  (SrcSpan -> LIdP GhcPs -> LFieldOcc GhcPs
Hs.fieldOcc SrcSpan
srcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> OccName -> LIdP GhcPs
Hs.unqual SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ Field -> OccName
Field.name Field
field)
                  forall a b. (a -> b) -> a -> b
$ SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var
            )
            [(Field, (String, GenLocated SrcSpanAnnN RdrName))]
fields

      lHsBind :: GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lHsBind =
        SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind SrcSpan
srcSpan (String -> OccName
Ghc.mkVarOcc String
"parseJSON") []
          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
aeson forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"withObject")
                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 -> MatchGroup GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
Hs.lam SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
Hs.mg
          forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
Ghc.L
            SrcSpan
srcSpan
            [ SrcSpan
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
Hs.match SrcSpan
srcSpan forall p. HsMatchContext p
Ghc.LambdaExpr [SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
object] forall a b. (a -> b) -> a -> b
$
                SrcSpan
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> GRHSs GhcPs (LHsExpr GhcPs)
Hs.grhss
                  SrcSpan
srcSpan
                  [ SrcSpan -> LHsExpr GhcPs -> LGRHS GhcPs (LHsExpr GhcPs)
Hs.grhs SrcSpan
srcSpan
                      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
aeson
          (String -> OccName
Ghc.mkClsOcc String
"FromJSON")
          [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))