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 :: Generator
generate 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

  [(OccName, String)]
fieldNames <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Hsc String) -> OccName -> Hsc (OccName, String)
fromField String -> Hsc String
modifyFieldName)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
List.sort
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
aeson <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataAeson
  ModuleName
monoid <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataMonoid
  ModuleName
string <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataString
  GenLocated SrcSpanAnnN RdrName
var1 <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan String
"var_"
  GenLocated SrcSpanAnnN RdrName
var2 <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan String
"var_"
  let lImportDecls :: [LImportDecl GhcPs]
lImportDecls =
        SrcSpan -> [(ModuleName, ModuleName)] -> [LImportDecl GhcPs]
Hs.importDecls
          SrcSpan
srcSpan
          [ (ModuleName
Module.dataAeson, ModuleName
aeson),
            (ModuleName
Module.dataMonoid, ModuleName
monoid),
            (ModuleName
Module.dataString, ModuleName
string)
          ]

      toPair :: GenLocated SrcSpanAnnN RdrName
-> (OccName, String) -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
toPair GenLocated SrcSpanAnnN RdrName
lRdrName (OccName
occName, String
fieldName) =
        SrcSpan
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.opApp
          SrcSpan
srcSpan
          ( 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
fieldName
          )
          (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
aeson 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 -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ SrcSpan -> OccName -> LIdP GhcPs
Hs.unqual SrcSpan
srcSpan OccName
occName)
          forall a b. (a -> b) -> a -> b
$ SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
lRdrName

      lHsExprs :: GenLocated SrcSpanAnnN RdrName
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
lHsExprs GenLocated SrcSpanAnnN RdrName
lRdrName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenLocated SrcSpanAnnN RdrName
-> (OccName, String) -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
toPair GenLocated SrcSpanAnnN RdrName
lRdrName) [(OccName, String)]
fieldNames

      toJSON :: GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toJSON =
        SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind
          SrcSpan
srcSpan
          (String -> OccName
Ghc.mkVarOcc String
"toJSON")
          [SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var1]
          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
aeson forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"object")
          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
$ GenLocated SrcSpanAnnN RdrName
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
lHsExprs GenLocated SrcSpanAnnN RdrName
var1

      toEncoding :: GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toEncoding =
        SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind
          SrcSpan
srcSpan
          (String -> OccName
Ghc.mkVarOcc String
"toEncoding")
          [SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var2]
          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
aeson forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pairs")
          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
monoid forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"mconcat")
          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
$ GenLocated SrcSpanAnnN RdrName
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
lHsExprs GenLocated SrcSpanAnnN RdrName
var2

      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
"ToJSON")
          [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toJSON, GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toEncoding]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)
lHsDecl])

fromField ::
  (String -> Ghc.Hsc String) -> Ghc.OccName -> Ghc.Hsc (Ghc.OccName, String)
fromField :: (String -> Hsc String) -> OccName -> Hsc (OccName, String)
fromField String -> Hsc String
modifyFieldName OccName
occName = do
  String
fieldName <- String -> Hsc String
modifyFieldName forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString OccName
occName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (OccName
occName, String
fieldName)