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))