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)