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 :: 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] -> Constructor -> Hsc Constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor
x
    [Constructor]
_ -> SrcSpan -> MsgDoc -> Hsc Constructor
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc Constructor) -> MsgDoc -> Hsc Constructor
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
aeson <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataAeson
  ModuleName
text <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataText
  Located 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.dataText, ModuleName
text)
      ]

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

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