yesod-dsl 0.2.0 → 0.2.1
raw patch · 76 files changed
+1181/−376 lines, 76 filesdep +hscolourPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: hscolour
API changes (from Hackage documentation)
- YesodDsl.AST: AndExpr :: BoolExpr -> BoolExpr -> BoolExpr
- YesodDsl.AST: CeilingExpr :: ValExpr -> ValExpr
- YesodDsl.AST: ExtractExpr :: FieldName -> ValExpr -> ValExpr
- YesodDsl.AST: FloorExpr :: ValExpr -> ValExpr
- YesodDsl.AST: NotExpr :: BoolExpr -> BoolExpr
- YesodDsl.AST: OrExpr :: BoolExpr -> BoolExpr -> BoolExpr
- YesodDsl.AST: RandomExpr :: ValExpr
- YesodDsl.AST: SelectValExpr :: ValExpr -> VariableName -> SelectField
- YesodDsl.AST: ValBinOpExpr :: ValExpr -> ValBinOp -> ValExpr -> ValExpr
- YesodDsl.AST: classFields :: Class -> [Field]
- YesodDsl.AST: classLoc :: Class -> Location
- YesodDsl.AST: className :: Class -> String
- YesodDsl.AST: classUniques :: Class -> [Unique]
- YesodDsl.AST: data BoolExpr
- YesodDsl.AST: data ValBinOp
- YesodDsl.AST: data ValExpr
- YesodDsl.AST: entityChecks :: Entity -> [FunctionName]
- YesodDsl.AST: entityClassFields :: Entity -> [Field]
- YesodDsl.AST: entityDeriving :: Entity -> [ClassName]
- YesodDsl.AST: entityFields :: Entity -> [Field]
- YesodDsl.AST: entityInstances :: Entity -> [ClassName]
- YesodDsl.AST: entityLoc :: Entity -> Location
- YesodDsl.AST: entityName :: Entity -> String
- YesodDsl.AST: entityTable :: Entity -> Maybe String
- YesodDsl.AST: entityUniques :: Entity -> [Unique]
- YesodDsl.AST: enumLoc :: EnumType -> Location
- YesodDsl.AST: enumName :: EnumType -> String
- YesodDsl.AST: enumValues :: EnumType -> [String]
- YesodDsl.AST: fieldClassName :: Field -> Maybe (ClassName, FieldName)
- YesodDsl.AST: fieldContent :: Field -> FieldContent
- YesodDsl.AST: fieldLoc :: Field -> Location
- YesodDsl.AST: fieldName :: Field -> FieldName
- YesodDsl.AST: fieldOptional :: Field -> Bool
- YesodDsl.AST: fieldOptions :: Field -> [FieldOption]
- YesodDsl.AST: handlerLoc :: Handler -> Location
- YesodDsl.AST: handlerStmts :: Handler -> [Stmt]
- YesodDsl.AST: handlerType :: Handler -> HandlerType
- YesodDsl.AST: importFunctions :: Import -> [FunctionName]
- YesodDsl.AST: importModule :: Import -> String
- YesodDsl.AST: instance Data BinOp
- YesodDsl.AST: instance Data BoolExpr
- YesodDsl.AST: instance Data CheckmarkValue
- YesodDsl.AST: instance Data Class
- YesodDsl.AST: instance Data Entity
- YesodDsl.AST: instance Data EnumType
- YesodDsl.AST: instance Data Field
- YesodDsl.AST: instance Data FieldContent
- YesodDsl.AST: instance Data FieldOption
- YesodDsl.AST: instance Data FieldRef
- YesodDsl.AST: instance Data FieldType
- YesodDsl.AST: instance Data FieldValue
- YesodDsl.AST: instance Data FunctionParam
- YesodDsl.AST: instance Data Handler
- YesodDsl.AST: instance Data HandlerType
- YesodDsl.AST: instance Data Import
- YesodDsl.AST: instance Data Join
- YesodDsl.AST: instance Data JoinType
- YesodDsl.AST: instance Data Location
- YesodDsl.AST: instance Data Module
- YesodDsl.AST: instance Data PathPiece
- YesodDsl.AST: instance Data Route
- YesodDsl.AST: instance Data SelectField
- YesodDsl.AST: instance Data SelectQuery
- YesodDsl.AST: instance Data SortDir
- YesodDsl.AST: instance Data Stmt
- YesodDsl.AST: instance Data Unique
- YesodDsl.AST: instance Data ValBinOp
- YesodDsl.AST: instance Data ValExpr
- YesodDsl.AST: instance Data VariableRef
- YesodDsl.AST: instance Eq BinOp
- YesodDsl.AST: instance Eq BoolExpr
- YesodDsl.AST: instance Eq CheckmarkValue
- YesodDsl.AST: instance Eq Class
- YesodDsl.AST: instance Eq Entity
- YesodDsl.AST: instance Eq EnumType
- YesodDsl.AST: instance Eq Field
- YesodDsl.AST: instance Eq FieldContent
- YesodDsl.AST: instance Eq FieldOption
- YesodDsl.AST: instance Eq FieldRef
- YesodDsl.AST: instance Eq FieldType
- YesodDsl.AST: instance Eq FieldValue
- YesodDsl.AST: instance Eq FunctionParam
- YesodDsl.AST: instance Eq Handler
- YesodDsl.AST: instance Eq HandlerType
- YesodDsl.AST: instance Eq Join
- YesodDsl.AST: instance Eq JoinType
- YesodDsl.AST: instance Eq Location
- YesodDsl.AST: instance Eq PathPiece
- YesodDsl.AST: instance Eq Route
- YesodDsl.AST: instance Eq SelectField
- YesodDsl.AST: instance Eq SelectQuery
- YesodDsl.AST: instance Eq SortDir
- YesodDsl.AST: instance Eq Stmt
- YesodDsl.AST: instance Eq Unique
- YesodDsl.AST: instance Eq ValBinOp
- YesodDsl.AST: instance Eq ValExpr
- YesodDsl.AST: instance Eq VariableRef
- YesodDsl.AST: instance Ord CheckmarkValue
- YesodDsl.AST: instance Ord FieldValue
- YesodDsl.AST: instance Show BinOp
- YesodDsl.AST: instance Show BoolExpr
- YesodDsl.AST: instance Show CheckmarkValue
- YesodDsl.AST: instance Show Class
- YesodDsl.AST: instance Show Entity
- YesodDsl.AST: instance Show EnumType
- YesodDsl.AST: instance Show Field
- YesodDsl.AST: instance Show FieldContent
- YesodDsl.AST: instance Show FieldOption
- YesodDsl.AST: instance Show FieldRef
- YesodDsl.AST: instance Show FieldType
- YesodDsl.AST: instance Show FieldValue
- YesodDsl.AST: instance Show FunctionParam
- YesodDsl.AST: instance Show Handler
- YesodDsl.AST: instance Show HandlerType
- YesodDsl.AST: instance Show Import
- YesodDsl.AST: instance Show Join
- YesodDsl.AST: instance Show JoinType
- YesodDsl.AST: instance Show Location
- YesodDsl.AST: instance Show Module
- YesodDsl.AST: instance Show PathPiece
- YesodDsl.AST: instance Show Route
- YesodDsl.AST: instance Show SelectField
- YesodDsl.AST: instance Show SelectQuery
- YesodDsl.AST: instance Show SortDir
- YesodDsl.AST: instance Show Stmt
- YesodDsl.AST: instance Show Unique
- YesodDsl.AST: instance Show ValBinOp
- YesodDsl.AST: instance Show ValExpr
- YesodDsl.AST: instance Show VariableRef
- YesodDsl.AST: instance Typeable BinOp
- YesodDsl.AST: instance Typeable BoolExpr
- YesodDsl.AST: instance Typeable CheckmarkValue
- YesodDsl.AST: instance Typeable Class
- YesodDsl.AST: instance Typeable Entity
- YesodDsl.AST: instance Typeable EnumType
- YesodDsl.AST: instance Typeable Field
- YesodDsl.AST: instance Typeable FieldContent
- YesodDsl.AST: instance Typeable FieldOption
- YesodDsl.AST: instance Typeable FieldRef
- YesodDsl.AST: instance Typeable FieldType
- YesodDsl.AST: instance Typeable FieldValue
- YesodDsl.AST: instance Typeable FunctionParam
- YesodDsl.AST: instance Typeable Handler
- YesodDsl.AST: instance Typeable HandlerType
- YesodDsl.AST: instance Typeable Import
- YesodDsl.AST: instance Typeable Join
- YesodDsl.AST: instance Typeable JoinType
- YesodDsl.AST: instance Typeable Location
- YesodDsl.AST: instance Typeable Module
- YesodDsl.AST: instance Typeable PathPiece
- YesodDsl.AST: instance Typeable Route
- YesodDsl.AST: instance Typeable SelectField
- YesodDsl.AST: instance Typeable SelectQuery
- YesodDsl.AST: instance Typeable SortDir
- YesodDsl.AST: instance Typeable Stmt
- YesodDsl.AST: instance Typeable Unique
- YesodDsl.AST: instance Typeable ValBinOp
- YesodDsl.AST: instance Typeable ValExpr
- YesodDsl.AST: instance Typeable VariableRef
- YesodDsl.AST: joinAlias :: Join -> VariableName
- YesodDsl.AST: joinEntity :: Join -> EntityRef
- YesodDsl.AST: joinExpr :: Join -> Maybe BoolExpr
- YesodDsl.AST: joinType :: Join -> JoinType
- YesodDsl.AST: modClasses :: Module -> [Class]
- YesodDsl.AST: modEntities :: Module -> [Entity]
- YesodDsl.AST: modEnums :: Module -> [EnumType]
- YesodDsl.AST: modImports :: Module -> [Import]
- YesodDsl.AST: modName :: Module -> Maybe String
- YesodDsl.AST: modRoutes :: Module -> [Route]
- YesodDsl.AST: routeHandlers :: Route -> [Handler]
- YesodDsl.AST: routeLoc :: Route -> Location
- YesodDsl.AST: routePath :: Route -> [PathPiece]
- YesodDsl.AST: sqFields :: SelectQuery -> [SelectField]
- YesodDsl.AST: sqFrom :: SelectQuery -> (EntityRef, VariableName)
- YesodDsl.AST: sqJoins :: SelectQuery -> [Join]
- YesodDsl.AST: sqLimitOffset :: SelectQuery -> (Int, Int)
- YesodDsl.AST: sqOrderBy :: SelectQuery -> [(FieldRef, SortDir)]
- YesodDsl.AST: sqWhere :: SelectQuery -> Maybe BoolExpr
- YesodDsl.AST: uniqueFields :: Unique -> [FieldName]
- YesodDsl.AST: uniqueName :: Unique -> String
- YesodDsl.Generator.Esqueleto: ctxExprListValue :: Context -> Bool
- YesodDsl.Generator.Esqueleto: ctxExprType :: Context -> Maybe String
- YesodDsl.Generator.Esqueleto: ctxNames :: Context -> Map VariableName (Entity, MaybeFlag)
- YesodDsl.Generator.Esqueleto: hsBoolExpr :: BoolExpr -> Reader Context String
- YesodDsl.Generator.Esqueleto: hsValBinOp :: ValBinOp -> String
- YesodDsl.Generator.Esqueleto: hsValExpr :: MaybeLevel -> ValExpr -> Reader Context String
- YesodDsl.Generator.Esqueleto: scopedBoolExpr :: Map VariableName (Entity, MaybeFlag) -> BoolExpr -> String
- YesodDsl.Generator.Esqueleto: selectFieldExprs :: SelectField -> [ValExpr]
- YesodDsl.Lexer: TRandom :: TokenType
- YesodDsl.Lexer: instance Eq AlexPosn
- YesodDsl.Lexer: instance Functor AlexLastAcc
- YesodDsl.Lexer: instance Show AlexPosn
- YesodDsl.Lexer: instance Show Token
- YesodDsl.Lexer: instance Show TokenType
- YesodDsl.Parser: instance Exception ParseError
- YesodDsl.Parser: instance Show ModDef
- YesodDsl.Parser: instance Show ParseError
- YesodDsl.Parser: instance Typeable ParseError
- YesodDsl.ParserState: instance Show (Entity -> ParserMonad ())
- YesodDsl.ParserState: instance Show (Syms -> ParserMonad ())
- YesodDsl.ParserState: instance Show ParserState
- YesodDsl.ParserState: instance Show Sym
- YesodDsl.ParserState: instance Show SymType
+ YesodDsl.AST: And :: BinOp
+ YesodDsl.AST: Ceiling :: UnOp
+ YesodDsl.AST: Extract :: FieldName -> UnOp
+ YesodDsl.AST: FieldReadOnly :: FieldOption
+ YesodDsl.AST: Floor :: UnOp
+ YesodDsl.AST: MapJson :: FunctionName -> Stmt
+ YesodDsl.AST: Not :: UnOp
+ YesodDsl.AST: Or :: BinOp
+ YesodDsl.AST: SelectExpr :: Expr -> VariableName -> SelectField
+ YesodDsl.AST: UnOpExpr :: UnOp -> Expr -> Expr
+ YesodDsl.AST: [classFields] :: Class -> [Field]
+ YesodDsl.AST: [classLoc] :: Class -> Location
+ YesodDsl.AST: [className] :: Class -> String
+ YesodDsl.AST: [classUniques] :: Class -> [Unique]
+ YesodDsl.AST: [entityChecks] :: Entity -> [FunctionName]
+ YesodDsl.AST: [entityClassFields] :: Entity -> [Field]
+ YesodDsl.AST: [entityDeriving] :: Entity -> [ClassName]
+ YesodDsl.AST: [entityFields] :: Entity -> [Field]
+ YesodDsl.AST: [entityInstances] :: Entity -> [ClassName]
+ YesodDsl.AST: [entityLoc] :: Entity -> Location
+ YesodDsl.AST: [entityName] :: Entity -> String
+ YesodDsl.AST: [entityTable] :: Entity -> Maybe String
+ YesodDsl.AST: [entityUniques] :: Entity -> [Unique]
+ YesodDsl.AST: [enumLoc] :: EnumType -> Location
+ YesodDsl.AST: [enumName] :: EnumType -> String
+ YesodDsl.AST: [enumValues] :: EnumType -> [String]
+ YesodDsl.AST: [fieldClassName] :: Field -> Maybe (ClassName, FieldName)
+ YesodDsl.AST: [fieldContent] :: Field -> FieldContent
+ YesodDsl.AST: [fieldLoc] :: Field -> Location
+ YesodDsl.AST: [fieldName] :: Field -> FieldName
+ YesodDsl.AST: [fieldOptional] :: Field -> Bool
+ YesodDsl.AST: [fieldOptions] :: Field -> [FieldOption]
+ YesodDsl.AST: [handlerLoc] :: Handler -> Location
+ YesodDsl.AST: [handlerStmts] :: Handler -> [Stmt]
+ YesodDsl.AST: [handlerType] :: Handler -> HandlerType
+ YesodDsl.AST: [importFunctions] :: Import -> [FunctionName]
+ YesodDsl.AST: [importModule] :: Import -> String
+ YesodDsl.AST: [joinAlias] :: Join -> VariableName
+ YesodDsl.AST: [joinEntity] :: Join -> EntityRef
+ YesodDsl.AST: [joinExpr] :: Join -> Maybe Expr
+ YesodDsl.AST: [joinType] :: Join -> JoinType
+ YesodDsl.AST: [modClasses] :: Module -> [Class]
+ YesodDsl.AST: [modEntities] :: Module -> [Entity]
+ YesodDsl.AST: [modEnums] :: Module -> [EnumType]
+ YesodDsl.AST: [modImports] :: Module -> [Import]
+ YesodDsl.AST: [modName] :: Module -> Maybe String
+ YesodDsl.AST: [modRoutes] :: Module -> [Route]
+ YesodDsl.AST: [routeHandlers] :: Route -> [Handler]
+ YesodDsl.AST: [routeLoc] :: Route -> Location
+ YesodDsl.AST: [routePath] :: Route -> [PathPiece]
+ YesodDsl.AST: [sqFields] :: SelectQuery -> [SelectField]
+ YesodDsl.AST: [sqFrom] :: SelectQuery -> (EntityRef, VariableName)
+ YesodDsl.AST: [sqJoins] :: SelectQuery -> [Join]
+ YesodDsl.AST: [sqLimitOffset] :: SelectQuery -> (Int, Int)
+ YesodDsl.AST: [sqOrderBy] :: SelectQuery -> [OrderBy]
+ YesodDsl.AST: [sqWhere] :: SelectQuery -> Maybe Expr
+ YesodDsl.AST: [uniqueFields] :: Unique -> [FieldName]
+ YesodDsl.AST: [uniqueName] :: Unique -> String
+ YesodDsl.AST: data Expr
+ YesodDsl.AST: data UnOp
+ YesodDsl.AST: fieldReadOnly :: Field -> Bool
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.BinOp
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.CheckmarkValue
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Class
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Entity
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.EnumType
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Expr
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Field
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FieldContent
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FieldOption
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FieldRef
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FieldType
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FieldValue
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.FunctionParam
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Handler
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.HandlerType
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Import
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Join
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.JoinType
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Location
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Module
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.PathPiece
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Route
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.SelectField
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.SelectQuery
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.SortDir
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Stmt
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.UnOp
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.Unique
+ YesodDsl.AST: instance Data.Data.Data YesodDsl.AST.VariableRef
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.BinOp
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.CheckmarkValue
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Class
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Entity
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.EnumType
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Expr
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Field
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FieldContent
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FieldOption
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FieldRef
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FieldType
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FieldValue
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.FunctionParam
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Handler
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.HandlerType
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Join
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.JoinType
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Location
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.PathPiece
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Route
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.SelectField
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.SelectQuery
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.SortDir
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Stmt
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.UnOp
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.Unique
+ YesodDsl.AST: instance GHC.Classes.Eq YesodDsl.AST.VariableRef
+ YesodDsl.AST: instance GHC.Classes.Ord YesodDsl.AST.CheckmarkValue
+ YesodDsl.AST: instance GHC.Classes.Ord YesodDsl.AST.FieldValue
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.BinOp
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.CheckmarkValue
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Class
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Entity
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.EnumType
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Expr
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Field
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FieldContent
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FieldOption
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FieldRef
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FieldType
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FieldValue
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.FunctionParam
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Handler
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.HandlerType
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Import
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Join
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.JoinType
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Location
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Module
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.PathPiece
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Route
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.SelectField
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.SelectQuery
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.SortDir
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Stmt
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.UnOp
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.Unique
+ YesodDsl.AST: instance GHC.Show.Show YesodDsl.AST.VariableRef
+ YesodDsl.AST: type OrderBy = (Maybe FunctionName, [FieldRef], SortDir)
+ YesodDsl.Generator: genHsClient :: FilePath -> Module -> IO ()
+ YesodDsl.Generator: genPureScript :: FilePath -> Module -> IO ()
+ YesodDsl.Generator.Client: handlerInputFields :: Handler -> [(FieldName, Maybe Field)]
+ YesodDsl.Generator.Client: handlerOutputFields :: Module -> Handler -> [Field]
+ YesodDsl.Generator.Client: mkField :: FieldName -> (Bool, FieldContent) -> Field
+ YesodDsl.Generator.Common: isKeyword :: String -> Bool
+ YesodDsl.Generator.Common: prepend :: String -> String -> String
+ YesodDsl.Generator.Common: safeHsName :: String -> String
+ YesodDsl.Generator.Esqueleto: [ctxExprListValue] :: Context -> Bool
+ YesodDsl.Generator.Esqueleto: [ctxExprType] :: Context -> Maybe String
+ YesodDsl.Generator.Esqueleto: [ctxNames] :: Context -> Map VariableName (Entity, MaybeFlag)
+ YesodDsl.Generator.Esqueleto: hsExpr :: MaybeLevel -> Expr -> Reader Context String
+ YesodDsl.Generator.Esqueleto: hsUnOp :: UnOp -> String
+ YesodDsl.Generator.Esqueleto: scopedExpr :: Map VariableName (Entity, MaybeFlag) -> Expr -> String
+ YesodDsl.Generator.HsClient: moduleToHsClient :: Module -> [(FilePath, String)]
+ YesodDsl.Generator.Input: fieldRefMappingToAttrs :: Entity -> Bool -> [FieldRefMapping] -> [(FieldName, Maybe Field)]
+ YesodDsl.Generator.Input: nubAttrs :: [(FieldName, Maybe Field)] -> [(FieldName, Maybe Field)]
+ YesodDsl.Generator.Input: requestAttrs :: Stmt -> [(FieldName, Maybe Field)]
+ YesodDsl.Generator.PureScript: moduleToPureScript :: Module -> String
+ YesodDsl.Generator.PureScript: moduleToPureScriptJs :: Module -> String
+ YesodDsl.Lexer: TMap :: TokenType
+ YesodDsl.Lexer: TReadOnly :: TokenType
+ YesodDsl.Lexer: instance GHC.Base.Functor YesodDsl.Lexer.AlexLastAcc
+ YesodDsl.Lexer: instance GHC.Classes.Eq YesodDsl.Lexer.AlexPosn
+ YesodDsl.Lexer: instance GHC.Show.Show YesodDsl.Lexer.AlexPosn
+ YesodDsl.Lexer: instance GHC.Show.Show YesodDsl.Lexer.Token
+ YesodDsl.Lexer: instance GHC.Show.Show YesodDsl.Lexer.TokenType
+ YesodDsl.Parser: instance GHC.Exception.Exception YesodDsl.Parser.ParseError
+ YesodDsl.Parser: instance GHC.Show.Show YesodDsl.Parser.ModDef
+ YesodDsl.Parser: instance GHC.Show.Show YesodDsl.Parser.ParseError
+ YesodDsl.ParserState: instance GHC.Show.Show (YesodDsl.AST.Entity -> YesodDsl.ParserState.ParserMonad ())
+ YesodDsl.ParserState: instance GHC.Show.Show (YesodDsl.ParserState.Syms -> YesodDsl.ParserState.ParserMonad ())
+ YesodDsl.ParserState: instance GHC.Show.Show YesodDsl.ParserState.ParserState
+ YesodDsl.ParserState: instance GHC.Show.Show YesodDsl.ParserState.Sym
+ YesodDsl.ParserState: instance GHC.Show.Show YesodDsl.ParserState.SymType
- YesodDsl.AST: Add :: ValBinOp
+ YesodDsl.AST: Add :: BinOp
- YesodDsl.AST: BinOpExpr :: ValExpr -> BinOp -> ValExpr -> BoolExpr
+ YesodDsl.AST: BinOpExpr :: Expr -> BinOp -> Expr -> Expr
- YesodDsl.AST: Concat :: ValBinOp
+ YesodDsl.AST: Concat :: BinOp
- YesodDsl.AST: ConcatManyExpr :: [ValExpr] -> ValExpr
+ YesodDsl.AST: ConcatManyExpr :: [Expr] -> Expr
- YesodDsl.AST: DeleteFrom :: EntityRef -> VariableName -> (Maybe BoolExpr) -> Stmt
+ YesodDsl.AST: DeleteFrom :: EntityRef -> VariableName -> (Maybe Expr) -> Stmt
- YesodDsl.AST: Div :: ValBinOp
+ YesodDsl.AST: Div :: BinOp
- YesodDsl.AST: ExistsExpr :: SelectQuery -> BoolExpr
+ YesodDsl.AST: ExistsExpr :: SelectQuery -> Expr
- YesodDsl.AST: ExternExpr :: FunctionName -> [FunctionParam] -> BoolExpr
+ YesodDsl.AST: ExternExpr :: FunctionName -> [FunctionParam] -> Expr
- YesodDsl.AST: FieldExpr :: FieldRef -> ValExpr
+ YesodDsl.AST: FieldExpr :: FieldRef -> Expr
- YesodDsl.AST: Join :: JoinType -> EntityRef -> VariableName -> Maybe BoolExpr -> Join
+ YesodDsl.AST: Join :: JoinType -> EntityRef -> VariableName -> Maybe Expr -> Join
- YesodDsl.AST: Mul :: ValBinOp
+ YesodDsl.AST: Mul :: BinOp
- YesodDsl.AST: SelectQuery :: [SelectField] -> (EntityRef, VariableName) -> [Join] -> Maybe BoolExpr -> [(FieldRef, SortDir)] -> (Int, Int) -> SelectQuery
+ YesodDsl.AST: SelectQuery :: [SelectField] -> (EntityRef, VariableName) -> [Join] -> Maybe Expr -> [OrderBy] -> (Int, Int) -> SelectQuery
- YesodDsl.AST: Sub :: ValBinOp
+ YesodDsl.AST: Sub :: BinOp
- YesodDsl.AST: SubQueryExpr :: SelectQuery -> ValExpr
+ YesodDsl.AST: SubQueryExpr :: SelectQuery -> Expr
- YesodDsl.AST: type IfFilterParams = (ParamName, [Join], BoolExpr, UseParamFlag)
+ YesodDsl.AST: type IfFilterParams = (ParamName, [Join], Expr, [OrderBy], UseParamFlag)
- YesodDsl.Generator.Cabal: syncCabal :: FilePath -> Module -> IO ()
+ YesodDsl.Generator.Cabal: syncCabal :: FilePath -> [String] -> String -> [String] -> IO ()
- YesodDsl.Generator.Esqueleto: exprMaybeLevel :: ValExpr -> Int
+ YesodDsl.Generator.Esqueleto: exprMaybeLevel :: Expr -> Int
- YesodDsl.Generator.Esqueleto: exprReturnType :: ValExpr -> Maybe String
+ YesodDsl.Generator.Esqueleto: exprReturnType :: Expr -> Maybe String
- YesodDsl.Generator.Esqueleto: hsOrderBy :: (FieldRef, SortDir) -> Reader Context String
+ YesodDsl.Generator.Esqueleto: hsOrderBy :: (Maybe FunctionName, [FieldRef], SortDir) -> Reader Context String
- YesodDsl.Generator.GetHandler: defaultSortFields :: SelectQuery -> Reader Context String
+ YesodDsl.Generator.GetHandler: defaultSortFields :: [IfFilterParams] -> SelectQuery -> Reader Context String
- YesodDsl.Generator.GetHandler: getHandlerReturn :: SelectQuery -> String
+ YesodDsl.Generator.GetHandler: getHandlerReturn :: SelectQuery -> [FunctionName] -> String
Files
- YesodDsl/AST.hs +24/−28
- YesodDsl/ClassImplementer.hs +33/−6
- YesodDsl/Generator.hs +76/−33
- YesodDsl/Generator/Cabal.hs +18/−53
- YesodDsl/Generator/Classes.hs +2/−0
- YesodDsl/Generator/Client.hs +57/−0
- YesodDsl/Generator/Common.hs +13/−0
- YesodDsl/Generator/Esqueleto.hs +94/−100
- YesodDsl/Generator/EsqueletoInstances.hs +1/−1
- YesodDsl/Generator/GetHandler.hs +30/−19
- YesodDsl/Generator/HsClient.hs +77/−0
- YesodDsl/Generator/Input.hs +27/−2
- YesodDsl/Generator/Json.hs +12/−36
- YesodDsl/Generator/PureScript.hs +88/−0
- YesodDsl/Generator/Require.hs +1/−1
- YesodDsl/Generator/UpdateHandlers.hs +4/−3
- YesodDsl/Lexer.x +4/−2
- YesodDsl/Parser.y +94/−64
- YesodDsl/Simplify.hs +8/−10
- codegen/base-if-filter-nouse.cg +2/−2
- codegen/base-if-filter.cg +1/−1
- codegen/base-select-query.cg +5/−7
- codegen/class-entity-instances.cg +4/−0
- codegen/class-select.cg +5/−0
- codegen/default-sort-fields-check-if-filter-order-by.cg +1/−0
- codegen/default-sort-fields.cg +1/−1
- codegen/get-handler-return.cg +2/−2
- codegen/header.cg +2/−0
- codegen/hs-client-entity.cg +2/−0
- codegen/hs-client-enum.cg +8/−0
- codegen/hs-client-enums.cg +7/−0
- codegen/hs-client-export-enum.cg +1/−0
- codegen/hs-client-field-label-modifier.cg +1/−0
- codegen/hs-client-field-label-modifiers.cg +5/−0
- codegen/hs-client-field.cg +1/−0
- codegen/hs-client-handler-get.cg +22/−0
- codegen/hs-client-handler-update-empty-body.cg +17/−0
- codegen/hs-client-handler-update-result-type.cg +4/−0
- codegen/hs-client-handler-update.cg +22/−0
- codegen/hs-client-idtypes-entity.cg +2/−0
- codegen/hs-client-import-enum.cg +1/−0
- codegen/hs-client-inputfield-unknown.cg +1/−0
- codegen/hs-client-inputfield.cg +1/−0
- codegen/hs-client-json.cg +28/−0
- codegen/hs-client-result.cg +12/−0
- codegen/hs-client-types.cg +28/−0
- codegen/hs-client.cg +14/−0
- codegen/if-filter-order-by.cg +1/−0
- codegen/input-field-auth.cg +1/−1
- codegen/json-wrapper.cg +2/−0
- codegen/lookup-class-instance.cg +3/−0
- codegen/map-input-field-auth.cg +1/−1
- codegen/purescript-decodejson-assign.cg +2/−0
- codegen/purescript-decodejson-extract.cg +1/−0
- codegen/purescript-encodejson-field.cg +1/−0
- codegen/purescript-encodejson-unknown.cg +1/−0
- codegen/purescript-entity.cg +2/−0
- codegen/purescript-enum-decodevalue.cg +1/−0
- codegen/purescript-enum-encodevalue.cg +1/−0
- codegen/purescript-enum-show.cg +1/−0
- codegen/purescript-enum.cg +22/−0
- codegen/purescript-field.cg +1/−0
- codegen/purescript-handler-get.cg +19/−0
- codegen/purescript-handler-update-boolean-result.cg +2/−0
- codegen/purescript-handler-update-empty-body.cg +12/−0
- codegen/purescript-handler-update-process-result.cg +1/−0
- codegen/purescript-handler-update-result-type.cg +2/−0
- codegen/purescript-handler-update.cg +19/−0
- codegen/purescript-inputfield-unknown.cg +1/−0
- codegen/purescript-inputfield.cg +1/−0
- codegen/purescript-js.cg +25/−0
- codegen/purescript.cg +182/−0
- codegen/reflect-class-entity-instance-id.cg +1/−0
- codegen/static-order-by.cg +1/−1
- main/main.hs +6/−1
- yesod-dsl.cabal +5/−1
YesodDsl/AST.hs view
@@ -87,16 +87,9 @@ isOuterJoin FullOuterJoin = True isOuterJoin _ = False -data BinOp = Eq | Ne | Lt | Gt | Le | Ge | Like | Ilike | Is | In | NotIn deriving (Show,Eq, Data,Typeable) -data ValBinOp = Add | Sub | Div | Mul | Concat deriving (Show,Eq, Data,Typeable) +data BinOp = And | Or | Eq | Ne | Lt | Gt | Le | Ge | Like | Ilike | Is | In | NotIn | Add | Sub | Div | Mul | Concat deriving (Show,Eq, Data,Typeable) -data BoolExpr = AndExpr BoolExpr BoolExpr- | OrExpr BoolExpr BoolExpr- | NotExpr BoolExpr- | BinOpExpr ValExpr BinOp ValExpr - | ExistsExpr SelectQuery- | ExternExpr FunctionName [FunctionParam]- deriving (Show, Eq, Data, Typeable)+data UnOp = Floor | Ceiling | Not | Extract FieldName deriving (Show, Eq, Data, Typeable) data FunctionParam = FieldRefParam FieldRef | VerbatimParam String@@ -104,15 +97,14 @@ type MaybeLevel = Int -data ValExpr = FieldExpr FieldRef- | ConcatManyExpr [ValExpr]- | ValBinOpExpr ValExpr ValBinOp ValExpr - | RandomExpr- | FloorExpr ValExpr- | CeilingExpr ValExpr- | ExtractExpr FieldName ValExpr- | SubQueryExpr SelectQuery - deriving (Show, Eq, Data, Typeable)+data Expr = FieldExpr FieldRef+ | ConcatManyExpr [Expr]+ | BinOpExpr Expr BinOp Expr + | UnOpExpr UnOp Expr+ | SubQueryExpr SelectQuery + | ExistsExpr SelectQuery+ | ExternExpr FunctionName [FunctionParam]+ deriving (Show, Eq, Data, Typeable) type EntityRef = Either EntityName Entity entityRefName :: EntityRef -> EntityName@@ -124,7 +116,7 @@ | DefaultFilterSort | Select SelectQuery | IfFilter IfFilterParams- | DeleteFrom EntityRef VariableName (Maybe BoolExpr)+ | DeleteFrom EntityRef VariableName (Maybe Expr) | GetById EntityRef FieldRef VariableName | Update EntityRef FieldRef (Maybe [FieldRefMapping]) | Insert EntityRef (Maybe (Maybe VariableName, [FieldRefMapping])) (Maybe VariableName)@@ -132,16 +124,17 @@ | Require SelectQuery | For VariableName FieldRef [Stmt] | Call FunctionName [FieldRef]+ | MapJson FunctionName deriving (Show, Eq, Data, Typeable) type UseParamFlag = Bool -type IfFilterParams = (ParamName,[Join],BoolExpr,UseParamFlag)-+type IfFilterParams = (ParamName,[Join],Expr,[OrderBy],UseParamFlag)+type OrderBy = (Maybe FunctionName, [FieldRef], SortDir) data SelectQuery = SelectQuery { sqFields :: [SelectField], sqFrom :: (EntityRef, VariableName), sqJoins :: [Join],- sqWhere :: Maybe BoolExpr,- sqOrderBy :: [(FieldRef, SortDir)],+ sqWhere :: Maybe Expr,+ sqOrderBy :: [OrderBy], sqLimitOffset :: (Int, Int) } deriving (Show, Eq, Data, Typeable) @@ -155,15 +148,14 @@ data SelectField = SelectAllFields VariableRef | SelectField VariableRef FieldName (Maybe VariableName) | SelectIdField VariableRef (Maybe VariableName)- | SelectValExpr ValExpr VariableName- deriving (Show, Eq, Data, Typeable)-- + | SelectExpr Expr VariableName+ deriving (Show, Eq, Data, Typeable)+ data Join = Join { joinType :: JoinType, joinEntity :: EntityRef, joinAlias :: VariableName,- joinExpr :: Maybe BoolExpr+ joinExpr :: Maybe Expr } deriving (Show, Eq, Data, Typeable) type FieldRefMapping = (ParamName, FieldRef, Maybe FunctionName)@@ -274,6 +266,9 @@ fieldInternal :: Field -> Bool fieldInternal = (FieldInternal `elem`) . fieldOptions +fieldReadOnly :: Field -> Bool+fieldReadOnly = (FieldReadOnly `elem`) . fieldOptions+ fieldJsonName :: Field -> FieldName fieldJsonName f = fromMaybe (fieldName f) $ listToMaybe [ fn | FieldJsonName fn <- universeBi f ] @@ -282,6 +277,7 @@ | FieldColumnName FieldName | FieldJsonName FieldName | FieldInternal+ | FieldReadOnly deriving (Show, Eq, Data, Typeable)
YesodDsl/ClassImplementer.hs view
@@ -19,9 +19,36 @@ implementClasses m = let m' = m { modEntities = [ implInEntity m (modClasses m) e | e <- modEntities m ] } in m' {- modRoutes = everywhere (mkT $ trSq m') $ modRoutes m'+ modRoutes = everywhere ((mkT $ trStmt m) . (mkT $ trSq m')) $ modRoutes m' } +trStmt :: Module -> Stmt -> Stmt+trStmt m s = case s of+ Update er@(Left en) fr (Just frm) -> Update er fr (Just $ concatMap (f en) frm)+ Insert er@(Left en) (Just (mvn1, frm)) mvn2 -> Insert er (Just (mvn1, concatMap (f en) frm)) mvn2+ + x -> x+ where+ f en x@(pn,RequestField fn,mfn) = if pn == fn + then fromMaybe [x] $ do+ f <- lookupField' m en pn+ case fieldContent f of+ EntityField name -> do+ c <- classLookup (modClasses m) name++ Just $ [ + (lowerFirst (entityName e) ++ upperFirst pn,+ RequestField (lowerFirst (entityName e) ++ upperFirst pn),+ mfn) + | e <- modEntities m, + className c `elem` entityInstances e+ ]+ _ -> Nothing+ else [x]+ f _ x = [x]++ + trSq :: Module -> SelectQuery -> SelectQuery trSq m sq = sq { sqFields = concatMap trSelectField $ sqFields sq,@@ -78,7 +105,7 @@ SelectIdField (Var vn' (Left "") False) $ aliasName "id" man men | (vn',men) <- newAliases vn ]- SelectValExpr _ _ -> [sf] + SelectExpr _ _ -> [sf] trExpr e = let r = catMaybes [@@ -86,14 +113,14 @@ in if e' /= e && validExpr e' then Just e' else Nothing | (s,(d,_)) <- vnMap ] - in if null r then e else foldl1 OrExpr r- + in if null r then e else foldl1 mkOrExpr r+ mkOrExpr e1 e2 = BinOpExpr e1 Or e2 trueExpr = let c = (FieldExpr (Const (BoolValue True))) in BinOpExpr c Eq c trDropInvalidExprs e = let me = case e of- AndExpr e1 e2 -> Just (e1,e2)- OrExpr e1 e2 -> Just (e1,e2)+ BinOpExpr e1 And e2 -> Just (e1,e2)+ BinOpExpr e1 Or e2 -> Just (e1,e2) _ -> Nothing in case me >>= \(e1,e2) -> Just (validExpr e1, validExpr e2, e1, e2) of Just (True, True, _, _) -> e
YesodDsl/Generator.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}-module YesodDsl.Generator (generate, hsRouteName, genJson) where+module YesodDsl.Generator (generate, hsRouteName, genJson, genPureScript, genHsClient) where import Prelude hiding (readFile) import System.FilePath (joinPath) import System.Directory (createDirectoryIfMissing)@@ -12,6 +12,8 @@ import Data.List import Data.Maybe import Control.Monad+import System.FilePath (replaceExtension, dropExtension)+import Data.String.Utils (replace) import YesodDsl.Generator.Models import YesodDsl.Generator.EntityFactories@@ -22,6 +24,8 @@ import YesodDsl.Generator.EsqueletoInstances import YesodDsl.Generator.Cabal import YesodDsl.Generator.Json+import YesodDsl.Generator.PureScript+import YesodDsl.Generator.HsClient import YesodDsl.SyncFile import Data.Generics.Uniplate.Data import qualified Data.Map as Map@@ -32,13 +36,13 @@ fmtImport :: Import -> String fmtImport i = T.unpack $(codegenFile "codegen/import.cg") -writeRoute :: Module -> Route -> IO ()-writeRoute m r = do- let content = concatMap (handler m r) (routeHandlers r)- syncFile (joinPath ["Handler", moduleName m, - routeModuleName r ++ ".hs"]) $- T.unpack $(codegenFile "codegen/route-header.cg") ++ content+routeFile :: Module -> Route -> (FilePath, String)+routeFile m r = (joinPath ["Handler", moduleName m, + routeModuleName r ++ ".hs"],+ T.unpack $(codegenFile "codegen/route-header.cg") + ++ content) where+ content = concatMap (handler m r) (routeHandlers r) imports = concatMap fmtImport $ filter ((`elem` modules) . importModule) $ modImports m modules = nub $ catMaybes $ [ Map.lookup fn importedFunctions @@ -52,40 +56,79 @@ ++ concat [ catMaybes [ mm | (_,_,mm) <- ifs ] | Update _ _ (Just ifs) <- universeBi r ] ++ concat [ catMaybes [ mm | (_,_,mm) <- ifs ] | Insert _ (Just (Just _, ifs)) _ <- universeBi r ]+pathToModuleName :: String -> String+pathToModuleName = (replace "/" ".") . dropExtension + generate :: FilePath -> Module -> IO () generate path m = do- syncCabal path m createDirectoryIfMissing True (joinPath ["Handler", moduleName m])- syncFile (joinPath ["Handler", moduleName m, "Enums.hs"]) $- T.unpack $(codegenFile "codegen/enums-header.cg")- ++ (concatMap enum $ modEnums m)- syncFile (joinPath ["Handler", moduleName m, "Esqueleto.hs"]) $- T.unpack $(codegenFile "codegen/esqueleto-header.cg")- ++ (esqueletoInstances m) - forM_ (modRoutes m) (writeRoute m)- syncFile (joinPath ["Handler", moduleName m, "Internal.hs"]) $- T.unpack $(codegenFile "codegen/header.cg")- ++ models m- ++ entityFactories m- ++ classes m- ++ (T.unpack $(codegenFile "codegen/json-wrapper.cg")) - syncFile (joinPath ["Handler", moduleName m, "Validation.hs"]) $- T.unpack $(codegenFile "codegen/validation-header.cg")- ++ (concatMap validationEntity (modEntities m))- syncFile (joinPath ["Handler", moduleName m, "Routes.hs"]) $- routes m- syncFile (joinPath ["Handler", moduleName m ++ ".hs"]) $ - T.unpack $(codegenFile "codegen/dispatch.cg")- syncFile (joinPath ["Handler", moduleName m, "PathPieces.hs"]) $- T.unpack $(codegenFile "codegen/path-pieces.cg")- syncFile (joinPath ["Handler", moduleName m, "FilterSort.hs"]) $- T.unpack $(codegenFile "codegen/filter-sort.cg") + forM_ files $ uncurry syncFile+ syncCabal (replaceExtension path ".cabal") cabalDeps (moduleName m) moduleNames where- routeImport r = T.unpack $(codegenFile "codegen/route-import.cg")+ moduleNames = map (pathToModuleName . fst) files+ files = [(joinPath ["Handler", moduleName m, "Enums.hs"],+ T.unpack $(codegenFile "codegen/enums-header.cg")+ ++ (concatMap enum $ modEnums m)),+ (joinPath ["Handler", moduleName m, "Esqueleto.hs"],+ T.unpack $(codegenFile "codegen/esqueleto-header.cg")+ ++ (esqueletoInstances m)),+ (joinPath ["Handler", moduleName m, "Internal.hs"],+ T.unpack $(codegenFile "codegen/header.cg")+ ++ models m+ ++ entityFactories m+ ++ classes m+ ++ (T.unpack $(codegenFile "codegen/json-wrapper.cg"))),+ (joinPath ["Handler", moduleName m, "Validation.hs"],+ T.unpack $(codegenFile "codegen/validation-header.cg")+ ++ (concatMap validationEntity (modEntities m))),+ (joinPath ["Handler", moduleName m, "Routes.hs"],+ routes m),+ (joinPath ["Handler", moduleName m ++ ".hs"],+ T.unpack $(codegenFile "codegen/dispatch.cg")),+ (joinPath ["Handler", moduleName m, "PathPieces.hs"],+ T.unpack $(codegenFile "codegen/path-pieces.cg")),+ (joinPath ["Handler", moduleName m, "FilterSort.hs"],+ T.unpack $(codegenFile "codegen/filter-sort.cg"))]+ ++ [ routeFile m r | r <- modRoutes m ]+ routeImport r = T.unpack $(codegenFile "codegen/route-import.cg") + cabalDeps = ["unordered-containers",+ "transformers",+ "tagged",+ "blaze-builder",+ "http-types",+ "wai",+ "resourcet",+ "attoparsec",+ "time",+ "vector",+ "esqueleto",+ "yesod-persistent",+ "old-locale",+ "filepath",+ "unix",+ "path-pieces",+ "conduit-extra",+ "exceptions"+ ] genJson :: FilePath -> Module -> IO () genJson path m = syncFile path $ moduleToJson m +genPureScript :: FilePath -> Module -> IO ()+genPureScript path m = do+ syncFile path $ moduleToPureScript m+ syncFile (replaceExtension path ".js") $ moduleToPureScriptJs m++genHsClient :: FilePath -> Module -> IO ()+genHsClient path m = do+ createDirectoryIfMissing True $ joinPath [path, clientModuleName ]+ forM_ (moduleToHsClient m) $ \(name, src) -> do+ syncFile (joinPath [path, name]) src + syncCabal (joinPath [ path, path ++ ".cabal"]) cabalDeps (clientModuleName) moduleNames+ where+ moduleNames = map (pathToModuleName . fst) $ moduleToHsClient m+ clientModuleName = moduleName m ++ "Client"+ cabalDeps = ["aeson", "wreq", "time", "text"]
YesodDsl/Generator/Cabal.hs view
@@ -13,65 +13,30 @@ import Data.List import YesodDsl.Generator.Routes import YesodDsl.SyncFile-knownMods :: Module -> [ModuleName]-knownMods m = map fromString $ [pfx, pfx ++ ".Internal", pfx ++ ".Enums", pfx ++ ".Routes", pfx ++ ".Esqueleto", pfx ++ ".PathPieces", pfx ++ ".Validation", pfx ++ ".FilterSort" ]- ++ [pfx ++ "." ++ (routeModuleName r) | r <- modRoutes m ] ++ (map importModule $ modImports m)- where pfx = handlerPrefix m--handlerPrefix :: Module -> String-handlerPrefix m = "Handler." ++ (fromMaybe "" $ modName m)--ensureDeps :: [Dependency] -> [Dependency]-ensureDeps deps = nubBy samePackage ([Dependency (PackageName name) anyVersion - | name <- ["unordered-containers",- "transformers",- "tagged",- "blaze-builder",- "http-types",- "wai",- "resourcet",- "attoparsec",- "time",- "vector",- "esqueleto",- "yesod-persistent",- "old-locale",- "filepath",- "unix",- "path-pieces",- "conduit-extra",- "exceptions"- ] ] ++ deps)- where samePackage (Dependency pn1 _) (Dependency pn2 _) = pn1 == pn2- +import Control.Monad (when)+ -modifyDesc :: Module -> GenericPackageDescription -> GenericPackageDescription-modifyDesc m d = d {- condLibrary = (condLibrary d) >>= modifyCtree- }- where +syncCabal :: FilePath -> [String] -> String -> [String]-> IO ()+syncCabal path extraDeps generatedModule moduleNames = do+ e <- doesFileExist path+ when e $ do+ desc <- readPackageDescription verbose path+ syncFile path $ showGenericPackageDescription $ modifyDesc desc+ where+ modifyDesc d = d {+ condLibrary = (condLibrary d) >>= modifyCtree+ } modifyCtree ctree = Just $ ctree { condTreeData = modifyLib (condTreeData ctree),- condTreeConstraints = nub $ ensureDeps (condTreeConstraints ctree)+ condTreeConstraints = nub $ ensureDeps $ condTreeConstraints ctree } modifyLib l = l { exposedModules = modifyExposed (exposedModules l) }- modifyExposed mods = nub $ filter notGeneratedMod mods ++ knownMods m- notGeneratedMod = not . ((handlerPrefix m) `isPrefixOf`) . (intercalate ".") . components-syncCabal :: FilePath -> Module -> IO ()-syncCabal path' m = do- let path = addExtension (dropExtension path') ".cabal"- e <- doesFileExist path- if e - then do- desc <- readPackageDescription verbose path- - let content = showGenericPackageDescription (modifyDesc m desc)- syncFile path content - else return ()-+ samePackage (Dependency pn1 _) (Dependency pn2 _) = pn1 == pn2 - - + ensureDeps deps = nubBy samePackage $ [ Dependency (PackageName name) anyVersion + | name <- extraDeps ] ++ deps+ modifyExposed mods = nub $ filter notGeneratedMod mods ++ map fromString moduleNames+ notGeneratedMod = not . (generatedModule `isPrefixOf`) . (intercalate ".") . components
YesodDsl/Generator/Classes.hs view
@@ -69,6 +69,7 @@ where entityInstance e = T.unpack $(codegenFile "codegen/class-entity-instance.cg") entityInstanceId e = T.unpack $(codegenFile "codegen/class-entity-instance-id.cg")+ reflectEntityInstanceId e = T.unpack $(codegenFile "codegen/reflect-class-entity-instance-id.cg") classSelectFilterDataType :: Class -> String classSelectFilterDataType c = T.unpack $(codegenFile "codegen/class-select-filter-data-type.cg")@@ -80,6 +81,7 @@ classSelect c es = maybeFilterDataType ++ T.unpack $(codegenFile "codegen/class-select.cg") where + lookupInstance e = T.unpack $(codegenFile "codegen/lookup-class-instance.cg") selectEntity e = T.unpack $(codegenFile "codegen/class-select-entity.cg") wrapResult e = T.unpack $(codegenFile "codegen/class-select-result.cg") hasClassFields = not . null $ classFields c
+ YesodDsl/Generator/Client.hs view
@@ -0,0 +1,57 @@+module YesodDsl.Generator.Client where+import YesodDsl.AST+import Data.Maybe+import YesodDsl.Generator.Input++mkField :: FieldName -> (Bool,FieldContent) -> Field+mkField n (o,c) = Field (Loc "" 0 0) o n c [] Nothing++handlerInputFields :: Handler -> [(FieldName, Maybe Field)]+handlerInputFields h = nubAttrs $ concatMap requestAttrs $ handlerStmts h++handlerOutputFields :: Module -> Handler -> [Field]+handlerOutputFields m h = concatMap stmtOutputs $ handlerStmts h+ where+ stmtOutputs s = case s of+ Select sq -> mapMaybe selectFieldToField $ sqFields sq+ Return ofs -> mapMaybe (\(pn,fr,_) -> fieldRefToContent fr >>= Just . (mkField pn)) ofs+ _ -> []+ selectFieldToField sf = case sf of+ SelectField (Var _ (Right e) mf) fn mvn -> do+ f <- lookupField e fn+ let f' = f { fieldOptional = fieldOptional f || mf }+ Just $ case mvn of+ Just vn -> f' { fieldOptions = [ FieldJsonName vn ] ++ fieldOptions f' }+ Nothing -> f'+ SelectIdField (Var _ (Right e) mf) mvn -> Just $ + mkField (fromMaybe "id" mvn) (mf, EntityField $ entityName e)+ SelectExpr ve vn -> do+ fc <- case ve of+ FieldExpr fr -> fieldRefToContent fr+ BinOpExpr _ op _ -> Just $ if op `elem` [Add,Sub,Div,Mul]+ then (False, NormalField FTDouble)+ else (False, NormalField FTText)+ UnOpExpr Floor _ -> Just (False, NormalField FTDouble)+ UnOpExpr Ceiling _ -> Just (False, NormalField FTDouble)+ UnOpExpr (Extract _) _ -> Just (False, NormalField FTDouble)+ UnOpExpr Not _ -> Just (False, NormalField FTBool)+ ConcatManyExpr _ -> Just (False, NormalField FTText)+ _ -> Nothing+ Just $ mkField vn fc+ _ -> Nothing + fieldRefToContent fr = case fr of+ SqlId (Var _ (Right e) mf) -> Just (mf, EntityField $ entityName e)+ SqlField (Var _ (Right e) mf) fn -> do+ f <- lookupField e fn+ Just $ (fieldOptional f || mf, fieldContent f)+ AuthId -> Just (False, EntityField "User")+ AuthField fn -> listToMaybe [ (fieldOptional f, fieldContent f)+ | e <- modEntities m, + f <- entityFields e, + entityName e == "User",+ fieldName f == fn ]+ LocalParamField (Var _ (Right e) mf) fn -> do+ f <- lookupField e fn+ Just $ (fieldOptional f || mf, fieldContent f)+ _ -> Nothing+
YesodDsl/Generator/Common.hs view
@@ -1,5 +1,7 @@ module YesodDsl.Generator.Common where import YesodDsl.AST+import Language.Haskell.HsColour.Classify+ brackets :: Bool -> String -> String brackets True s = "(" ++ s ++ ")" brackets False s = s@@ -18,10 +20,21 @@ indent :: Int -> String -> String indent x = unlines . (map ((replicate x ' ')++)) . lines +prepend :: String -> String -> String+prepend x = (x++)+ entityFieldName :: Entity -> Field -> String entityFieldName e f = (lowerFirst . entityName) e ++ (upperFirst . fieldName) f resultMapper :: Maybe FunctionName -> String resultMapper mmapper = maybe "" ((" $ " ++) . (++ " $ ")) mmapper++isKeyword :: String -> Bool+isKeyword = (== [Keyword]) . map fst . tokenise++safeHsName :: String -> String+safeHsName x+ | isKeyword x = x ++ "_"+ | otherwise = x
YesodDsl/Generator/Esqueleto.hs view
@@ -24,7 +24,21 @@ Is -> "`is`" In -> "`in_`" NotIn -> "`notIn`"+ Div -> "/."+ Mul -> "*."+ Add -> "+."+ Sub -> "-."+ Concat -> "++."+ And -> "&&."+ Or -> "||." +hsUnOp :: UnOp -> String+hsUnOp op = case op of+ Not -> "not_"+ Floor -> "floor_"+ Ceiling -> "ceiling_"+ Extract fn -> "extractSubField " ++ (quote $ extractSubField fn) + type TypeName = String data Context = Context { ctxNames :: Map.Map VariableName (Entity,MaybeFlag),@@ -102,24 +116,23 @@ hsFieldRef ml (Const (fv@(NothingValue))) = return $ makeJust ml $ fieldValueToEsqueleto fv hsFieldRef ml (Const fv) = return $ makeJust ml $ "(val " ++ fieldValueToEsqueleto fv ++ ")" hsFieldRef _ fr = return $ show fr-hsOrderBy :: (FieldRef, SortDir) -> Reader Context String-hsOrderBy (f,d) = do- content <- hsFieldRef 0 f- return $ dir d ++ "(" ++ content ++ ")"- where dir SortAsc = "asc "- dir SortDesc = "desc "--hsValBinOp :: ValBinOp -> String-hsValBinOp vo = case vo of- Div -> "/."- Mul -> "*."- Add -> "+."- Sub -> "-."- Concat -> "++."+hsOrderBy :: (Maybe FunctionName, [FieldRef], SortDir) -> Reader Context String+hsOrderBy ob = case ob of+ (Nothing, fs,d) -> simple fs d+ (Just fn, fs, d) -> aggr fn fs d+ where + dir SortAsc = "asc "+ dir SortDesc = "desc "+ simple fs d = do+ contents <- forM fs $ hsFieldRef 0 + return $ intercalate ", " [ dir d ++ "(" ++ content ++ ")" | content <- contents ]+ aggr fn fs d = do+ contents <- forM fs $ hsFieldRef 0+ return $ dir d ++ "(" ++ fn ++ " (" ++ (intercalate ") (" contents) ++ "))" - -hsValExpr :: MaybeLevel -> ValExpr -> Reader Context String-hsValExpr ml ve = do+ +hsExpr :: MaybeLevel -> Expr -> Reader Context String+hsExpr ml ve = do c <- content maybePromoteJust c where @@ -131,25 +144,46 @@ return $ makeJust ml c content = case ve of FieldExpr fr -> hsFieldRef ml fr- ConcatManyExpr ves -> do- rs <- mapM (hsValExpr 0) ves+ ConcatManyExpr ves -> local noListValue $ do+ rs <- mapM (hsExpr 0) ves return $ "(concat_ [" ++ intercalate ", " rs ++ "])"- ValBinOpExpr e1 vop e2 -> do- r1 <- hsValExpr 0 e1- r2 <- hsValExpr 0 e2- return $ "(" ++ r1 ++ ") " ++ hsValBinOp vop ++ " (" ++ r2 ++ ")"- RandomExpr -> return "random_"- FloorExpr ve' -> do- r <- hsValExpr 0 ve'- return $ "(floor_ $ " ++ r ++ ")"- CeilingExpr ve' -> do- r <- hsValExpr 0 ve'- return $ "(ceiling_ $ " ++ r ++ ")"- ExtractExpr fn ve' -> do- r <- hsValExpr 0 ve'- return $ "(extractSubField " ++ (quote $ extractSubField fn) ++ " $ " ++ r++ ")"- SubQueryExpr sq -> subQuery "subList_select" sq-+ BinOpExpr e1 op e2 -> if op `elem` [ Add , Sub , Div , Mul , Concat, And, Or ] + then local noListValue $ do+ r1 <- hsExpr 0 e1+ r2 <- hsExpr 0 e2+ return $ "(" ++ r1 ++ ") " ++ hsBinOp op ++ " (" ++ r2 ++ ")" + else do+ let e1m = exprMaybeLevel e1+ e2m = exprMaybeLevel e2+ e1rt = exprReturnType e1+ e2rt = exprReturnType e2+ r1 <- local + (\ctx -> ctx { + ctxExprType = e2rt+ } )+ (hsExpr (max 0 $ e2m - e1m) e1)+ r2 <- local + (\ctx -> ctx { + ctxExprType = case op of+ Ilike -> Just "Text"+ Like -> Just "Text"+ _ -> e1rt,+ ctxExprListValue = op `elem` [In, NotIn]+ }) + (hsExpr (max 0 $ e1m - e2m) e2)+ return $ "(" ++ r1 ++ ") " ++ hsBinOp op ++ " (" ++ r2 ++ ")"+ + SubQueryExpr sq -> local noListValue $ subQuery "subList_select" sq+ UnOpExpr op e -> local noListValue $ do+ r <- hsExpr 0 e+ return $ "(" ++ hsUnOp op ++ " $ " ++ r ++ ")"+ ExistsExpr sq -> local noListValue $ subQuery "exists" sq+ ExternExpr ee ps -> local noListValue $ do+ ps' <- mapM externExprParam ps+ return $ intercalate " " $ [ee] ++ map ((++ ")"). ("("++)) ps'+ externExprParam (FieldRefParam fr) = hsFieldRef 0 fr+ externExprParam (VerbatimParam v) = return v + noListValue ctx = ctx { ctxExprListValue = False } fieldRefMaybeLevel :: FieldRef -> Int fieldRefMaybeLevel (SqlId (Var _ _ mf)) = boolToInt mf fieldRefMaybeLevel (SqlField (Var _ (Right e) mf) fn) = boolToInt mf + (fromMaybe 0 $ lookupField e fn >>= \f -> Just $ boolToInt $ fieldOptional f)@@ -157,43 +191,44 @@ fieldRefMaybeLevel _ = 0 -exprMaybeLevel :: ValExpr -> Int+exprMaybeLevel :: Expr -> Int exprMaybeLevel ve = case ve of FieldExpr fr -> fieldRefMaybeLevel fr- ConcatManyExpr ves -> 0- ValBinOpExpr e1 _ e2 -> max (exprMaybeLevel e1) (exprMaybeLevel e2)- FloorExpr e -> exprMaybeLevel e- CeilingExpr e -> exprMaybeLevel e- ExtractExpr _ e -> exprMaybeLevel e+ ConcatManyExpr _ -> 0+ BinOpExpr e1 _ e2 -> 0+ UnOpExpr _ e -> 0 SubQueryExpr sq -> fromMaybe 0 $ listToMaybe $ map exprMaybeLevel $ concatMap (selectFieldExprs) $ sqFields sq _ -> 0-exprReturnType :: ValExpr -> Maybe String+ where+ selectFieldExprs sf = case sf of+ (SelectField vn fn _) -> [ FieldExpr $ SqlField vn fn]+ (SelectIdField vn _) -> [ FieldExpr $ SqlId vn ]+ (SelectExpr ve' _) -> [ ve' ]+ _ -> []+ +exprReturnType :: Expr -> Maybe String exprReturnType e = case e of- FloorExpr _ -> Just "Double"- CeilingExpr _ -> Just "Double"- ExtractExpr _ _ -> Just "Double"+ UnOpExpr Floor _ -> Just "Double"+ UnOpExpr Ceiling _ -> Just "Double"+ UnOpExpr (Extract _) _ -> Just "Double" _ -> Nothing mapJoinExpr :: Join -> Reader Context String mapJoinExpr (Join _ _ _ (Just expr)) = do- e <- hsBoolExpr expr+ e <- hsExpr 0 expr return $ "on (" ++ e ++ ")\n" mapJoinExpr _ = return "" -selectFieldExprs :: SelectField -> [ValExpr]-selectFieldExprs sf = - case sf of- (SelectField vn fn _) -> [ FieldExpr $ SqlField vn fn]- (SelectIdField vn _) -> [ FieldExpr $ SqlId vn ]- (SelectValExpr ve _) -> [ ve ]- _ -> [] selectReturnFields :: SelectQuery -> Reader Context String selectReturnFields sq = do- let fieldExprs = concatMap selectFieldExprs (sqFields sq)- ves <- mapM (hsValExpr 0) fieldExprs+ ves <- forM (sqFields sq) $ \sf -> case sf of+ SelectField vn fn _ -> hsExpr 0 $ FieldExpr $ SqlField vn fn+ SelectIdField vn _ -> hsExpr 0 $ FieldExpr $ SqlId vn+ SelectExpr ve _ -> hsExpr 0 ve+ _ -> return "" return $ "return (" ++ (intercalate ", " ves) ++ ")"- + where joinDef :: Join-> String joinDef (Join jt _ vn _) = "`" ++ show jt ++ "` " ++ vn @@ -203,7 +238,7 @@ rfs <- selectReturnFields sq maybeWhere <- case sqWhere sq of Just expr -> do- e <- hsBoolExpr expr+ e <- hsExpr 0 expr return $ "where_ (" ++ e ++ ")" Nothing -> return "" return $ sqFunc ++ " $ from $ \\(" ++ vn ++ @@ -221,47 +256,6 @@ withScope names = local $ \ctx -> ctx { ctxNames = Map.union names $ ctxNames ctx } -scopedBoolExpr :: Map.Map VariableName (Entity, MaybeFlag) -> BoolExpr -> String-scopedBoolExpr names e = runReader (hsBoolExpr e) $ emptyContext { ctxNames = names }+scopedExpr :: Map.Map VariableName (Entity, MaybeFlag) -> Expr -> String+scopedExpr names e = runReader (hsExpr 0 e) $ emptyContext { ctxNames = names } -hsBoolExpr :: BoolExpr -> Reader Context String-hsBoolExpr expr = local (\ctx -> ctx { ctxExprListValue = False}) $- case expr of- AndExpr e1 e2 -> do- r1 <- hsBoolExpr e1- r2 <- hsBoolExpr e2- return $ "(" ++ r1 ++ ") &&. (" ++ r2 ++ ")"- OrExpr e1 e2 -> do- r1 <- hsBoolExpr e1- r2 <- hsBoolExpr e2 - return $ "(" ++ r1 ++ ") ||. (" ++ r2 ++ ")"- NotExpr e -> do- r <- hsBoolExpr e- return $ "not_ (" ++ r ++ ")"- BinOpExpr e1 op e2 -> do- let e1m = exprMaybeLevel e1- e2m = exprMaybeLevel e2- e1rt = exprReturnType e1- e2rt = exprReturnType e2- r1 <- local - (\ctx -> ctx { - ctxExprType = e2rt- } )- (hsValExpr (max 0 $ e2m - e1m) e1)- r2 <- local - (\ctx -> ctx { - ctxExprType = case op of- Ilike -> Just "Text"- Like -> Just "Text"- _ -> e1rt,- ctxExprListValue = op `elem` [In, NotIn]- }) - (hsValExpr (max 0 $ e1m - e2m) e2)- return $ "(" ++ r1 ++ ") " ++ hsBinOp op ++ " (" ++ r2 ++ ")"- ExistsExpr sq -> subQuery "exists" sq- ExternExpr ee ps -> do- ps' <- mapM externExprParam ps- return $ intercalate " " $ [ee] ++ map ((++ ")"). ("("++)) ps'- where- externExprParam (FieldRefParam fr) = hsFieldRef 0 fr- externExprParam (VerbatimParam v) = return v
YesodDsl/Generator/EsqueletoInstances.hs view
@@ -16,7 +16,7 @@ hp <- handlerStmts h] where isSelectQuery (Select _) = True isSelectQuery _ = False- sqFieldNumber (Select sq) = length $ concatMap selectFieldExprs (sqFields sq)+ sqFieldNumber (Select sq) = length $ sqFields sq sqFieldNumber _ = 0 safeMaximum [] = 0 safeMaximum xs = maximum xs
YesodDsl/Generator/GetHandler.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module YesodDsl.Generator.GetHandler where@@ -19,7 +20,7 @@ getStmt :: Stmt -> String getStmt DefaultFilterSort = T.unpack $(codegenFile "codegen/default-filter-sort-param.cg") ++ (T.unpack $(codegenFile "codegen/offset-limit-param.cg"))-getStmt (IfFilter (pn,_,_,useFlag)) = T.unpack $(codegenFile "codegen/get-filter-param.cg")+getStmt (IfFilter (pn,_,_,_,useFlag)) = T.unpack $(codegenFile "codegen/get-filter-param.cg") where forceType = if useFlag == True then (""::String) else " :: Maybe Text" getStmt _ = "" @@ -57,42 +58,51 @@ defaultSortField (e,vn,f,pn,isMaybe) = do return $ T.unpack $(codegenFile "codegen/default-sort-field.cg") -defaultSortFields :: SelectQuery -> Reader Context String-defaultSortFields sq = do+defaultSortFields :: [IfFilterParams] -> SelectQuery -> Reader Context String+defaultSortFields ifFilters sq = do sortFields <- liftM concat $ mapM fromSelectField (sqFields sq) fields <- liftM concat $ mapM defaultSortField sortFields staticSortFields <- mapM hsOrderBy $ sqOrderBy sq return $ T.unpack $(codegenFile "codegen/default-sort-fields.cg") where - fromSelectField (SelectField (Var vn (Right e) mf) fn an) = do+ ifFilterOrderBys = [ "filterParam_" ++ pn | (pn, _, _, obs, _) <- ifFilters, null obs == False ] + checkIfFilterOrderBy + | null ifFilterOrderBys = ""+ | otherwise = rstrip (T.unpack $(codegenFile "codegen/default-sort-fields-check-if-filter-order-by.cg")) ++ " "+ + fromSelectField (SelectField (Var vn (Right e) mf) fn an) = do return [ (e,vn, f, maybe (fieldName f) id an,mf) | f <- entityFields e, fieldName f == fn ]- fromSelectField (SelectIdField _ _) = return [] -- TODO- fromSelectField _ = return [] + fromSelectField (SelectIdField _ _) = return [] -- TODO+ fromSelectField _ = return [] implicitJoinExpr :: Join -> Reader Context String implicitJoinExpr (Join _ _ _ (Just expr)) = do- e <- hsBoolExpr expr+ e <- hsExpr 0 expr return $ "where_ (" ++ e ++ ")\n" implicitJoinExpr _ = return "" baseIfFilter :: IfFilterParams -> Reader Context String-baseIfFilter (pn,joins,bExpr,useFlag) = withScope +baseIfFilter (pn,joins,bExpr,obs,useFlag) = withScope (Map.fromList $ catMaybes [ either (\_ -> Nothing) (\e -> Just (joinAlias j, (e, isOuterJoin $ joinType j))) $ joinEntity j | j <- joins]) $ do joinExprs <- liftM concat $ mapM implicitJoinExpr joins- expr <- hsBoolExpr bExpr+ expr <- hsExpr 0 bExpr+ sortFields <- mapM hsOrderBy obs+ return $ T.unpack $ if useFlag then $(codegenFile "codegen/base-if-filter.cg") else $(codegenFile "codegen/base-if-filter-nouse.cg") where - maybeFrom = if null joins - then "do"- else T.unpack $(codegenFile "codegen/if-filter-from.cg") + maybeOrderBy [] = ""+ maybeOrderBy sortFields = T.unpack $(codegenFile "codegen/if-filter-order-by.cg")+ maybeFrom = if null joins + then "do"+ else T.unpack $(codegenFile "codegen/if-filter-from.cg") getHandlerSelect :: [Stmt] -> String getHandlerSelect ps = case listToMaybe [ sq | Select sq <- universeBi ps ] of@@ -109,7 +119,7 @@ else "" maybeWhere <- case sqWhere sq of Just expr -> do- e <- hsBoolExpr expr+ e <- hsExpr 0 expr return $ "where_ (" ++ e ++ ")\n" Nothing -> return "" joinExprs <- liftM concat $ mapM mapJoinExpr $ reverse $ sqJoins sq@@ -117,9 +127,9 @@ filterFieldsStr <- defaultFilterFields sq returnFieldsStr <- selectReturnFields sq maybeDefaultSortFields <- if defaultFilterSort- then defaultSortFields sq+ then defaultSortFields ifFilters sq else do- staticSortFields <- mapM hsOrderBy $ sqOrderBy sq+ sortFields <- mapM hsOrderBy $ sqOrderBy sq return $ T.unpack $(codegenFile "codegen/static-order-by.cg") return $ concat [ (T.unpack $(codegenFile "codegen/base-select-query.cg")),@@ -130,20 +140,21 @@ (indent 8 returnFieldsStr), (T.unpack $(codegenFile "codegen/select-count.cg")), (T.unpack $(codegenFile "codegen/select-results.cg")),- getHandlerReturn sq+ getHandlerReturn sq [ fn | MapJson fn <- universeBi ps ] ]) (emptyContext { ctxNames = sqAliases sq }) Nothing -> "" -getHandlerReturn :: SelectQuery -> String-getHandlerReturn sq = T.unpack $(codegenFile "codegen/get-handler-return.cg")+getHandlerReturn :: SelectQuery -> [FunctionName] -> String+getHandlerReturn sq jsonMappers = T.unpack $(codegenFile "codegen/get-handler-return.cg") where + prependBind = prepend " >>= " fieldNames' = concat $ map expand $ sqFields sq fieldNames = zip fieldNames' ([1..]::[Int]) mappedResultFields = concatMap mapResultField $ fieldNames resultFields = map (\(_,i) -> "(Database.Esqueleto.Value f"++ show i ++ ")") fieldNames expand (SelectField _ fn an') = [ maybe fn id an' ] expand (SelectIdField _ an') = [ maybe "id" id an' ]- expand (SelectValExpr _ an) = [ an ]+ expand (SelectExpr _ an) = [ an ] expand _ = [] mapResultField (fn,i) = T.unpack $(codegenFile "codegen/map-result-field.cg")
+ YesodDsl/Generator/HsClient.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module YesodDsl.Generator.HsClient (moduleToHsClient) where+import YesodDsl.AST+import Data.List+import Data.Maybe+import Data.Char (toLower)+import Data.String.Utils (rstrip)+import Data.Text (Text)+import qualified Data.Text as T+import Text.Shakespeare.Text hiding (toText)+import Data.Generics.Uniplate.Data+import YesodDsl.Generator.Common+import YesodDsl.Generator.Input+import YesodDsl.Generator.Models+import YesodDsl.Generator.Client+import System.FilePath (joinPath)+ +mkField :: FieldName -> (Bool,FieldContent) -> Field+mkField n (o,c) = Field (Loc "" 0 0) o n c [] Nothing++moduleToHsClient :: Module -> [(FilePath, String)]+moduleToHsClient m = [ + (baseName ++".hs", T.unpack $(codegenFile "codegen/hs-client.cg")),+ (joinPath [baseName, "Result.hs"], T.unpack $(codegenFile "codegen/hs-client-result.cg")),+ (joinPath [baseName, "Types.hs"], T.unpack $(codegenFile "codegen/hs-client-types.cg")),+ (joinPath [baseName, "Json.hs"], T.unpack $(codegenFile "codegen/hs-client-json.cg")),+ (joinPath [baseName, "Enums.hs"], T.unpack $(codegenFile "codegen/hs-client-enums.cg"))++ + ] ++ [ (handlerFileName r h, handler r h) + | r <- modRoutes m, h <- routeHandlers r ]+ ++ [ (enumFileName e, enum e) | e <- modEnums m ]+ where+ importEnum e = T.unpack $(codegenFile "codegen/hs-client-import-enum.cg")+ exportEnum e = T.unpack $(codegenFile "codegen/hs-client-export-enum.cg")+ entityIdType e = T.unpack $(codegenFile "codegen/hs-client-idtypes-entity.cg")+ baseName = moduleName m ++ "Client"+ handlerFileName r h = joinPath [ baseName, (upperFirst . (map toLower) . show . handlerType) h ++ concatMap pathName (routePath r) ++ ".hs"]+ enumFileName e = joinPath [ baseName, enumName e ++ ".hs" ]+ enum e = T.unpack $(codegenFile "codegen/hs-client-enum.cg")+ handler r h + | handlerType h == GetHandler = T.unpack $(codegenFile "codegen/hs-client-handler-get.cg")+ | null $ handlerInputFields h =T.unpack $(codegenFile "codegen/hs-client-handler-update-empty-body.cg")+ | otherwise = T.unpack $(codegenFile "codegen/hs-client-handler-update.cg")+ where+ ifBodyAllowed content + | handlerType h `elem` [PutHandler, PostHandler] = content :: String+ | otherwise = ""+ fieldLabelModifier (src, dst) = T.unpack $(codegenFile "codegen/hs-client-field-label-modifier.cg")+ fieldLabelModifiers = [ (safeHsName $ fieldJsonName f, fieldJsonName f) | f <- handlerOutputFields m h, safeHsName (fieldJsonName f) /= fieldJsonName f ] + maybeFieldLabelModifier+ | null fieldLabelModifiers = ""+ | otherwise = T.unpack $(codegenFile "codegen/hs-client-field-label-modifiers.cg")+ methodName = map toLower $ show $ handlerType h+ defineResultType+ | null $ handlerOutputFields m h = "type Result = A.Value" :: String+ | otherwise = T.unpack $(codegenFile "codegen/hs-client-handler-update-result-type.cg")+ field f = rstrip $ T.unpack $(codegenFile "codegen/hs-client-field.cg")++ handlerTypeName = upperFirst $ map toLower (show $ handlerType h) + handlerEntityName = handlerTypeName ++ concatMap pathName (routePath r) + pathName pp = case pp of+ PathText t -> upperFirst t+ PathId _ en -> "_"+ + routePathParams r = mapMaybe (\(n,pp) -> case pp of+ PathText _ -> Nothing+ PathId _ en -> Just ("(Key p" ++ show (n::Int) ++ ")",en ++ "Id")) $ zip [1..] (routePath r)+ routePathUrl r = concatMap (\(n,pp) -> case pp of+ PathText t -> " ++ \"/" ++ t ++ "\""+ PathId _ _ -> " ++ \"/\" ++ show p" ++ show (n::Int)) $ zip [1..] (routePath r)+ + inputField (fn,Just f) = rstrip $ T.unpack $(codegenFile "codegen/hs-client-inputfield.cg")+ inputField (fn,Nothing) = rstrip $ T.unpack $(codegenFile "codegen/hs-client-inputfield-unknown.cg")+ entity e = T.unpack $(codegenFile "codegen/hs-client-entity.cg")
YesodDsl/Generator/Input.hs view
@@ -3,10 +3,33 @@ import Data.Maybe import qualified Data.Text as T import Text.Shakespeare.Text hiding (toText)+import qualified Data.List as L+import Data.Function (on) import Data.String.Utils (rstrip) import YesodDsl.AST import Data.Generics.Uniplate.Data import qualified Data.Map as Map++fieldRefMappingToAttrs :: Entity -> Bool -> [FieldRefMapping] -> [(FieldName, Maybe Field)]+fieldRefMappingToAttrs e onlyMapped fs = (if onlyMapped then [] else [ (fieldName f, Just f) | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False, fieldInternal f == False, fieldName f `notElem` mapped ]) ++ [ (pn, Just f) | f <- entityFields e, (fn,fr,_) <- fs, (RequestField pn) <- universeBi fr, fieldName f == fn ]+ where+ mapped = [ fn | (fn, _, _) <- fs ]++requestAttrs :: Stmt -> [(FieldName, Maybe Field)]+requestAttrs (Update (Right e) _ Nothing) = [ (fieldJsonName f, Just f) | f <- entityFields e, fieldInternal f == False, fieldReadOnly f == False ]+requestAttrs (Update (Right e) _ (Just fs)) = fieldRefMappingToAttrs e False fs+requestAttrs (Insert (Right e) Nothing _) = [ (fieldJsonName f, Just f) | f <- entityFields e, fieldInternal f == False, fieldReadOnly f == False ]+requestAttrs (Insert (Right e) (Just (me, fs)) _) = fieldRefMappingToAttrs e (isJust me) fs+requestAttrs hp = [ (fn, Nothing) | RequestField fn <- universeBi hp ] ++ (concat $ [ requestAttrs i | i@(Insert _ _ _) <- universeBi hp ] ++ [ requestAttrs u | u@(Update _ _ _) <- universeBi hp ])+ ++ (concat [ + [ (fieldJsonName f, Just f) | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]+ | Insert (Right e) Nothing _ <- universeBi hp ])++nubAttrs :: [(FieldName, Maybe Field)] -> [(FieldName, Maybe Field)]+nubAttrs = L.nubBy ((==) `on` fst) +++ inputFieldRef :: FieldRef -> String inputFieldRef AuthId = rstrip $ T.unpack $(codegenFile "codegen/input-field-authid.cg") inputFieldRef (AuthField fn) = rstrip $ T.unpack $(codegenFile "codegen/input-field-auth.cg")@@ -17,12 +40,14 @@ inputFieldRef (PathParam i) = T.unpack $(codegenFile "codegen/input-field-path-param.cg") inputFieldRef (RequestField pn) = rstrip $ T.unpack $(codegenFile "codegen/input-field-normal.cg")+inputFieldRef (Const fv) = fieldValueToHs fv inputFieldRef ifr = show ifr getJsonAttrs :: Stmt -> [FieldName]-getJsonAttrs (Insert (Right e) Nothing _) = [ fieldName f | f <- entityFields e, fieldInternal f == False ]+getJsonAttrs (Insert (Right e) Nothing _) = [ fieldJsonName f | f <- entityFields e, fieldInternal f == False, fieldReadOnly f == False ]+getJsonAttrs (Update (Right e) fr Nothing) = [ fn | RequestField fn <- universeBi fr ] ++ [ fieldName f | f <- entityFields e ] getJsonAttrs hp = [ fn | RequestField fn <- universeBi hp ]- ++ (concat [ [ fieldName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]+ ++ (concat [ [ fieldJsonName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ] | Insert (Right e) Nothing _ <- universeBi hp ]) getParamDefaults :: [Stmt] -> Map.Map ParamName FieldValue
YesodDsl/Generator/Json.hs view
@@ -10,39 +10,15 @@ import qualified Data.Vector as V import qualified Data.Text.Lazy.Encoding as LTE import YesodDsl.Generator.Input-import Data.Generics.Uniplate.Data-import qualified Data.List as L import qualified Data.Text.Lazy as LT-import Data.Function-fieldRefMappingToAttrs :: Entity -> [FieldRefMapping] -> [(FieldName, Maybe FieldContent)]-fieldRefMappingToAttrs e fs = [ (fieldName f, Just $ fieldContent f) | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False, fieldInternal f == False, fieldName f `notElem` mapped ] ++ [ (pn, Just $ fieldContent f) | f <- entityFields e, (fn,fr,_) <- fs, (RequestField pn) <- universeBi fr, fieldName f == fn ]- where- mapped = [ fn | (fn, _, _) <- fs ] -requestAttrs :: Stmt -> [(FieldName, Maybe FieldContent)]-requestAttrs (Update (Right e) _ Nothing) = [ (fieldName f, Just $ fieldContent f) | f <- entityFields e, fieldInternal f == False ]-requestAttrs (Update (Right e) _ (Just fs)) = fieldRefMappingToAttrs e fs-requestAttrs (Insert (Right e) Nothing _) = [ (fieldName f, Just $ fieldContent f) | f <- entityFields e, fieldInternal f == False ]-requestAttrs (Insert (Right e) (Just (_, fs)) _) = fieldRefMappingToAttrs e fs-requestAttrs hp = [ (fn, Nothing) | RequestField fn <- universeBi hp ] ++ (concat $ [ requestAttrs i | i@(Insert _ _ _) <- universeBi hp ] ++ [ requestAttrs u | u@(Update _ _ _) <- universeBi hp ])-requestAttrs hp = [ (fn, Nothing) | RequestField fn <- universeBi hp ]- ++ (concat [ [ (fieldName f, Just $ fieldContent f) | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]- | Insert (Right e) Nothing _ <- universeBi hp ])--nubAttrs :: [(FieldName, Maybe FieldContent)] -> [(FieldName, Maybe FieldContent)]-nubAttrs = L.nubBy ((==) `on` fst) . (L.sortBy cmp)- where- cmp (_, Just _) (_, Nothing) = LT- cmp (_, Nothing) (_, Just _) = GT- cmp _ _ = EQ- moduleToJson :: Module -> String moduleToJson m = LT.unpack $ LTE.decodeUtf8 $ encodePretty $ object [ "name" .= moduleName m, "classes" .= [ object [ "name" .= className c,- "fields" .= [ fieldJson f | f <- classFields c, fieldInternal f == False ],+ "fields" .= [ fieldJson f | f <- classFields c, fieldInternal f == False, fieldReadOnly f == False ], "instances" .= [ entityName e | e <- modEntities m, className c `elem` entityInstances e ] ] | c <- modClasses m@@ -50,7 +26,7 @@ "entities" .= [ object [ "name" .= entityName e,- "fields" .= [ fieldJson f | f <- entityFields e, fieldInternal f == False ]+ "fields" .= [ fieldJson f | f <- entityFields e, fieldInternal f == False, fieldReadOnly f == False ] ] | e <- modEntities m ], "enums" .= [@@ -81,8 +57,8 @@ "inputs" .= [ object [ "name" .= fn,- "type" .= (mfc >>= Just . toJSON . jsonFieldType),- "references" .= (mfc >>= Just . toJSON . jsonFieldReferences)+ "type" .= (mfc >>= Just . toJSON . jsonFieldType . fieldContent),+ "references" .= (mfc >>= Just . toJSON . jsonFieldReferences . fieldContent) ] | (fn, mfc) <- nubAttrs $ concatMap requestAttrs $ handlerStmts h ],@@ -113,19 +89,19 @@ name = case sf of SelectField _ fn mvn -> fromMaybe fn mvn SelectIdField _ mvn -> fromMaybe "id" mvn- SelectValExpr _ vn -> vn+ SelectExpr _ vn -> vn _ -> "" type_ = case sf of SelectField (Var _ (Right e) _) fn _ -> fromMaybe Null $ lookupField e fn >>= Just . toJSON . jsonFieldType . fieldContent SelectIdField _ _ -> String "integer"- SelectValExpr ve _ -> case ve of+ SelectExpr ve _ -> case ve of ConcatManyExpr _ -> String "string"- ValBinOpExpr _ Concat _ -> String "string"- ValBinOpExpr _ _ _ -> String "number"- RandomExpr -> String "number"- FloorExpr _ -> String "number"- CeilingExpr _ -> String "number"- ExtractExpr _ _ -> String "string"+ BinOpExpr _ Concat _ -> String "string"+ BinOpExpr _ _ _ -> String "number"+ UnOpExpr Floor _ -> String "number"+ UnOpExpr Ceiling _ -> String "number"+ UnOpExpr Not _ -> String "boolean"+ UnOpExpr (Extract _) _ -> String "string" _ -> Null _ -> Null references = case sf of
+ YesodDsl/Generator/PureScript.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module YesodDsl.Generator.PureScript (moduleToPureScript, moduleToPureScriptJs) where+import YesodDsl.AST+import Data.List+import Data.Maybe+import Data.Char (toLower)+import Data.String.Utils (rstrip)+import Data.Text (Text)+import qualified Data.Text as T+import Text.Shakespeare.Text hiding (toText)+import Data.Generics.Uniplate.Data+import YesodDsl.Generator.Common+import YesodDsl.Generator.Input+import YesodDsl.Generator.Client+ +pureScriptFieldType :: Field -> String+pureScriptFieldType f = (if fieldOptional f then "Maybe " else "") + ++ case fieldContent f of+ NormalField ft -> case ft of+ FTWord32 -> "Int"+ FTWord64 -> "Number"+ FTInt32 -> "Int"+ FTInt -> "Number"+ FTInt64 -> "Number"+ FTText -> "String"+ FTBool -> "Boolean"+ FTDouble -> "Number"+ FTRational -> "Number"+ FTTimeOfDay -> "TimeOfDay"+ FTDay -> "Day" + FTUTCTime -> "UTCTime"+ FTCheckmark -> "Boolean"+ EntityField en -> en ++ "Id"+ EnumField en -> en+++moduleToPureScriptJs :: Module -> String+moduleToPureScriptJs m = T.unpack $(codegenFile "codegen/purescript-js.cg")+moduleToPureScript :: Module -> String+moduleToPureScript m = T.unpack $(codegenFile "codegen/purescript.cg")+ ++ concat [ handler r h | r <- modRoutes m, h <- routeHandlers r ]+ where+ enum e = T.unpack $(codegenFile "codegen/purescript-enum.cg")+ where+ value v = enumName e ++ v+ showValue v = T.unpack $(codegenFile "codegen/purescript-enum-show.cg")+ decodeValue v = rstrip $ T.unpack $(codegenFile "codegen/purescript-enum-decodevalue.cg")+ encodeValue v = T.unpack $(codegenFile "codegen/purescript-enum-encodevalue.cg")+ handler r h + | handlerType h == GetHandler = T.unpack $(codegenFile "codegen/purescript-handler-get.cg")+ | null $ handlerInputFields h =T.unpack $(codegenFile "codegen/purescript-handler-update-empty-body.cg")+ | otherwise = T.unpack $(codegenFile "codegen/purescript-handler-update.cg")+ where+ defineResultType+ | null $ handlerOutputFields m h = ""+ | otherwise = T.unpack $(codegenFile "codegen/purescript-handler-update-result-type.cg")+ resultType + | null $ handlerOutputFields m h = "Boolean"+ | otherwise = handlerEntityName ++ "Result"+ processResult + | null $ handlerOutputFields m h = T.unpack $(codegenFile "codegen/purescript-handler-update-boolean-result.cg")+ | otherwise = T.unpack $(codegenFile "codegen/purescript-handler-update-process-result.cg")+ field f = rstrip $ T.unpack $(codegenFile "codegen/purescript-field.cg")+ encodeJson (fn,Just f) = rstrip $ T.unpack $(codegenFile "codegen/purescript-encodejson-field.cg")+ encodeJson (fn,Nothing) = rstrip $ T.unpack $(codegenFile "codegen/purescript-encodejson-unknown.cg")++ decodeJsonExtract f = T.unpack $(codegenFile "codegen/purescript-decodejson-extract.cg")+ decodeJsonAssign f = rstrip $ T.unpack $(codegenFile "codegen/purescript-decodejson-assign.cg")++ handlerTypeName = upperFirst $ map toLower (show $ handlerType h) + handlerEntityName = handlerTypeName ++ concatMap pathName (routePath r) ++ inputField (fn,Just f) = rstrip $ T.unpack $(codegenFile "codegen/purescript-inputfield.cg")+ inputField (fn,Nothing) = rstrip $ T.unpack $(codegenFile "codegen/purescript-inputfield-unknown.cg")+ pathName pp = case pp of+ PathText t -> upperFirst t+ PathId _ en -> "_"+ + routePathParams r = mapMaybe (\(n,pp) -> case pp of+ PathText _ -> Nothing+ PathId _ en -> Just ("(Key p" ++ show (n::Int) ++ ")",en ++ "Id")) $ zip [1..] (routePath r)+ routePathUrl r = concatMap (\(n,pp) -> case pp of+ PathText t -> " ++ \"/" ++ t ++ "\""+ PathId _ _ -> " ++ \"/\" ++ show p" ++ show (n::Int)) $ zip [1..] (routePath r)+ + entity e = T.unpack $(codegenFile "codegen/purescript-entity.cg")
YesodDsl/Generator/Require.hs view
@@ -15,7 +15,7 @@ (do mw <- case sqWhere sq of Just expr -> do- e <- hsBoolExpr expr + e <- hsExpr 0 expr return $ "where_ (" ++ e ++ ")\n" Nothing -> return "" jes <- liftM concat $ mapM mapJoinExpr (reverse $ sqJoins sq)
YesodDsl/Generator/UpdateHandlers.hs view
@@ -39,7 +39,7 @@ let maybeExpr = rstrip $ T.unpack $(codegenFile "codegen/delete-all.cg") in T.unpack $(codegenFile "codegen/delete.cg") DeleteFrom (Right en) vn (Just e) -> - let maybeExpr = scopedBoolExpr (Map.fromList [(vn,(en,False))]) e+ let maybeExpr = scopedExpr (Map.fromList [(vn,(en,False))]) e in T.unpack $(codegenFile "codegen/delete.cg") For vn fr hps -> let content = concatMap updateHandlerRunDB $ zip [1..] hps@@ -77,7 +77,7 @@ promoteJust = fieldOptional f && isJust maybeInput && notNothing && notInputField mcontent - | null ifields && fieldInternal f == False = Just $ let fn = fieldName f in T.unpack $(codegenFile "codegen/map-input-field-normal.cg")+ | null ifields && fieldInternal f == False && fieldReadOnly f == False = Just $ let fn = fieldName f in T.unpack $(codegenFile "codegen/map-input-field-normal.cg") | otherwise = case maybeInput of Just (RequestField fn, mm) -> Just $ resultMapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-normal.cg") Just (AuthId, mm) -> Just $ resultMapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-authid.cg")@@ -111,7 +111,8 @@ let maybeExisting = maybeSelectExisting e (mv,fields) fr fieldMappers = mapFields e fields isNew- isNew = isNothing fr && isNothing mv+ isMatched = ((`elem` (map (\(pn,_,_) -> pn) fields)) . fieldName)+ isNew = (isNothing fr || all isMatched (entityFields e)) && isNothing mv entityToUpdate | isNew = entityName e | otherwise = "e"
YesodDsl/Lexer.x view
@@ -90,6 +90,7 @@ "TimeOfDay" { mkT TTimeOfDay } "UTCTime" { mkT TUTCTime } "sql" { mkT TSql }+ "map" { mkT TMap } "json" { mkT TJson } "default-filter-sort" { mkT TDefaultFilterSort } "param" { mkT TParam }@@ -115,6 +116,7 @@ "$request" { mkT TRequest } "require" { mkT TRequire } "internal" { mkT TInternal }+ "read-only" { mkT TReadOnly } "extract" { mkT TExtract } "concat" { mkT TConcat } "return" { mkT TReturn }@@ -123,7 +125,6 @@ $digit+ { mkTvar (TInt . read) } $digit+ "." $digit+ { mkTvar (TFloat . read) } "now" { mkT TNow }- "random" { mkT TRandom } "ceiling" { mkT TCeiling } "floor" { mkT TFloor } "exists" { mkT TExists }@@ -246,12 +247,12 @@ | TAuth | TReturn | TInternal+ | TReadOnly | TRequire | TUnderScore | TFor | TExtract | TConcat- | TRandom | TFloor | TCeiling | TExists@@ -259,6 +260,7 @@ | TCheckmarkActive | TCheckmarkInactive | TSql+ | TMap | TJson deriving (Show)
YesodDsl/Parser.y view
@@ -43,6 +43,7 @@ hash { Tk _ THash } equals { Tk _ TEquals } sql { Tk _ TSql }+ map { Tk _ TMap } jsonTk { Tk _ TJson } concatop { Tk _ TConcatOp } ne { Tk _ TNe }@@ -132,11 +133,11 @@ return { Tk _ TReturn } require { Tk _ TRequire } internal { Tk _ TInternal }+ readonly { Tk _ TReadOnly } underscore { Tk _ TUnderScore } for { Tk _ TFor } extract { Tk _ TExtract } concat { Tk _ TConcat }- random { Tk _ TRandom } floor { Tk _ TFloor } ceiling { Tk _ TCeiling } exists { Tk _ TExists }@@ -144,9 +145,12 @@ checkmarkActive { Tk _ TCheckmarkActive } checkmarkInactive { Tk _ TCheckmarkInactive } -%left in +%left and or+%right in +%nonassoc equals ne lt gt le ge like ilike is %left plus minus %left asterisk slash+%left concatop %% @@ -323,6 +327,9 @@ } fieldRefList : { [ ] } | fieldRefList fieldRef { $1 ++ [$2] }++fieldRefCommaList : fieldRef { [$1] }+ | fieldRefCommaList comma fieldRef { $1 ++ [$3] } fieldRef : value { Const $1 } | now lparen rparen { Now }@@ -515,19 +522,19 @@ requireHandlerType l1 "default-filter-sort" (==GetHandler) return DefaultFilterSort }- | if param stringval equals localParam then pushScope joins where expr popScope {% + | if param stringval equals localParam then pushScope joins where expr maybeOrder popScope {% do l1 <- mkLoc $1 statement l1 "if-then" requireHandlerType l1 "if-then" (==GetHandler)- return $ IfFilter ($3 ,$8 ,$10, True) + return $ IfFilter ($3 ,$8 ,$10, $11, True) }- | if param stringval equals underscore then pushScope joins where expr popScope {% + | if param stringval equals underscore then pushScope joins where expr maybeOrder popScope {% do l1 <- mkLoc $1 statement l1 "if-then" requireHandlerType l1 "if-then" (==GetHandler)- return $ IfFilter ($3, $8, $10, False) + return $ IfFilter ($3, $8, $10, $11, False) } | return json {% do@@ -552,9 +559,22 @@ | lowerIdTk fieldRefList {% do l <- mkLoc $1- statement l (tkString $1)- return $ Call (tkString $1) $2+ let s1 = tkString $1+ statement l s1+ withSymbol l s1 requireFunction+ return $ Call s1 $2 } + | map jsonTk with lowerIdTk {%+ do+ l <- mkLoc $1+ let s4 = tkString $4+ statement l "map json"+ requireHandlerType l "map json" (==GetHandler)+ l4 <- mkLoc $4+ withSymbol l4 s4 requireFunction+ + return $ MapJson (tkString $4) + } lowerIdParam: lowerIdTk {% do l1 <- mkLoc $1@@ -585,17 +605,16 @@ | lowerIdTk dot lowerIdTk maybeSelectAlias {% do l1 <- mkLoc $1+ let v = Var (tkString $1) (Left "") False if tkString $3 == "id"- then return (l1, SelectIdField (Var (tkString $1) (Left "") False) $4) - else return (l1, SelectField (Var (tkString $1) (Left "") False) (tkString $3) $4) + then return (l1, SelectIdField v $4)+ else return (l1, SelectField v (tkString $3) $4) }- | valexpr as lowerIdTk {% + | expr as lowerIdTk {% do l3 <- mkLoc $3- return (l3, SelectValExpr $1 (tkString $3) )- }- - + return (l3, SelectExpr $1 (tkString $3) )+ } maybeSelectAlias: { Nothing } | as lowerIdTk { Just $ tkString $2 } joins : { [] }@@ -619,7 +638,16 @@ orderByList : orderByListitem { [$1] } | orderByList comma orderByListitem { $3 : $1 }-orderByListitem : fieldRef orderByDir { ($1, $2) }+orderByListitem :+ fieldRef orderByDir { (Nothing, [$1], $2) }+ | lowerIdTk lparen fieldRefCommaList rparen orderByDir + {%+ do+ l1 <- mkLoc $1+ let s1 = tkString $1 + withSymbol l1 s1 requireFunction+ return $ (Just s1, $3, $5)+ } orderByDir : asc { SortAsc } |desc { SortDesc }@@ -665,64 +693,60 @@ -binop : equals { Eq }- | ne { Ne }- | lt { Lt }- | gt { Gt }- | le { Le }- | ge { Ge }- | like { Like }- | ilike {Ilike }- | is { Is }- | in { In }- | not in { NotIn }-expr : expr and expr { AndExpr $1 $3 }- | expr or expr { OrExpr $1 $3 }- | not expr { NotExpr $2 }- | lparen expr rparen { $2 } - | valexpr binop valexpr { BinOpExpr $1 $2 $3 }+ +expr : + lparen expr rparen { $2 }+ | not expr { UnOpExpr Not $2 } | exists lparen pushScope selectQuery popScope rparen { ExistsExpr $4 }+ | fieldRef { FieldExpr $1 }+ | expr and expr { BinOpExpr $1 And $3 }+ | expr or expr { BinOpExpr $1 Or $3 }+ | expr equals expr { BinOpExpr $1 Eq $3 }+ | expr ne expr { BinOpExpr $1 Ne $3 }+ | expr lt expr { BinOpExpr $1 Lt $3 }+ | expr gt expr { BinOpExpr $1 Gt $3 }+ | expr le expr { BinOpExpr $1 Le $3 }+ | expr ge expr { BinOpExpr $1 Ge $3 }+ | expr like expr { BinOpExpr $1 Like $3 }+ | expr ilike expr { BinOpExpr $1 Ilike $3 }+ | expr is expr { BinOpExpr $1 Is $3 }+ | expr in expr { BinOpExpr $1 In $3 }+ | expr not in expr { BinOpExpr $1 NotIn $4 }+ | expr slash expr { BinOpExpr $1 Div $3 }+ | expr asterisk expr { BinOpExpr $1 Mul $3 }+ | expr plus expr { BinOpExpr $1 Add $3 }+ | expr minus expr { BinOpExpr $1 Sub $3 }+ | expr concatop expr { BinOpExpr $1 Concat $3 }+ | concat lparen exprlist rparen { ConcatManyExpr (reverse $3) }+ | floor lparen expr rparen { UnOpExpr Floor $3 }+ | ceiling lparen expr rparen { UnOpExpr Ceiling $3 }+ | extract lparen lowerIdTk from expr rparen {% + do+ let s3 = tkString $3+ l3 <- mkLoc $3 + validateExtractField l3 s3+ return $ UnOpExpr (Extract (tkString $3)) $5 + }+ | lparen pushScope selectQuery popScope rparen+ { SubQueryExpr $3 } | lowerIdTk functionParamList {%- do- l1 <- mkLoc $1- let s1 = tkString $1- withSymbol l1 s1 requireFunction- return $ ExternExpr s1 $2+ do+ l1 <- mkLoc $1+ let s1 = tkString $1+ withSymbol l1 s1 requireFunction+ return $ ExternExpr s1 $2 } + + functionParamList: functionParam { [$1] } | functionParamList functionParam { $1 ++ [$2] } functionParam: fieldRef { FieldRefParam $1 } | verbatim { VerbatimParam (tkString $1) } --valbinop : - slash { Div }- | asterisk { Mul } - | plus { Add }- | minus { Sub }- | concatop { Concat }--valexpr : lparen valexpr rparen { $2 }- | fieldRef { FieldExpr $1 }- | valexpr valbinop valexpr { ValBinOpExpr $1 $2 $3 }- | concat lparen valexprlist rparen { ConcatManyExpr (reverse $3) }- | random lparen rparen { RandomExpr }- | floor lparen valexpr rparen { FloorExpr $3 }- | ceiling lparen valexpr rparen { CeilingExpr $3 }- | extract lparen lowerIdTk from valexpr rparen {% - do- let s3 = tkString $3- l3 <- mkLoc $3 - validateExtractField l3 s3- return $ ExtractExpr (tkString $3) $5 - }- | lparen pushScope selectQuery popScope rparen- { SubQueryExpr $3 }--valexprlist: valexpr { [$1] } - | valexprlist comma valexpr { $3 : $1 }+exprlist: expr { [$1] } + | exprlist comma expr { $3 : $1 } maybeJoinOn : { Nothing } | on expr { Just $2 }@@ -860,6 +884,12 @@ do l <- mkLoc $1 declare l "internal field" SReserved+ return $ FieldInternal+ }+ | readonly {%+ do+ l <- mkLoc $1+ declare l "readonly field" SReserved return $ FieldInternal }
YesodDsl/Simplify.hs view
@@ -10,16 +10,14 @@ simplify :: Module -> Module-simplify m = everywhere ((mkT sHandler) . (mkT sValExpr) . (mkT sBoolExpr)+simplify m = everywhere ((mkT sHandler) . (mkT sExpr) . (mkT sStmt) . (mkT mapEntityRef)) m where- sValExpr (SubQueryExpr sq) = SubQueryExpr $ mapSq sq- sValExpr x = x-- sBoolExpr (ExistsExpr sq) = ExistsExpr $ mapSq sq- sBoolExpr x = x+ sExpr (SubQueryExpr sq) = SubQueryExpr $ mapSq sq+ sExpr (ExistsExpr sq) = ExistsExpr $ mapSq sq+ sExpr x = x sStmt (Require sq) = Require $ mapSq sq- sStmt (IfFilter (pn,js,be,uf)) = IfFilter (pn, map mapJoin js, be, uf)+ sStmt (IfFilter (pn,js,be,ob,uf)) = IfFilter (pn, map mapJoin js, be, ob, uf) sStmt (Select sq) = Select $ mapSq sq sStmt x = x @@ -27,11 +25,11 @@ sqJoins = map mapJoin $ sqJoins sq } in sq' { sqFields = concatMap (expand sq') $ sqFields sq',- sqWhere = everywhere ((mkT sValExpr) . (mkT sBoolExpr)) $ sqWhere sq'+ sqWhere = everywhere (mkT sExpr) $ sqWhere sq' } mapJoin j = j { joinEntity = mapEntityRef $ joinEntity j,- joinExpr = joinExpr j >>= Just . (everywhere $ (mkT sValExpr) . (mkT sBoolExpr))+ joinExpr = joinExpr j >>= Just . (everywhere $ (mkT sExpr)) } lookupEntity en = L.find ((==en) . entityName) $ modEntities m@@ -57,7 +55,7 @@ where baseAliases = Map.unions [ sqAliases sq | Select sq <- universeBi h ] mapStmt df@(DeleteFrom er vn _) = everywhere (mkT $ mapSqVarRef $ Map.unions [ baseAliases, Map.fromList $ rights [ er >>= \e -> Right (vn, (e, False)) ] ]) df- mapStmt i@(IfFilter (_,js,_,_)) = everywhere (mkT $ mapSqVarRef $ Map.unions [ baseAliases, Map.fromList $ rights [ joinEntity j >>= \e -> Right (joinAlias j,(e, isOuterJoin $ joinType j)) | j <- js ] ]) i+ mapStmt i@(IfFilter (_,js,_,_,_)) = everywhere (mkT $ mapSqVarRef $ Map.unions [ baseAliases, Map.fromList $ rights [ joinEntity j >>= \e -> Right (joinAlias j,(e, isOuterJoin $ joinType j)) | j <- js ] ]) i mapStmt i = i mapSq sq = everywhere (mkT $ mapSqVarRef $ sqAliases sq) sq mapSqVarRef aliases (Var vn (Left "") _) = case Map.lookup vn aliases of
codegen/base-if-filter-nouse.cg view
@@ -1,5 +1,5 @@ if FS.hasDefaultFilter filterParam_~{pn} defaultFilterJson "~{pn}" then ~{maybeFrom} -~{indent 12 joinExprs} +~{indent 16 joinExprs} where_ $ ~{expr}- else return ()+~{indent 16 $ maybeOrderBy sortFields} else return ()
codegen/base-if-filter.cg view
@@ -2,4 +2,4 @@ Just localParam -> ~{maybeFrom} ~{indent 16 joinExprs} where_ $ ~{expr}- Nothing -> return ()+~{indent 16 $ maybeOrderBy sortFields} Nothing -> return ()
codegen/base-select-query.cg view
@@ -1,10 +1,8 @@ let baseQuery limitOffsetOrder = from $ \(~{selectVar} ~{concatMap joinDef (sqJoins sq)}) -> do ~{indent 8 $ joinExprs} let ~{selectVar}Id' = ~{selectVar} ^. ~{entityRefName selectEntity}Id ~{indent 8 $ maybeWhere}- _ <- if limitOffsetOrder- then do - offset ~{show offset}- limit ~{show limit}-~{indent 16 $ maybeDefaultSortFields}-~{indent 16 $ maybeDefaultLimitOffset} - else return ()+ _ <- when limitOffsetOrder $ do+ offset ~{show offset}+ limit ~{show limit}+~{indent 12 $ maybeDefaultSortFields}+~{indent 12 $ maybeDefaultLimitOffset}
codegen/class-entity-instances.cg view
@@ -2,4 +2,8 @@ data ~{className c}InstanceId = ~{intercalate " | " $ map entityInstanceId es} deriving (Eq, Ord) +reflect~{className c}InstanceId :: ~{className c}InstanceId -> (Text, Int64)+reflect~{className c}InstanceId x = case x of+~{indent 4 $ concatMap reflectEntityInstanceId es}+ instance ~{className c} ~{className c}Instance where
codegen/class-select.cg view
@@ -1,3 +1,8 @@+lookup~{className c}Instance :: forall (m :: * -> *). (MonadIO m) =>+ ~{className c}InstanceId -> SqlPersistT m (Maybe ~{className c}Instance)+lookup~{className c}Instance k = case k of+~{indent 4 $ concatMap lookupInstance es}+ select~{className c} :: forall (m :: * -> *). (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m) => ~{maybeFilterType} SqlPersistT m [~{className c}Instance]
+ codegen/default-sort-fields-check-if-filter-order-by.cg view
@@ -0,0 +1,1 @@+when (null $ catMaybes [ ~{intercalate ", " ifFilterOrderBys} ]) $
codegen/default-sort-fields.cg view
@@ -3,4 +3,4 @@ ~{indent 12 $ fields} _ -> return () ) xs- Nothing -> orderBy [ ~{intercalate ", " staticSortFields} ]+ Nothing -> ~{checkIfFilterOrderBy}orderBy [ ~{intercalate ", " staticSortFields} ]
codegen/get-handler-return.cg view
@@ -1,4 +1,4 @@- return $ A.object [+ (return $ A.object [ "totalCount" .= ((\(Database.Esqueleto.Value v) -> (v::Int)) (head count)), "result" .= (toJSON $ map (\row -> case row of (~{intercalate ", " resultFields}) -> A.object [@@ -6,4 +6,4 @@ ] _ -> A.object [] ) results)- ]+ ])~{concatMap prependBind jsonMappers}
codegen/header.cg view
@@ -10,6 +10,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}@@ -22,6 +23,7 @@ import Prelude import Control.Monad (forM_, when) import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Database.Esqueleto import qualified Database.Esqueleto as E import qualified Database.Persist as P
+ codegen/hs-client-entity.cg view
@@ -0,0 +1,2 @@+data ~{entityName e} = ~{entityName e}+type ~{entityName e}Id = Key ~{entityName e}
+ codegen/hs-client-enum.cg view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.~{enumName e} where+import qualified Data.Aeson.TH as AT++data ~{enumName e} = ~{intercalate " | " $ enumValues e} + deriving (Show, Eq, Ord, Read)++$(AT.deriveJSON AT.defaultOptions ''~{enumName e})
+ codegen/hs-client-enums.cg view
@@ -0,0 +1,7 @@+module ~{moduleName m}Client.Enums (+~{indent 4 $ intercalate ",\n" $ map (rstrip . exportEnum) $ modEnums m}+) where++~{concatMap importEnum $ modEnums m}++
+ codegen/hs-client-export-enum.cg view
@@ -0,0 +1,1 @@+module ~{enumName e}, ~{enumName e}.~{enumName e}
+ codegen/hs-client-field-label-modifier.cg view
@@ -0,0 +1,1 @@+"~{src}" -> "~{dst}"
+ codegen/hs-client-field-label-modifiers.cg view
@@ -0,0 +1,5 @@+{ + AT.fieldLabelModifier = \x -> case x of +~{indent 8 $ concatMap fieldLabelModifier fieldLabelModifiers} _ -> x+}+
+ codegen/hs-client-field.cg view
@@ -0,0 +1,1 @@+~{safeHsName $ fieldJsonName f} :: ~{hsFieldType f}
+ codegen/hs-client-handler-get.cg view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.~{handlerEntityName} where++import qualified Data.Aeson as A+import qualified Network.Wreq as W+import qualified Network.Wreq.Session as WS+import qualified Network.Wreq.Types as WT+import qualified Data.Aeson.TH as AT++import ~{moduleName m}Client.Result+import ~{moduleName m}Client.Types+import ~{moduleName m}Client.Enums+import ~{moduleName m}Client.Json++data Record = Record {+~{indent 4 $ intercalate ",\n" $ map field $ handlerOutputFields m h}}++$(AT.deriveJSON AT.defaultOptions~{maybeFieldLabelModifier} ''Record)++get :: WS.Session -> WT.Options -> String~{concatMap (prepend " -> ") $ map snd $ routePathParams r} -> IO (W.Response (Result Record))+get s opts baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r} = W.asJSON =<< WS.getWith opts s (baseUrl~{routePathUrl r}) +
+ codegen/hs-client-handler-update-empty-body.cg view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.~{handlerEntityName} where++import qualified Data.Aeson as A+import qualified Network.Wreq as W+import qualified Network.Wreq.Session as WS+import qualified Network.Wreq.Types as WT+import qualified Data.Aeson.TH as AT++import ~{moduleName m}Client.Types+import ~{moduleName m}Client.Enums+import ~{moduleName m}Client.Json++~{defineResultType}+~{methodName} :: WS.Session -> WT.Options -> String~{concatMap (prepend " -> ") $ map snd $ routePathParams r} -> IO (W.Response Result)+~{methodName} s opts baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r} = W.asJSON =<< WS.~{methodName}With opts s (baseUrl~{routePathUrl r}) ~{ifBodyAllowed "(A.object [])"}+
+ codegen/hs-client-handler-update-result-type.cg view
@@ -0,0 +1,4 @@+data Result = Result {+~{indent 4 $ intercalate ",\n" $ map field $ handlerOutputFields m h}}++$(AT.deriveJSON AT.defaultOptions ''Result)
+ codegen/hs-client-handler-update.cg view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.~{handlerEntityName} where++import qualified Data.Aeson as A+import qualified Network.Wreq as W+import qualified Network.Wreq.Session as WS+import qualified Network.Wreq.Types as WT+import qualified Data.Aeson.TH as AT++import ~{moduleName m}Client.Types+import ~{moduleName m}Client.Enums+import ~{moduleName m}Client.Json++data Request = Request {+~{indent 4 $ intercalate ",\n" $ map inputField $ handlerInputFields h}}++$(AT.deriveJSON AT.defaultOptions ''Request)++~{defineResultType}+~{methodName} :: WS.Session -> WT.Options -> String~{concatMap (prepend " -> ") $ map snd $ routePathParams r}~{ifBodyAllowed " -> Request"} -> IO (W.Response Result)+~{methodName} s opts baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r}~{ifBodyAllowed " request"} = W.asJSON =<< WS.~{methodName}With opts s (baseUrl~{routePathUrl r}) ~{ifBodyAllowed "(A.toJSON request)"}+
+ codegen/hs-client-idtypes-entity.cg view
@@ -0,0 +1,2 @@+data ~{entityName e} = ~{entityName e}+type ~{entityName e}Id = Key ~{entityName e}
+ codegen/hs-client-import-enum.cg view
@@ -0,0 +1,1 @@+import qualified ~{moduleName m}Client.~{enumName e} as ~{enumName e}
+ codegen/hs-client-inputfield-unknown.cg view
@@ -0,0 +1,1 @@+~{fn} :: A.Value
+ codegen/hs-client-inputfield.cg view
@@ -0,0 +1,1 @@+~{fieldName f} :: ~{hsFieldType f}
+ codegen/hs-client-json.cg view
@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+module ~{moduleName m}Client.Json where++import Data.Aeson+import Data.Time+import Control.Monad (mzero)++instance ToJSON Day where+ toJSON = toJSON . show++#ifndef no_FromJSON_Day+instance FromJSON Day where+ parseJSON x = do+ s <- parseJSON x+ case reads s of+ (d, _):_ -> return d+ [] -> mzero+#endif++instance ToJSON TimeOfDay where+ toJSON = toJSON . show++instance FromJSON TimeOfDay where+ parseJSON x = do+ s <- parseJSON x+ case reads s of+ (d, _):_ -> return d+ [] -> mzero
+ codegen/hs-client-result.cg view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.Result where++import Data.Int+import Data.Aeson.TH++data Result a = Result {+ result :: [a],+ totalCount :: Int64+}+$(deriveJSON defaultOptions ''Result)+
+ codegen/hs-client-types.cg view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}+module ~{moduleName m}Client.Types (+ module ~{moduleName m}Client.Types,+ module Data.Text,+ module Data.Int,+ module Data.Word,+ module Data.Time) where++import Prelude+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)+import Data.Text (Text)+import Data.Time (UTCTime, Day, TimeOfDay)+import Data.Aeson+import Data.Aeson.TH++newtype Key entity = Key Int64 deriving (Show, Read, Ord, Eq)++instance FromJSON (Key entity) where+ parseJSON = (fmap Key) . parseJSON++instance ToJSON (Key entity) where+ toJSON (Key x) = toJSON x ++~{concatMap entityIdType $ modEntities m} ++data Checkmark = Active | Inactive deriving (Eq, Ord, Show, Read)+$(deriveJSON defaultOptions ''Checkmark)
+ codegen/hs-client.cg view
@@ -0,0 +1,14 @@+module ~{moduleName m}Client (+ module ~{moduleName m}Client.Types,+ module ~{moduleName m}Client.Result,+ module ~{moduleName m}Client.Enums+) where++import ~{moduleName m}Client.Types+import ~{moduleName m}Client.Result+import ~{moduleName m}Client.Enums+++++
+ codegen/if-filter-order-by.cg view
@@ -0,0 +1,1 @@+when limitOffsetOrder $ orderBy [ ~{intercalate ", " sortFields} ]
codegen/input-field-auth.cg view
@@ -1,1 +1,1 @@-user~{upperFirst fn} __auth+(user~{upperFirst fn} __auth)
codegen/json-wrapper.cg view
@@ -1,12 +1,14 @@ instance ToJSON Day where toJSON = toJSON . show +#ifdef FromJSON_Day instance FromJSON Day where parseJSON x = do s <- parseJSON x case reads s of (d, _):_ -> return d [] -> mzero +#endif instance ToJSON TimeOfDay where toJSON = toJSON . show
+ codegen/lookup-class-instance.cg view
@@ -0,0 +1,3 @@+ ~{className c}Instance~{entityName e}Id key -> runMaybeT $ do+ val <- MaybeT $ get key+ return $ ~{className c}Instance~{entityName e} $ Entity key val
codegen/map-input-field-auth.cg view
@@ -1,1 +1,1 @@-user~{upperFirst fn} __auth+(user~{upperFirst fn} __auth)
+ codegen/purescript-decodejson-assign.cg view
@@ -0,0 +1,2 @@+~{fieldName f} : ~{fieldName f}_+
+ codegen/purescript-decodejson-extract.cg view
@@ -0,0 +1,1 @@+~{fieldName f}_ <- x .? "~{fieldJsonName f}"
+ codegen/purescript-encodejson-field.cg view
@@ -0,0 +1,1 @@+"~{fn}" := x.~{fieldName f}
+ codegen/purescript-encodejson-unknown.cg view
@@ -0,0 +1,1 @@+"~{fn}" := x.~{fn}
+ codegen/purescript-entity.cg view
@@ -0,0 +1,2 @@+data ~{entityName e} = ~{entityName e}+type ~{entityName e}Id = Key ~{entityName e}
+ codegen/purescript-enum-decodevalue.cg view
@@ -0,0 +1,1 @@+"~{v}" -> pure ~{enumName e}~{v}
+ codegen/purescript-enum-encodevalue.cg view
@@ -0,0 +1,1 @@+~{enumName e}~{v} -> "~{v}"
+ codegen/purescript-enum-show.cg view
@@ -0,0 +1,1 @@+show ~{enumName e}~{v} = "~{v}"
+ codegen/purescript-enum.cg view
@@ -0,0 +1,22 @@+data ~{enumName e} = ~{intercalate " | " $ map value $ enumValues e}++derive instance ~{lowerFirst $ enumName e}Generic :: Generic ~{enumName e}++instance show~{enumName e} :: Show ~{enumName e} where+~{indent 4 $ concatMap showValue $ enumValues e}++instance eq~{enumName e} :: Eq ~{enumName e} where+ eq = gEq++instance ord~{enumName e} :: Ord ~{enumName e} where+ compare = gCompare++instance decodeJson~{enumName e} :: DecodeJson ~{enumName e} where+ decodeJson json = do+ x <- decodeJson json+ case x of+~{indent 12 $ intercalate "\n" $ map decodeValue $ enumValues e} _ -> Left $ "Invalid ~{enumName e} value: " ++ x+ +instance encodeJson~{enumName e} :: EncodeJson ~{enumName e} where+ encodeJson x = encodeJson $ case x of+~{indent 8 $ concatMap encodeValue $ enumValues e}
+ codegen/purescript-field.cg view
@@ -0,0 +1,1 @@+~{fieldName f} :: ~{pureScriptFieldType f}
+ codegen/purescript-handler-get.cg view
@@ -0,0 +1,19 @@+newtype ~{handlerEntityName} = ~{handlerEntityName} {+~{indent 4 $ intercalate ",\n" $ map field $ handlerOutputFields m h}}++instance decodeJson~{handlerEntityName} :: DecodeJson ~{handlerEntityName} where+ decodeJson json = do+ x <- decodeJson json+~{indent 8 $ concatMap decodeJsonExtract $ handlerOutputFields m h}+ pure $ ~{handlerEntityName} {+~{indent 12 $ intercalate ",\n" $ map decodeJsonAssign $ handlerOutputFields m h} }+++~{lowerFirst handlerEntityName} :: forall e. Affjax.URL~{concatMap (prepend " -> ") $ map snd $ routePathParams r} -> Array RH.RequestHeader -> URIT.Query -> Aff.Aff (ajax :: Affjax.AJAX | e) (Either String (Result ~{handlerEntityName}))+~{lowerFirst handlerEntityName} baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r} headers query = do+ r <- Affjax.affjax $ Affjax.defaultRequest {+ url = baseUrl~{routePathUrl r} ++ URIQ.printQuery query,+ headers = headers+ }+ pure $ jsonParser r.response >>= decodeJson+
+ codegen/purescript-handler-update-boolean-result.cg view
@@ -0,0 +1,2 @@+let response = r.response :: String+pure $ Right $ r.status == SC.StatusCode 200
+ codegen/purescript-handler-update-empty-body.cg view
@@ -0,0 +1,12 @@+~{defineResultType}+++~{lowerFirst handlerEntityName} :: forall e. Affjax.URL~{concatMap (prepend " -> ") $ map snd $ routePathParams r} -> Array RH.RequestHeader -> Aff.Aff (ajax :: Affjax.AJAX | e) (Either String ~{resultType})+~{lowerFirst handlerEntityName} baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r} headers = do+ r <- Affjax.affjax $ Affjax.defaultRequest {+ method = ~{show $ handlerType h},+ url = baseUrl~{routePathUrl r},+ headers = headers+ }+~{indent 4 $ processResult}+
+ codegen/purescript-handler-update-process-result.cg view
@@ -0,0 +1,1 @@+pure $ jsonParser r.response >>= decodeJson
+ codegen/purescript-handler-update-result-type.cg view
@@ -0,0 +1,2 @@+type ~{handlerEntityName}Result = {+~{indent 4 $ intercalate ",\n" $ map field $ handlerOutputFields m h}}
+ codegen/purescript-handler-update.cg view
@@ -0,0 +1,19 @@+~{defineResultType}++newtype ~{handlerEntityName} = ~{handlerEntityName} {+~{indent 4 $ intercalate ",\n" $ map inputField $ handlerInputFields h}}++instance encodeJson~{handlerEntityName} :: EncodeJson ~{handlerEntityName} where+ encodeJson (~{handlerEntityName} x) = do+~{indent 8 $ intercalate "\n~> " $ map encodeJson $ handlerInputFields h} ~> jsonEmptyObject++~{lowerFirst handlerEntityName} :: forall e. Affjax.URL~{concatMap (prepend " -> ") $ map snd $ routePathParams r} -> Array RH.RequestHeader -> ~{handlerEntityName} -> Aff.Aff (ajax :: Affjax.AJAX | e) (Either String ~{resultType})+~{lowerFirst handlerEntityName} baseUrl~{concatMap (prepend " ") $ map fst $ routePathParams r} headers content = do+ r <- Affjax.affjax $ Affjax.defaultRequest {+ method = ~{show $ handlerType h},+ url = baseUrl~{routePathUrl r},+ headers = headers,+ content = Just (show $ encodeJson content)+ }+~{indent 4 $ processResult}+
+ codegen/purescript-inputfield-unknown.cg view
@@ -0,0 +1,1 @@+~{fn} :: Json
+ codegen/purescript-inputfield.cg view
@@ -0,0 +1,1 @@+~{fieldName f} :: ~{pureScriptFieldType f}
+ codegen/purescript-js.cg view
@@ -0,0 +1,25 @@+// module ~{moduleName m}++// from https://github.com/slamdata/purescript-jtable/blob/master/src/Data/Json/JSemantic.js++exports.s2nImpl = function(Just) {+ return function(Nothing) {+ return function(s) {+ var n = s * 1;+ if (isNaN(n)) {+ return Nothing;+ }+ else {+ return Just(n);+ }+ };+ };+};++exports.toString = function(d) {+ return d.toString();+};++exports.jsDateToISOString = function(d) {+ return d.toISOString();+};
+ codegen/purescript.cg view
@@ -0,0 +1,182 @@+module ~{moduleName m} where+import Prelude+import Data.Argonaut.Combinators ((~>), (:=), (.?))+import Data.Argonaut.Parser (jsonParser)+import Data.Argonaut.Core (jsonEmptyObject, Json(..))+import Data.Argonaut.Encode (EncodeJson, encodeJson)+import Data.Argonaut.Decode (DecodeJson, decodeJson)+import Data.Maybe (Maybe(..), fromMaybe)+import Data.Generic+import Data.Either (Either(..))+import qualified Data.URI as URI+import qualified Data.URI.Types as URIT+import qualified Data.URI.Query as URIQ+import Data.Array ((!!))+import qualified Control.Monad.Aff as Aff+import qualified Network.HTTP.Affjax as Affjax+import qualified Network.HTTP.RequestHeader as RH+import Network.HTTP.Method (Method(POST, PUT, DELETE))+import qualified Network.HTTP.StatusCode as SC+import qualified Data.String as DS+import qualified Data.Date as DD+import qualified Data.Time as DT+import qualified Data.String.Regex as R+import qualified Data.Int as I++foreign import s2nImpl :: (Number -> Maybe Number) -> Maybe Number -> String -> Maybe Number++foreign import jsDateToISOString :: DD.JSDate -> String++stringToNumber :: String -> Maybe Number+stringToNumber = s2nImpl Just Nothing++newtype TimeOfDay = TimeOfDay Number++derive instance genericTimeOfDay :: Generic TimeOfDay++timeOfDayRegex :: R.Regex+timeOfDayRegex = R.regex "([0-1][0-9]|2[0-3]):([0-5][0-9]):([0-5][0-9]|60)(\\.\\d+)?" R.noFlags++instance showTimeOfDay :: Show TimeOfDay where+ show (TimeOfDay secs) = DS.joinWith ":" [h,zp m++m,zp s++s] ++ fromMaybe "" frac+ where+ ss = I.floor secs+ h = show $ ss `div` 3600+ m = show $ (ss `div` 60) `mod` 60+ zp x = if DS.length x < 2 then "0" else ""+ s = show $ ss `mod` 60+ r = secs - I.toNumber ss+ frac + | r > 0.0 = Just $ show r+ | otherwise = Nothing+++instance eqTimeOfDay :: Eq TimeOfDay where+ eq = gEq++instance ordTimeOfDay :: Ord TimeOfDay where+ compare = gCompare++instance decodeJsonTimeOfDay :: DecodeJson TimeOfDay where+ decodeJson json = do+ x <- decodeJson json+ fromMaybe (Left $ "Invalid TimeOfDay: " ++ x) $ do+ r <- R.match timeOfDayRegex x+ h <- parseInt r 1+ m <- parseInt r 2+ s <- parseInt r 3+ Just $ pure $ TimeOfDay $ secs h m s + frac (r !! 4)+ where+ parseInt r idx = do+ me <- r !! idx+ e <- me+ I.fromString e+ secs h m s = I.toNumber $ h * 3600 + m * 60 + s+ frac (Just mms) = fromMaybe 0.0 $ do+ mss <- mms+ ms <- stringToNumber mss+ Just $ ms+ frac Nothing = 0.0++instance encodeJsonTimeOfDay :: EncodeJson TimeOfDay where+ encodeJson s = encodeJson $ show s+data Day = Day Int Int Int++derive instance genericDay :: Generic Day++dayRegex :: R.Regex+dayRegex = R.regex "([0-9]{4})-(0[1-9]|1[0-2])-(0[1-9]|[1-2][0-9]|3[0-1])" R.noFlags++instance showDay :: Show Day where+ show = gShow++instance eqDay :: Eq Day where+ eq = gEq++instance ordDay :: Ord Day where+ compare = gCompare++instance decodeJsonDay :: DecodeJson Day where+ decodeJson json = do+ x <- decodeJson json+ fromMaybe (Left $ "Invalid Day: " ++ x) $ do+ r <- R.match dayRegex x+ y <- parseInt r 1+ m <- parseInt r 2+ d <- parseInt r 3+ Just $ pure $ Day y m d+ where+ parseInt r idx = do+ me <- r !! idx+ e <- me+ I.fromString e+ +instance encodeJsonDay :: EncodeJson Day where+ encodeJson (Day y m d) = encodeJson $ DS.joinWith "-" [ys, ms, ds]+ where+ ys = show y+ ms = pfxZero m+ ds = pfxZero d+ pfxZero v = (if v < 10 then "0" else "") ++ show v+ ++newtype UTCTime = UTCTime DD.Date+++instance showUTCTime :: Show UTCTime where+ show (UTCTime d)= show d++instance eqUTCTime :: Eq UTCTime where+ eq (UTCTime d1) (UTCTime d2) = d1 `eq` d2++instance ordUTCTime :: Ord UTCTime where+ compare (UTCTime d1) (UTCTime d2) = compare d1 d2++instance decodeJsonUTCTime :: DecodeJson UTCTime where+ decodeJson json = do+ x <- decodeJson json+ case DD.fromStringStrict x of+ Just d -> pure $ UTCTime d+ Nothing -> Left $ "Invalid UTCTime: " ++ x+ +instance encodeJsonUTCTime :: EncodeJson UTCTime where+ encodeJson (UTCTime d) = encodeJson $ jsDateToISOString $ DD.toJSDate d++data Key record = Key Number++derive instance genericKey :: Generic (Key record)++instance showKey :: Show (Key record) where+ show = gShow++instance eqKey :: Eq (Key record) where+ eq = gEq++instance ordKey :: Ord (Key record) where+ compare = gCompare++instance decodeJsonKey :: DecodeJson (Key record) where+ decodeJson json = do+ x <- decodeJson json+ pure $ Key x++instance encodeJsonKey :: EncodeJson (Key record) where+ encodeJson (Key x) = encodeJson x++++data Result record = Result (Array record) Int++instance decodeJsonResult :: (DecodeJson record) => DecodeJson (Result record) where+ decodeJson json = do+ obj <- decodeJson json+ result <- obj .? "result"+ recs <- decodeJson result+ totalCount <- obj .? "totalCount"++ pure $ Result recs totalCount++ +~{concatMap enum $ modEnums m}+~{concatMap entity $ modEntities m}+
+ codegen/reflect-class-entity-instance-id.cg view
@@ -0,0 +1,1 @@+~{className c}Instance~{entityName e}Id key -> ("~{entityName e}", fromSqlKey key)
codegen/static-order-by.cg view
@@ -1,1 +1,1 @@-orderBy [ ~{intercalate ", " staticSortFields} ]+orderBy [ ~{intercalate ", " sortFields} ]
main/main.hs view
@@ -8,11 +8,14 @@ data Flag = Version | JsonPath String - | FayPath String deriving Eq+ | HsClient String+ | PureScriptPath String deriving Eq options :: [OptDescr Flag] options = [ Option [] ["json"] (ReqArg JsonPath "FILE") "translate DSL definition to JSON object",+ Option [] ["purescript"] (ReqArg PureScriptPath "FILE") "generate client-side PureScript module",+ Option [] ["hs-client"] (ReqArg HsClient "PATH") "generate client-side Haskell modules", Option ['v'] ["version"] (NoArg Version) "print version number" ] @@ -42,4 +45,6 @@ forM_ o (processFlag ast) Nothing -> return () processFlag ast (JsonPath path) = genJson path ast+ processFlag ast (PureScriptPath path) = genPureScript path ast+ processFlag ast (HsClient path) = genHsClient path ast processFlag _ _ = return ()
yesod-dsl.cabal view
@@ -1,5 +1,5 @@ name: yesod-dsl-version: 0.2.0+version: 0.2.1 license: BSD3 license-file: LICENSE author: Tero Laitinen @@ -32,6 +32,7 @@ , aeson , bytestring , aeson-pretty+ , hscolour Build-tools: alex, happy ghc-options: -Wall exposed: True@@ -48,6 +49,7 @@ YesodDsl.Generator.Classes YesodDsl.Generator.Common YesodDsl.Generator.Input+ YesodDsl.Generator.Client YesodDsl.Generator.Esqueleto YesodDsl.Generator.GetHandler YesodDsl.Generator.Handlers@@ -59,6 +61,8 @@ YesodDsl.Generator.Cabal YesodDsl.Generator.EsqueletoInstances YesodDsl.Generator.Json+ YesodDsl.Generator.PureScript+ YesodDsl.Generator.HsClient YesodDsl.Generator.EntityFactories YesodDsl.SyncFile