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 GhcPlugins 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
_] -> () -> 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

  [(OccName, String)]
fieldNames <-
    (OccName -> Hsc (OccName, String))
-> [OccName] -> Hsc [(OccName, String)]
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)
    ([OccName] -> Hsc [(OccName, String)])
-> ([Constructor] -> [OccName])
-> [Constructor]
-> Hsc [(OccName, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OccName] -> [OccName]
forall a. Ord a => [a] -> [a]
List.sort
    ([OccName] -> [OccName])
-> ([Constructor] -> [OccName]) -> [Constructor] -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> OccName) -> [Field] -> [OccName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field -> OccName
Field.name
    ([Field] -> [OccName])
-> ([Constructor] -> [Field]) -> [Constructor] -> [OccName]
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 [(OccName, String)])
-> [Constructor] -> Hsc [(OccName, String)]
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
text <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.dataText
  Located RdrName
var1 <- SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan String
"var_"
  Located 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.dataText, ModuleName
text)
      ]

    toPair :: Located RdrName -> (OccName, String) -> LHsExpr GhcPs
toPair Located 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
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
fieldName
          )
          (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
".=")
        (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 -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan (LIdP GhcPs -> LHsExpr GhcPs) -> LIdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> OccName -> LIdP GhcPs
Hs.unqual SrcSpan
srcSpan OccName
occName)
        (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan LIdP GhcPs
Located RdrName
lRdrName

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

    toJSON :: LHsBind 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 LIdP GhcPs
Located RdrName
var1]
        (LHsExpr GhcPs -> LHsBind GhcPs)
-> ([LHsExpr GhcPs] -> LHsExpr 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 -> 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
"object")
        (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] -> LHsBind GhcPs)
-> [LHsExpr GhcPs] -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$ Located RdrName -> [LHsExpr GhcPs]
lHsExprs Located RdrName
var1

    toEncoding :: LHsBind 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 LIdP GhcPs
Located RdrName
var2]
        (LHsExpr GhcPs -> LHsBind GhcPs)
-> ([LHsExpr GhcPs] -> LHsExpr 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 -> 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
"pairs")
        (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.par SrcSpan
srcSpan
        (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
monoid (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"mconcat")
        (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] -> LHsBind GhcPs)
-> [LHsExpr GhcPs] -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$ Located RdrName -> [LHsExpr GhcPs]
lHsExprs Located 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")
      [LHsBind GhcPs
toJSON, LHsBind GhcPs
toEncoding]

  ([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
  :: (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 (String -> Hsc String) -> String -> Hsc String
forall a b. (a -> b) -> a -> b
$ OccName -> String
Ghc.occNameString OccName
occName
  (OccName, String) -> Hsc (OccName, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OccName
occName, String
fieldName)