yesod-dsl 0.1.1.22 → 0.1.1.23
raw patch · 44 files changed
+617/−481 lines, 44 filesdep +shakespearedep +uniplate
Dependencies added: shakespeare, uniplate
Files
- YesodDsl/AST.hs +44/−28
- YesodDsl/ClassImplementer.hs +5/−0
- YesodDsl/ExpandMacros.hs +1/−1
- YesodDsl/Generator.hs +30/−7
- YesodDsl/Generator/Cabal.hs +5/−10
- YesodDsl/Generator/Classes.hs +34/−4
- YesodDsl/Generator/Common.hs +1/−0
- YesodDsl/Generator/Esqueleto.hs +8/−3
- YesodDsl/Generator/GetHandler.hs +34/−2
- YesodDsl/Generator/Input.hs +84/−0
- YesodDsl/Generator/Interface.hs +0/−58
- YesodDsl/Generator/Models.hs +5/−4
- YesodDsl/Generator/UpdateHandlers.hs +47/−155
- YesodDsl/Generator/Validation.hs +32/−0
- YesodDsl/Lexer.x +4/−0
- YesodDsl/ModuleMerger.hs +7/−27
- YesodDsl/Parser.y +131/−104
- YesodDsl/ParserState.hs +27/−33
- codegen/class-entity-instance-field-entity.cg +1/−1
- codegen/class-instance-field.cg +1/−1
- codegen/class-select-filter-data-type.cg +1/−1
- codegen/class-update-data-type.cg +1/−1
- codegen/dispatch.cg +0/−1
- codegen/enum.cg +1/−1
- codegen/get-by-id.cg +1/−1
- codegen/get-call.cg +1/−0
- codegen/get-handler-select.cg +1/−1
- codegen/handler-header.cg +2/−2
- codegen/import.cg +1/−0
- codegen/input-field-local-param-field.cg +1/−1
- codegen/interface-header.cg +0/−12
- codegen/prepare-request-input-field.cg +2/−0
- codegen/read-input-object-fields.cg +1/−1
- codegen/require-select-query.cg +1/−1
- codegen/route-header.cg +2/−1
- codegen/rundb.cg +1/−1
- codegen/select-bound-result.cg +1/−0
- codegen/select-count.cg +1/−1
- codegen/select-existing.cg +1/−1
- codegen/select-results.cg +1/−1
- codegen/validation-function-field.cg +0/−1
- codegen/validation-header.cg +71/−0
- main/main.hs +19/−12
- yesod-dsl.cabal +5/−2
YesodDsl/AST.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-}--- | Abstract Syntax Tree of yesod-dsl definition. module YesodDsl.AST where import Data.Maybe@@ -8,17 +7,16 @@ import Data.Data (Data) import Data.Typeable (Typeable) --- | definitions in single file form a 'Module' data Module = Module {- modName :: Maybe String, -- ^ top-level module must have a name- modEntities :: [Entity], -- ^ database entity definitions- modClasses :: [Class], -- ^ entity classes- modEnums :: [EnumType], -- ^ enumerated field types - modRoutes :: [Route], -- ^ HTTP routes- modDefines :: [Define] -- ^ common expressions+ modName :: Maybe String, + modEntities :: [Entity], + modClasses :: [Class], + modEnums :: [EnumType], + modRoutes :: [Route], + modDefines :: [Define],+ modImports :: [Import] } deriving (Show, Data, Typeable) --- | safe function to extract 'Module' name moduleName :: Module -> String moduleName m = fromMaybe "" (modName m) @@ -29,16 +27,24 @@ modClasses = [], modEnums = [], modRoutes = [],- modDefines = []+ modDefines = [],+ modImports = [] } ++data Import = Import {+ importModule :: String,+ importFunctions :: [FunctionName]+} deriving (Show, Data, Typeable)+ type ClassName = String--- | name of a parameter (for various things) type ParamName = String type EntityName = String type EnumName = String+type EnumValue = String+type FunctionName = String+type FieldName = String --- | type of a 'Field' of an 'Entity' data FieldType = FTWord32 | FTWord64 | FTInt32 | FTInt64 | FTText | FTBool | FTDouble | FTTimeOfDay | FTDay | FTUTCTime | FTZonedTime deriving (Eq,Show,Data,Typeable)@@ -65,8 +71,6 @@ data DefineContent = DefineSubQuery SelectQuery deriving (Show, Eq, Data, Typeable) --- | name of a 'Field'-type FieldName = String data Unique = Unique { uniqueName :: String,@@ -105,7 +109,11 @@ | NotExpr BoolExpr | BinOpExpr ValExpr BinOp ValExpr | ExistsExpr SelectQuery+ | ExternExpr FunctionName [FunctionParam] deriving (Show, Eq, Data, Typeable)+data FunctionParam = FieldRefParam FieldRef+ | VerbatimParam String+ deriving (Show, Eq, Data, Typeable) data ValExpr = FieldExpr FieldRef | ConstExpr FieldValue | ConcatManyExpr [ValExpr]@@ -118,14 +126,7 @@ | ApplyExpr FunctionName [ParamName] deriving (Show, Eq, Data, Typeable) -data Type = TypeEntityId EntityName - | TypeEnum EnumName- | TypeList Type- | TypeField FieldType- | TypeMaybe Type- | TypeCheckmark - deriving (Show, Eq, Data, Typeable)- + data HandlerParam = Public | DefaultFilterSort | Select SelectQuery @@ -133,11 +134,11 @@ | DeleteFrom EntityName VariableName (Maybe BoolExpr) | GetById EntityName InputFieldRef VariableName | Update EntityName InputFieldRef (Maybe [InputField])- | Insert EntityName (Maybe [InputField]) (Maybe VariableName)+ | Insert EntityName (Maybe (Maybe VariableName, [InputField])) (Maybe VariableName) | Return [OutputField] | Require SelectQuery | For VariableName InputFieldRef [HandlerParam]- | Call FunctionName [(InputFieldRef,Maybe Type)]+ | Call FunctionName [InputFieldRef] deriving (Show, Eq, Data, Typeable) type UseParamFlag = Bool type IfFilterParams = (ParamName,[Join],BoolExpr,UseParamFlag)@@ -173,7 +174,7 @@ joinExpr :: Maybe BoolExpr } deriving (Show, Eq, Data, Typeable) -type InputField = (ParamName, InputFieldRef)+type InputField = (ParamName, InputFieldRef, Maybe FunctionName) data CheckmarkValue = CheckmarkActive | CheckmarkInactive deriving (Show, Eq, Ord, Data, Typeable)@@ -274,8 +275,8 @@ type IsListFlag = Bool data FieldContent = NormalField FieldType [FieldOption] | EntityField EntityName - | EnumField EnumName- | CheckmarkField+ | EnumField EnumName (Maybe EnumValue)+ | CheckmarkField (Maybe CheckmarkValue) deriving (Show,Eq, Data, Typeable) @@ -287,7 +288,6 @@ fieldContent :: FieldContent } deriving (Show,Eq, Data, Typeable) -type FunctionName = String data FieldOption = FieldCheck FunctionName | FieldDefault FieldValue@@ -298,6 +298,8 @@ | FloatValue Double | BoolValue Bool | NothingValue+ | CheckmarkFieldValue CheckmarkValue+ | EnumFieldValue EnumName EnumValue deriving (Show, Eq, Ord, Data, Typeable) fieldValueToSql :: FieldValue -> String fieldValueToSql fv = case fv of@@ -306,6 +308,9 @@ (FloatValue d) -> show d (BoolValue b) -> show b NothingValue -> "NULL"+ CheckmarkFieldValue CheckmarkActive -> "True"+ CheckmarkFieldValue CheckmarkInactive -> "NULL"+ EnumFieldValue _ ev -> "'" ++ ev ++ "'" fieldValueToEsqueleto :: FieldValue -> String fieldValueToEsqueleto fv = case fv of@@ -314,6 +319,9 @@ (FloatValue d) -> show d (BoolValue b) -> show b NothingValue -> "nothing"+ CheckmarkFieldValue CheckmarkActive -> "Active"+ CheckmarkFieldValue CheckmarkInactive -> "Inactive"+ EnumFieldValue en ev -> en ++ ev fieldValueToHs :: FieldValue -> String fieldValueToHs fv = case fv of@@ -322,9 +330,17 @@ FloatValue d -> show d BoolValue b -> show b NothingValue -> "Nothing"+ CheckmarkFieldValue CheckmarkActive -> "Active"+ CheckmarkFieldValue CheckmarkInactive -> "Inactive"+ EnumFieldValue en ev -> en ++ ev+++ fieldOptions :: Field -> [FieldOption] fieldOptions f = fieldContentOptions (fieldContent f) where fieldContentOptions (NormalField _ options) = options+ fieldContentOptions (EnumField en (Just ev)) = [ FieldDefault (EnumFieldValue en ev) ]+ fieldContentOptions (CheckmarkField (Just cv)) = [ FieldDefault (CheckmarkFieldValue cv) ] fieldContentOptions _ = [] fieldDefault :: Field -> Maybe FieldValue
YesodDsl/ClassImplementer.hs view
@@ -28,6 +28,11 @@ expandClassRefFields :: Module -> Entity -> Field -> [Field] expandClassRefFields m e f = expand (fieldContent f) where + expand (EntityField "ClassInstance") = [ + f { + fieldContent = EntityField (entityName e)+ }+ ] expand (EntityField name) = case classLookup (modClasses m) name of Just _ -> expandClassField m e f Nothing -> [f]
YesodDsl/ExpandMacros.hs view
@@ -10,7 +10,7 @@ expandApplyExpr fn ps = case find (\d -> defineName d == fn) (modDefines m) of Just d -> if length (defineParams d) == length ps then case defineContent d of- (DefineSubQuery sq) -> SubQueryExpr (expandSubQuery sq $ zip (defineParams d) ps)+ (DefineSubQuery sq) -> SubQueryExpr (expandSubQuery (everywhere (mkT f) sq) $ zip (defineParams d) ps) else error $ "Expected " ++ show (length $ defineParams d) ++ " parameters for macro " ++ fn ++ " got " ++ show (length ps)
YesodDsl/Generator.hs view
@@ -21,7 +21,7 @@ import YesodDsl.Generator.EntityFactories import YesodDsl.Generator.Classes import YesodDsl.Generator.Routes-import YesodDsl.Generator.Interface+import YesodDsl.Generator.Validation import YesodDsl.Generator.Handlers import YesodDsl.Generator.EsqueletoInstances import YesodDsl.Generator.Cabal@@ -29,15 +29,36 @@ import YesodDsl.SyncFile import Control.Monad.State import YesodDsl.Generator.Esqueleto+import Data.Generics+import Data.Generics.Uniplate.Data+import qualified Data.Map as Map -writeRoute :: Module -> Route -> IO Context+allImports :: Module -> String+allImports m = concatMap fmtImport $ modImports m++fmtImport :: Import -> String+fmtImport i = T.unpack $(codegenFile "codegen/import.cg") ++writeRoute :: Module -> Route -> IO () writeRoute m r = do- let (content, ctx) = runState (liftM concat $ mapM handler (routeHandlers r)) ((emptyContext m) { ctxRoute = Just r})+ let (content, _) = runState (liftM concat $ mapM handler (routeHandlers r)) ((emptyContext m) { ctxRoute = Just r}) syncFile (joinPath ["Handler", moduleName m, routeModuleName r ++ ".hs"]) $ T.unpack $(codegenFile "codegen/route-header.cg") ++ content- return ctx- + where+ imports = concatMap fmtImport $ filter ((`elem` modules) . importModule) $ modImports m+ modules = nub $ catMaybes $ [ + Map.lookup fn importedFunctions + | fn <- usedFunctions + ] + importedFunctions = Map.fromList [ (fn, importModule i) |+ i <- modImports m,+ fn <- importFunctions i ]+ + usedFunctions = [ fn | Call fn _ <- universeBi r ] ++ [ fn | ExternExpr fn _ <- universeBi r ] + ++ concat [ catMaybes [ mm | (_,_,mm) <- ifs ] + | Update _ _ (Just ifs) <- universeBi r ] + ++ concat [ catMaybes [ mm | (_,_,mm) <- ifs ] | Insert _ (Just (Just _, ifs)) _ <- universeBi r ] generate :: FilePath -> Module -> IO () generate path m = do syncCabal path m@@ -49,14 +70,16 @@ T.unpack $(codegenFile "codegen/esqueleto-header.cg") ++ (esqueletoInstances m) - ctxs <- forM (modRoutes m) (writeRoute 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- ++ interface m ctxs ++ (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"]) $
YesodDsl/Generator/Cabal.hs view
@@ -13,18 +13,13 @@ import Data.List import YesodDsl.Generator.Routes import YesodDsl.SyncFile-stripGenerated :: Module -> [ModuleName] -> [ModuleName]-stripGenerated m mods = [ mn | mn <- mods, - not $("Handler." ++ (fromMaybe "" $ modName m)) `isPrefixOf` (mnToString mn) ]- where mnToString mn = intercalate "." (components mn) --generatedMods :: Module -> [ModuleName]-generatedMods m = map fromString $ [pfx, pfx ++ ".Internal", pfx ++ ".Enums", pfx ++ ".Routes", pfx ++ ".Esqueleto", pfx ++ ".PathPieces"]- ++ [pfx ++ "." ++ (routeModuleName r) | r <- modRoutes m ]+knownMods :: Module -> [ModuleName]+knownMods m = map fromString $ [pfx, pfx ++ ".Internal", pfx ++ ".Enums", pfx ++ ".Routes", pfx ++ ".Esqueleto", pfx ++ ".PathPieces", pfx ++ ".Validation"]+ ++ [pfx ++ "." ++ (routeModuleName r) | r <- modRoutes m ] ++ (map importModule $ modImports m) where pfx = "Handler." ++ (fromMaybe "" $ modName m) ensureDeps :: [Dependency] -> [Dependency]-ensureDeps deps = nubBy samePackage ([Dependency (PackageName name) AnyVersion +ensureDeps deps = nubBy samePackage ([Dependency (PackageName name) anyVersion | name <- ["unordered-containers", "transformers", "tagged",@@ -59,7 +54,7 @@ modifyLib l = l { exposedModules = modifyExposed (exposedModules l) }- modifyExposed mods = stripGenerated m mods ++ generatedMods m+ modifyExposed mods = nub $ mods ++ knownMods m syncCabal :: FilePath -> Module -> IO () syncCabal path' m = do
YesodDsl/Generator/Classes.hs view
@@ -16,7 +16,15 @@ classFieldName i f = (lowerFirst . className) i ++ (upperFirst . fieldName) f classDefField :: Class -> Field -> String-classDefField c f = T.unpack $(codegenFile "codegen/class-field.cg")+classDefField c cf = T.unpack $(codegenFile "codegen/class-field.cg")+ where+ f = case cf of+ Field _ _ _ _ (EntityField "ClassInstance") -> cf {+ fieldContent = EntityField (className c ++ "Instance")+ }+ _ -> cf+ + classFieldTypeName :: Class -> Field -> String classFieldTypeName c f= rstrip $ T.unpack $(codegenFile "codegen/class-field-type-field-name.cg")@@ -28,6 +36,14 @@ classInstanceField :: Class -> Entity -> Field -> String classInstanceField c e f = T.unpack $(codegenFile "codegen/class-instance-field.cg")+ where+ mapper = case f of+ Field _ opt _ _ (EntityField "ClassInstance") -> + let base = className c ++ "Instance" ++ entityName e ++ "Id"+ in if opt+ then "(fmap " ++ base ++ ") . "+ else base ++ " . "+ _ -> "" classInstance :: Class -> Entity -> String classInstance c e = T.unpack $(codegenFile "codegen/class-instance-header.cg")@@ -35,7 +51,16 @@ classEntityInstanceField :: Class -> [Entity] -> Field -> String classEntityInstanceField c es f = T.unpack $(codegenFile "codegen/class-entity-instance-field.cg")- where caseEntity e = T.unpack $(codegenFile "codegen/class-entity-instance-field-entity.cg")+ where + caseEntity e = T.unpack $(codegenFile "codegen/class-entity-instance-field-entity.cg")+ mapper e = case f of+ Field _ opt _ _ (EntityField "ClassInstance") -> + let base = className c ++ "Instance" ++ entityName e ++ "Id"+ in if opt+ then "(fmap " ++ base ++ ") $ "+ else base ++ " $ "+ _ -> "" + classEntityInstances :: Class -> [Entity] -> String@@ -48,7 +73,8 @@ classSelectFilterDataType :: Class -> String classSelectFilterDataType c = T.unpack $(codegenFile "codegen/class-select-filter-data-type.cg") where - fieldFilterDataType f = rstrip $ T.unpack $(codegenFile "codegen/class-select-filter-data-type-field.cg")+ fieldFilterDataType (Field _ _ _ _ (EntityField "ClassInstance")) = Nothing+ fieldFilterDataType f = Just $ rstrip $ T.unpack $(codegenFile "codegen/class-select-filter-data-type-field.cg") classSelect :: Class -> [Entity] -> String classSelect c es = maybeFilterDataType @@ -64,6 +90,7 @@ then classSelectFilterDataType c else "" maybeFilterParam = if hasClassFields then "filters" :: String else ""+ filterField e (Field _ _ _ _ (EntityField "ClassInstance")) = "" filterField e f = T.unpack $(codegenFile "codegen/class-select-entity-filter-field.cg") maybeFilterType = if hasClassFields then rstrip $ T.unpack $(codegenFile "codegen/class-select-filter-type.cg") else "" @@ -76,11 +103,14 @@ where hasClassFields = not . null $ classFields c updateEntity e = T.unpack $(codegenFile "codegen/class-update-entity.cg")- fieldUpdateDataType f = rstrip $ T.unpack $(codegenFile "codegen/class-update-data-type-field.cg")+ fieldUpdateDataType (Field _ _ _ _ (EntityField "ClassInstance")) = Nothing+ fieldUpdateDataType f = Just $ rstrip $ T.unpack $(codegenFile "codegen/class-update-data-type-field.cg")+ updateEntityField _ (Field _ _ _ _ (EntityField "ClassInstance")) = "" updateEntityField e f = T.unpack $(codegenFile "codegen/class-update-entity-field.cg") maybeFilter e = if hasClassFields then T.unpack $(codegenFile "codegen/class-select-entity-filter.cg") else ""+ filterField e (Field _ _ _ _ (EntityField "ClassInstance")) = "" filterField e f = T.unpack $(codegenFile "codegen/class-select-entity-filter-field.cg") instancesOf :: Module -> Class -> [Entity]
YesodDsl/Generator/Common.hs view
@@ -21,3 +21,4 @@ entityFieldName :: Entity -> Field -> String entityFieldName e f = (lowerFirst . entityName) e ++ (upperFirst . fieldName) f +
YesodDsl/Generator/Esqueleto.hs view
@@ -36,7 +36,6 @@ ctxExprType :: Maybe String, ctxExprMaybeLevel :: Int, ctxExprListValue :: Bool,- ctxCalls :: [ (FunctionName, [TypeName]) ], ctxTypes :: Map.Map InputFieldRef TypeName } emptyContext :: Module -> Context@@ -48,7 +47,6 @@ ctxExprType = Nothing, ctxExprMaybeLevel = 0, ctxExprListValue = False,- ctxCalls = [], ctxTypes = Map.empty } @@ -298,10 +296,11 @@ put $ f ctx r <- st ctx' <- get- put $ ctx { ctxCalls = ctxCalls ctx' }+ put ctx return r + hsBoolExpr :: BoolExpr -> State Context String hsBoolExpr expr = case expr of AndExpr e1 e2 -> do@@ -338,3 +337,9 @@ (hsValExpr 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 fr+ externExprParam (VerbatimParam v) = return v
YesodDsl/Generator/GetHandler.hs view
@@ -17,6 +17,7 @@ import YesodDsl.Generator.Esqueleto import YesodDsl.Generator.Models import YesodDsl.Generator.Require+import YesodDsl.Generator.Input import Control.Monad.State getHandlerParam :: HandlerParam -> State Context String getHandlerParam DefaultFilterSort = return $ T.unpack $(codegenFile "codegen/default-filter-sort-param.cg")@@ -191,13 +192,19 @@ valExprRefs (CeilingExpr ve) = valExprRefs ve valExprRefs (ExtractExpr _ ve) = valExprRefs ve valExprRefs (SubQueryExpr sq) = sqFieldRefs sq-valExprRefs (ApplyExpr _ _) = [] +valExprRefs (ApplyExpr _ _) = []+ exprFieldRefs :: BoolExpr -> [FieldRef] exprFieldRefs (AndExpr e1 e2) = concatMap exprFieldRefs [e1,e2] exprFieldRefs (OrExpr e1 e2) = concatMap exprFieldRefs [e1,e2] exprFieldRefs (NotExpr e) = exprFieldRefs e exprFieldRefs (BinOpExpr ve1 _ ve2) = valExprRefs ve1 ++ (valExprRefs ve2) exprFieldRefs (ExistsExpr sq) = sqFieldRefs sq +exprFieldRefs (ExternExpr _ ps) = mapMaybe f ps+ where+ f (FieldRefParam fr) = Just fr+ f _ = Nothing+ joinFieldRefs :: Join -> [FieldRef] joinFieldRefs j = maybe [] exprFieldRefs (joinExpr j) @@ -219,14 +226,39 @@ where fieldRefs = concatMap getHandlerParamFieldRefs ps isAuthField (FieldRefAuth _) = True isAuthField _ =False- + +callStmts :: State Context String+callStmts = do+ ps <- gets ctxHandlerParams+ liftM concat $ mapM f $ zip ([1..] :: [Int]) ps+ where + f (callId,(Call fn frs)) = do+ ifrs <- mapM inputFieldRef frs+ return $ T.unpack $(codegenFile "codegen/get-call.cg")+ f _ = return "" +getHandlerReadRequestFields :: State Context String+getHandlerReadRequestFields = do+ m <- gets ctxModule+ ps <- gets ctxHandlerParams+ let attrs = jsonAttrs m ps+ if null attrs+ then return ""+ else return $+ concatMap prepareRequestInputField attrs+ where+ jsonAttrs m ps = nub $ concatMap (getJsonAttrs m) ps+ prepareRequestInputField fn = T.unpack $(codegenFile "codegen/prepare-request-input-field.cg")++ getHandler :: State Context String getHandler = do ps <- gets ctxHandlerParams liftM concat $ sequence [ return $ getHandlerMaybeAuth ps, liftM concat $ mapM getHandlerParam ps,+ getHandlerReadRequestFields, requireStmts,+ callStmts, getHandlerSelect ]
+ YesodDsl/Generator/Input.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell #-}+module YesodDsl.Generator.Input where+import Data.Maybe+import qualified Data.Text as T+import Data.List+import Text.Shakespeare.Text hiding (toText)+import Data.String.Utils (rstrip)+import Control.Monad.State+import YesodDsl.AST+import YesodDsl.Generator.Esqueleto+import YesodDsl.Generator.Common+import YesodDsl.Generator.Models+import qualified Data.Map as Map+inputFieldRef :: InputFieldRef -> State Context String+inputFieldRef InputFieldAuthId = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-authid.cg")+inputFieldRef (InputFieldAuth fn) = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-auth.cg")+inputFieldRef (InputFieldLocalParam vn) = return $ rstrip $ T.unpack $(codegenFile "codegen/map-input-field-localparam.cg")+ +inputFieldRef (InputFieldLocalParamField vn fn) = do+ ps <- gets ctxHandlerParams+ let en = fromJust $ listToMaybe $ concatMap f ps+ return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-local-param-field.cg")+ where + f (GetById en _ vn') = if vn' == vn then [en] else []+ f _ = []+ +inputFieldRef (InputFieldPathParam i) = return $ T.unpack $(codegenFile "codegen/input-field-path-param.cg")+inputFieldRef (InputFieldNormal pn) = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-normal.cg")+inputFieldRef ifr = return $ show ifr++fieldRefToJsonAttrs :: FieldRef -> [FieldName]+fieldRefToJsonAttrs (FieldRefRequest fn) = [fn]+fieldRefToJsonAttrs _ = []+ +inputFieldRefToJsonAttr :: InputFieldRef -> Maybe FieldName+inputFieldRefToJsonAttr (InputFieldNormal fn) = Just fn+inputFieldRefToJsonAttr _ = Nothing++inputFieldToJsonAttr :: InputField -> Maybe FieldName+inputFieldToJsonAttr (_,fr,_) = inputFieldRefToJsonAttr fr+inputFieldToJsonAttr _ = Nothing++valExprToJsonAttr :: ValExpr -> [FieldName]+valExprToJsonAttr (FieldExpr fr) = fieldRefToJsonAttrs fr+valExprToJsonAttr (ConcatManyExpr ves) = concatMap valExprToJsonAttr ves+valExprToJsonAttr (ValBinOpExpr ve1 _ ve2) = concatMap valExprToJsonAttr [ve1,ve2]+valExprToJsonAttr (FloorExpr ve) = valExprToJsonAttr ve+valExprToJsonAttr (CeilingExpr ve) = valExprToJsonAttr ve+valExprToJsonAttr (SubQueryExpr sq) = fromMaybe [] $ do+ expr <- sqWhere sq+ return $ exprToJsonAttrs expr+valExprToJsonAttr _ = []++exprToJsonAttrs :: BoolExpr -> [FieldName]+exprToJsonAttrs (AndExpr e1 e2) = concatMap exprToJsonAttrs [e1,e2]+exprToJsonAttrs (OrExpr e1 e2) = concatMap exprToJsonAttrs [e1,e2]+exprToJsonAttrs (NotExpr e) = exprToJsonAttrs e+exprToJsonAttrs (BinOpExpr ve1 _ ve2) = concatMap valExprToJsonAttr [ve1,ve2]+exprToJsonAttrs (ExistsExpr sq) = fromMaybe [] $ do+ expr <- sqWhere sq+ return $ exprToJsonAttrs expr+exprToJsonAttrs (ExternExpr ee ps) = concatMap f ps+ where+ f (FieldRefParam fr) = fieldRefToJsonAttrs fr+ f _ = []++getJsonAttrs :: Module -> HandlerParam -> [FieldName]+getJsonAttrs _ (Update _ fr (Just fields)) = maybeToList (inputFieldRefToJsonAttr fr) ++ (mapMaybe inputFieldToJsonAttr fields)+getJsonAttrs m (Update en fr Nothing) = maybeToList (inputFieldRefToJsonAttr fr) ++ case lookupEntity m en of+ Just e -> [ fieldName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]+ _ -> []+getJsonAttrs _ (Insert _ (Just (_,fields)) _) = mapMaybe inputFieldToJsonAttr fields+getJsonAttrs m (Insert en Nothing _) = case lookupEntity m en of+ Just e -> [ fieldName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]+ _ -> []+getJsonAttrs _ (DeleteFrom _ _ (Just e)) = exprToJsonAttrs e+getJsonAttrs _ (Require sq) = let+ exprs = catMaybes $ [sqWhere sq] ++ [joinExpr j| j <- sqJoins sq]+ in concatMap exprToJsonAttrs exprs+getJsonAttrs m (For vn fr ps) = maybeToList (inputFieldRefToJsonAttr fr ) ++ concatMap (getJsonAttrs m) ps+getJsonAttrs _ (Call _ ifrs) = mapMaybe inputFieldRefToJsonAttr ifrs+getJsonAttrs _ _ = []++
− YesodDsl/Generator/Interface.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-module YesodDsl.Generator.Interface where-import YesodDsl.AST-import Data.Maybe-import qualified Data.Text as T-import Data.List-import Text.Shakespeare.Text hiding (toText)-import Data.String.Utils (rstrip)-import YesodDsl.Generator.Models-import YesodDsl.Generator.Common-import YesodDsl.Generator.Esqueleto--validationFieldCheck :: Entity -> Field -> FunctionName -> String-validationFieldCheck e f func = rstrip $ T.unpack $(codegenFile "codegen/validation-field.cg")--validationEntityCheck :: Entity -> FunctionName -> String-validationEntityCheck e func = rstrip $ T.unpack $(codegenFile "codegen/validation-entity.cg")- where fieldRef f = "(" ++ (lowerFirst . entityName) e ++ upperFirst f ++ " v)"--validationEntity :: Entity -> String-validationEntity e = T.unpack $(codegenFile "codegen/validation-entity-header.cg")- ++ (intercalate ",\n " $ [ validationFieldCheck e f func- | f <- entityFields e,- func <- fieldChecks f])- ++ (intercalate ",\n " $ [ validationEntityCheck e func |- func <- entityChecks e ])- ++ (T.unpack $(codegenFile "codegen/validation-entity-footer.cg"))---validationFieldFunction :: (Field, FunctionName) -> String-validationFieldFunction (f,func) = T.unpack $(codegenFile "codegen/validation-function-field.cg")--validationEntityFunction :: (Entity, FunctionName) -> String-validationEntityFunction (e, func) = T.unpack $(codegenFile "codegen/validation-function-entity.cg")- --lookupFieldType :: Module -> EntityName -> FieldName -> String-lookupFieldType m en fn = hsFieldType (fromJust $ lookupField m en fn)--handlerCall :: (FunctionName, [TypeName]) -> String-handlerCall (fn,ptns) = T.unpack $(codegenFile "codegen/call-type-signature.cg")- where paramTypes = concatMap (++" -> ") ptns--interface :: Module -> [Context] -> String-interface m ctxs= T.unpack $(codegenFile "codegen/interface-header.cg")- ++ (concatMap validationFieldFunction $ - nubBy (\(_,f1) (_,f2) -> f1 == f2)- [(f,func) | e <- modEntities m,- f <- entityFields e,- func <- fieldChecks f ])- ++ (concatMap validationEntityFunction $ - [ (e, func) |e <- modEntities m, func <- entityChecks e ])- ++ (concatMap handlerCall $ concatMap ctxCalls ctxs)- ++ (concatMap validationEntity (modEntities m))--
YesodDsl/Generator/Models.hs view
@@ -36,8 +36,8 @@ baseFieldType f = case fieldContent f of (NormalField ft _) -> fieldTypeToHsType ft (EntityField en) -> en ++ "Id"- (EnumField en) -> en- CheckmarkField -> "Checkmark"+ (EnumField en _) -> en+ (CheckmarkField _) -> "Checkmark" persistFieldType :: Field -> String@@ -46,11 +46,12 @@ ++ (maybeDefault . fieldDefault) f ++ (maybeDefaultNull f) ++ (maybeCheckmarkNullable f)- where maybeDefault (Just d) = " \"default=" ++ (fieldValueToSql d) ++ "\""+ where + maybeDefault (Just d) = " \"default=" ++ (fieldValueToSql d) ++ "\"" maybeDefault _ = " " maybeDefaultNull (Field _ True _ _ (EntityField _)) = " default=NULL" maybeDefaultNull _ = ""- maybeCheckmarkNullable (Field _ _ _ _ CheckmarkField) = " nullable"+ maybeCheckmarkNullable (Field _ _ _ _ (CheckmarkField _)) = " nullable" maybeCheckmarkNullable _ = ""
YesodDsl/Generator/UpdateHandlers.hs view
@@ -13,79 +13,11 @@ import YesodDsl.Generator.Common import YesodDsl.Generator.Models import YesodDsl.Generator.Require+import YesodDsl.Generator.Input import Control.Monad.State import qualified Data.Map as Map -inputFieldRefType :: InputFieldRef -> State Context String-inputFieldRefType InputFieldAuthId = return $ "UserId"-inputFieldRefType (InputFieldAuth fn) = do- m <- gets ctxModule- let mf = listToMaybe [ hsFieldType f | e <- modEntities m,- f <- entityFields e,- fieldName f == fn ]- case mf of- Just ft -> return ft- Nothing -> return "Unknown"-inputFieldRefType (InputFieldLocalParam vn) = do- ps <- gets ctxHandlerParams- let en = fromMaybe "Unknown" $ listToMaybe $ concatMap f ps- return $ en ++ "Id" - where- f (Insert en _ (Just vn')) = if vn' == vn then [en] else []- f _ = []- --inputFieldRefType (InputFieldLocalParamField vn fn) = do- ps <- gets ctxHandlerParams- let en = fromMaybe "Unknown" $ listToMaybe $ concatMap f ps- m <- gets ctxModule- let mf = lookupField m en fn- return $ case mf of- Just f -> hsFieldType f- Nothing -> "Unknown"- where - f (GetById en _ vn') = if vn' == vn then [en] else []- f _ = []- -inputFieldRefType (InputFieldPathParam i) = do- mr <- gets ctxRoute- case mr of- Just r -> do- let p = (routePathParams r) !! (i-1)- case p of- PathId _ en -> return $ en ++ "Id"- _ -> return ""- Nothing -> return ""-inputFieldRefType ifr = do- types <- gets ctxTypes- return $ Map.findWithDefault "Unknown" ifr types--inputFieldRef :: InputFieldRef -> State Context String-inputFieldRef InputFieldAuthId = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-authid.cg")-inputFieldRef (InputFieldAuth fn) = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-auth.cg")-inputFieldRef (InputFieldLocalParam vn) = return $ rstrip $ T.unpack $(codegenFile "codegen/map-input-field-localparam.cg")- -inputFieldRef (InputFieldLocalParamField vn fn) = do- ps <- gets ctxHandlerParams- let en = fromJust $ listToMaybe $ concatMap f ps- return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-local-param-field.cg")- where - f (GetById en _ vn') = if vn' == vn then [en] else []- f _ = []- -inputFieldRef (InputFieldPathParam i) = return $ T.unpack $(codegenFile "codegen/input-field-path-param.cg")-inputFieldRef (InputFieldNormal pn) = return $ rstrip $ T.unpack $(codegenFile "codegen/input-field-normal.cg")-inputFieldRef ifr = return $ show ifr--formatType :: Type -> String-formatType (TypeEntityId en) = en ++ "Id"-formatType (TypeEnum en) = en -formatType (TypeList t) = "[" ++ formatType t ++ "]"-formatType (TypeField ft) = fieldTypeToHsType ft-formatType (TypeMaybe f) = "Maybe (" ++ formatType f ++ ")"-- updateHandlerRunDB :: (Int,HandlerParam) -> State Context String updateHandlerRunDB (pId,p) = liftM concat $ sequence ([ updateHandlerDecode (pId,p) >>= return . (indent 4),@@ -114,13 +46,7 @@ ifr <- inputFieldRef fr return $ T.unpack $(codegenFile "codegen/for.cg") Call fn frs -> do- ifrs <- mapM inputFieldRef $ map fst frs- types <- forM frs $ \(fr,mt) -> do- case mt of- Just ft -> return $ formatType ft- Nothing -> inputFieldRefType fr- ctx <- get- put $ ctx { ctxCalls = (fn,types):ctxCalls ctx}+ ifrs <- mapM inputFieldRef frs return $ T.unpack $(codegenFile "codegen/call.cg") _ -> return "" ] :: [State Context String])@@ -135,47 +61,52 @@ ctx <- get put $ ctx { ctxTypes = Map.insert ifr typeName $ ctxTypes ctx } -mapJsonInputField :: [InputField] -> Bool -> (Entity,Field) -> State Context String+mapJsonInputField :: [InputField] -> Bool -> (Entity,Field) -> State Context (Maybe String) mapJsonInputField ifields isNew (e,f) = do- content' <- mkContent- let content = rstrip content'- return $ T.unpack $(codegenFile "codegen/map-input-field.cg")+ mcontent <- mkContent+ case mcontent of+ Just content' -> do+ let content = rstrip content'+ return $ Just $ T.unpack $(codegenFile "codegen/map-input-field.cg")+ Nothing -> return Nothing where maybeJust :: Bool -> String -> String maybeJust True v = "(Just " ++ v ++ ")" maybeJust False v = v maybeInput = matchInputField ifields (fieldName f) notNothing = case maybeInput of- Just (InputFieldConst NothingValue) -> False+ Just (InputFieldConst NothingValue, _) -> False _ -> True notInputField = case maybeInput of- Just (InputFieldNormal _) -> False+ Just (InputFieldNormal _, _) -> False _ -> True promoteJust = fieldOptional f && isJust maybeInput && notNothing && notInputField++ mapper mmapper = maybe "" ((" $ " ++) . (++ " $ ")) mmapper mkContent = case maybeInput of- Just (ifr@(InputFieldNormal fn)) -> do+ Just (ifr@(InputFieldNormal fn), mm) -> do addCtxType ifr (hsFieldType f)- return $ T.unpack $(codegenFile "codegen/map-input-field-normal.cg")- Just InputFieldAuthId -> return $ T.unpack $(codegenFile "codegen/map-input-field-authid.cg")- Just (InputFieldAuth fn) -> return $ T.unpack $(codegenFile "codegen/map-input-field-auth.cg")- Just (InputFieldPathParam i) -> return $ T.unpack $(codegenFile "codegen/map-input-field-pathparam.cg")- Just (InputFieldConst v) -> return $ T.unpack $(codegenFile "codegen/map-input-field-const.cg")- Just (InputFieldNow) -> return $ T.unpack $(codegenFile "codegen/map-input-field-now.cg")- Just (InputFieldLocalParam vn) -> return $ T.unpack $(codegenFile "codegen/map-input-field-localparam.cg")- Just (InputFieldLocalParamField vn fn) -> do+ return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-normal.cg")+ Just (InputFieldAuthId, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-authid.cg")+ Just (InputFieldAuth fn, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-auth.cg")+ Just (InputFieldPathParam i, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-pathparam.cg")+ Just (InputFieldConst v, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-const.cg")+ Just (InputFieldNow, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-now.cg")+ Just (InputFieldLocalParam vn, mm) -> return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/map-input-field-localparam.cg")+ Just (InputFieldLocalParamField vn fn, mm) -> do ps <- gets ctxHandlerParams let en = fromJust $ listToMaybe $ concatMap f ps- return $ T.unpack $(codegenFile "codegen/input-field-local-param-field.cg")+ return $ Just $ mapper mm ++ T.unpack $(codegenFile "codegen/input-field-local-param-field.cg") where f (GetById en _ vn') = if vn' == vn then [en] else [] f _ = []- Just (InputFieldCheckmark v) -> return $ case v of+ Just (InputFieldCheckmark v, mm) -> return $ Just $ mapper mm ++ case v of CheckmarkActive -> "Active" CheckmarkInactive -> "Inactive"- Nothing -> return $ if isNew then defaultFieldValue f- else T.unpack $(codegenFile "codegen/map-input-field-no-match.cg")-matchInputField :: [InputField] -> FieldName -> Maybe InputFieldRef-matchInputField ifields fn = listToMaybe [ inp | (pn,inp) <- ifields, pn == fn ]+ Nothing -> return $ if isNew then Just $ defaultFieldValue f+ else Nothing+matchInputField :: [InputField] -> FieldName -> Maybe (InputFieldRef, Maybe FunctionName)+matchInputField ifields fn = listToMaybe [ (inp,mm) | (pn,inp,mm) <- ifields, pn == fn ] prepareJsonInputField :: FieldName -> String prepareJsonInputField fn = T.unpack $(codegenFile "codegen/prepare-input-field-normal.cg") @@ -184,77 +115,37 @@ updateHandlerDecode (pId,p) = case p of Update en fr io -> do m <- gets ctxModule- readInputObject (fromJust $ lookupEntity m en) io (Just fr)+ readInputObject (fromJust $ lookupEntity m en) (io >>= \io' -> Just (Nothing, io')) (Just fr) Insert en io _ -> do m <- gets ctxModule readInputObject (fromJust $ lookupEntity m en) io Nothing _ -> return "" where - readInputObject e (Just fields) fr = do- maybeExisting <- maybeSelectExisting e fields fr- fieldMappers <- mapFields e fields (isNothing fr)+ readInputObject :: Entity -> Maybe (Maybe VariableName, [InputField]) -> Maybe InputFieldRef -> State Context String+ readInputObject e (Just (mv, fields)) fr = do+ maybeExisting <- maybeSelectExisting e (mv,fields) fr+ fieldMappers <- mapFields e fields isNew return $ T.unpack $(codegenFile "codegen/read-input-object-fields.cg") - readInputObject e Nothing _ = do+ where + isNew = isNothing fr && isNothing mv+ entityToUpdate+ | isNew = entityName e+ | otherwise = "e"++ readInputObject e Nothing _ = do fieldMappers <- mapFields e [] True return $ T.unpack $(codegenFile "codegen/read-input-object-whole.cg") - maybeSelectExisting e fields (Just fr)+ maybeSelectExisting e (Nothing, fields) (Just fr) | Nothing `elem` [ matchInputField fields (fieldName f) | f <- entityFields e ] = do ifr <- inputFieldRef fr return $ T.unpack $(codegenFile "codegen/select-existing.cg") | otherwise = return ""+ maybeSelectExisting _ (Just vn, _) _ = return $ T.unpack $(codegenFile "codegen/select-bound-result.cg") maybeSelectExisting e _ _ = return ""- mapFields e fields isNew = liftM (intercalate ",\n") $ mapM (mapJsonInputField fields isNew) + mapFields e fields isNew = liftM ((intercalate ",\n") . catMaybes) $ mapM (mapJsonInputField fields isNew) [ (e,f) | f <- entityFields e ]-fieldRefToJsonAttrs :: FieldRef -> [FieldName]-fieldRefToJsonAttrs (FieldRefRequest fn) = [fn]-fieldRefToJsonAttrs _ = []- -inputFieldRefToJsonAttr :: InputFieldRef -> Maybe FieldName-inputFieldRefToJsonAttr (InputFieldNormal fn) = Just fn-inputFieldRefToJsonAttr _ = Nothing--inputFieldToJsonAttr :: InputField -> Maybe FieldName-inputFieldToJsonAttr (_,fr) = inputFieldRefToJsonAttr fr-inputFieldToJsonAttr _ = Nothing--valExprToJsonAttr :: ValExpr -> [FieldName]-valExprToJsonAttr (FieldExpr fr) = fieldRefToJsonAttrs fr-valExprToJsonAttr (ConcatManyExpr ves) = concatMap valExprToJsonAttr ves-valExprToJsonAttr (ValBinOpExpr ve1 _ ve2) = concatMap valExprToJsonAttr [ve1,ve2]-valExprToJsonAttr (FloorExpr ve) = valExprToJsonAttr ve-valExprToJsonAttr (CeilingExpr ve) = valExprToJsonAttr ve-valExprToJsonAttr (SubQueryExpr sq) = fromMaybe [] $ do- expr <- sqWhere sq- return $ exprToJsonAttrs expr-valExprToJsonAttr _ = []--exprToJsonAttrs :: BoolExpr -> [FieldName]-exprToJsonAttrs (AndExpr e1 e2) = concatMap exprToJsonAttrs [e1,e2]-exprToJsonAttrs (OrExpr e1 e2) = concatMap exprToJsonAttrs [e1,e2]-exprToJsonAttrs (NotExpr e) = exprToJsonAttrs e-exprToJsonAttrs (BinOpExpr ve1 _ ve2) = concatMap valExprToJsonAttr [ve1,ve2]-exprToJsonAttrs (ExistsExpr sq) = fromMaybe [] $ do- expr <- sqWhere sq- return $ exprToJsonAttrs expr-getJsonAttrs :: Module -> HandlerParam -> [FieldName]-getJsonAttrs _ (Update _ fr (Just fields)) = maybeToList (inputFieldRefToJsonAttr fr) ++ (mapMaybe inputFieldToJsonAttr fields)-getJsonAttrs m (Update en fr Nothing) = maybeToList (inputFieldRefToJsonAttr fr) ++ case lookupEntity m en of- Just e -> [ fieldName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]- _ -> []-getJsonAttrs _ (Insert _ (Just fields) _) = mapMaybe inputFieldToJsonAttr fields-getJsonAttrs m (Insert en Nothing _) = case lookupEntity m en of- Just e -> [ fieldName f | f <- entityFields e, isNothing $ fieldDefault f, fieldOptional f == False ]- _ -> []-getJsonAttrs _ (DeleteFrom _ _ (Just e)) = exprToJsonAttrs e-getJsonAttrs _ (Require sq) = let- exprs = catMaybes $ [sqWhere sq] ++ [joinExpr j| j <- sqJoins sq]- in concatMap exprToJsonAttrs exprs-getJsonAttrs m (For vn fr ps) = maybeToList (inputFieldRefToJsonAttr fr ) ++ concatMap (getJsonAttrs m) ps-getJsonAttrs _ (Call _ ifrs) = mapMaybe (inputFieldRefToJsonAttr . fst) ifrs-getJsonAttrs _ _ = []- updateHandlerReadJsonFields :: State Context String updateHandlerReadJsonFields = do m <- gets ctxModule@@ -269,10 +160,11 @@ jsonAttrs m ps = nub $ concatMap (getJsonAttrs m) ps handlerParamToInputFieldRefs :: HandlerParam -> [InputFieldRef]-handlerParamToInputFieldRefs (Update _ fr io) = [fr] ++ [ fr' | (_,fr') <- fromMaybe [] io]-handlerParamToInputFieldRefs (Insert _ io _) = [ fr | (_,fr) <- fromMaybe [] io ]+handlerParamToInputFieldRefs (Update _ fr io) = [fr] ++ [ fr' | (_,fr',_) <- fromMaybe [] io]+handlerParamToInputFieldRefs (Insert _ (Just (_, io)) _) = [ fr | (_,fr,_) <- io ]+handlerParamToInputFieldRefs (Insert _ _ _) = [] handlerParamToInputFieldRefs (GetById _ ifr _) = [ifr]-handlerParamToInputFieldRefs (Call _ ifrs) = map fst ifrs+handlerParamToInputFieldRefs (Call _ ifrs) = ifrs handlerParamToInputFieldRefs _ = [] updateHandlerMaybeCurrentTime :: [HandlerParam] -> String
+ YesodDsl/Generator/Validation.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module YesodDsl.Generator.Validation where+import YesodDsl.AST+import Data.Maybe+import qualified Data.Text as T+import Data.List+import Text.Shakespeare.Text hiding (toText)+import Data.String.Utils (rstrip)+import YesodDsl.Generator.Models+import YesodDsl.Generator.Common+import YesodDsl.Generator.Esqueleto++validationFieldCheck :: Entity -> Field -> FunctionName -> String+validationFieldCheck e f func = rstrip $ T.unpack $(codegenFile "codegen/validation-field.cg")++validationEntityCheck :: Entity -> FunctionName -> String+validationEntityCheck e func = rstrip $ T.unpack $(codegenFile "codegen/validation-entity.cg")+ where fieldRef f = "(" ++ (lowerFirst . entityName) e ++ upperFirst f ++ " v)"++validationEntity :: Entity -> String+validationEntity e = T.unpack $(codegenFile "codegen/validation-entity-header.cg")+ ++ (intercalate ",\n " $ [ validationFieldCheck e f func+ | f <- entityFields e,+ func <- fieldChecks f])+ ++ (intercalate ",\n " $ [ validationEntityCheck e func |+ func <- entityChecks e ])+ ++ (T.unpack $(codegenFile "codegen/validation-entity-footer.cg"))+++
YesodDsl/Lexer.x view
@@ -18,6 +18,7 @@ $white+ ; "--".* ; \n ;+ "[|" .* "|]" { mkTvar (TVerbatim . stripBrackets) } @string { mkTvar (TString . stripQuotes) } \; { mkT TSemicolon } \{ { mkT TLBrace }@@ -171,6 +172,7 @@ | TLimit | TOffset | TString String+ | TVerbatim String | TLowerId String | TUpperId String | TInt Int@@ -268,6 +270,7 @@ tkString (Tk _ (TUpperId s)) = s tkString (Tk _ (TString s)) = s tkString (Tk _ (TEntityId s)) = s+tkString (Tk _ (TVerbatim s)) = s tkString _ = "" tkInt :: Token -> Int@@ -275,6 +278,7 @@ tkInt _ = 0 stripQuotes s = take ((length s) -2) (tail s)+stripBrackets s = take ((length s) -4) (drop 2 s) mkT :: TokenType -> AlexPosn -> String -> Token mkT t p s = Tk p t
YesodDsl/ModuleMerger.hs view
@@ -2,10 +2,10 @@ import YesodDsl.AST import Data.List import Data.Maybe+import Data.Generics mergeModules :: [(FilePath,Module)] -> Module-mergeModules ms = foldl merge emptyModule ms'- where ms' = map updateLocation ms+mergeModules ms = foldl merge emptyModule $ map updateLocation ms merge :: Module -> Module -> Module merge m1 m2 = Module {@@ -14,33 +14,13 @@ modClasses = modClasses m1 ++ modClasses m2, modEnums = modEnums m1 ++ modEnums m2, modRoutes = modRoutes m1 ++ modRoutes m2,- modDefines = modDefines m1 ++ modDefines m2+ modDefines = modDefines m1 ++ modDefines m2,+ modImports = modImports m1 ++ modImports m2 } updateLocation :: (FilePath,Module) -> Module-updateLocation (path,m) = m {- modEntities = map updateEntityLoc (modEntities m),- modClasses = map updateClassLoc (modClasses m),- modEnums = map updateEnumLoc (modEnums m),- modRoutes = map updateRouteLoc (modRoutes m),- modDefines = map updateDefineLoc (modDefines m)- } - where - updateEntityLoc e = e { entityLoc = updateLoc path (entityLoc e) }- updateClassLoc i = i { classLoc = updateLoc path (classLoc i) }- updateEnumLoc e = e { enumLoc = updateLoc path (enumLoc e) }- updateRouteLoc r = r {- routeLoc = updateLoc path (routeLoc r),- routeHandlers = map updateHandlerLoc (routeHandlers r)- }- updateHandlerLoc h = h {- handlerLoc = updateLoc path (handlerLoc h)- }- updateDefineLoc d = d {- defineLoc = updateLoc path (defineLoc d)- }- -updateLoc :: FilePath -> Location -> Location-updateLoc path (Loc _ l c) = Loc path l c+updateLocation (path,m) = everywhere (mkT (updateLoc path)) m+ where+ updateLoc path (Loc _ l c) = Loc path l c
YesodDsl/Parser.y view
@@ -10,6 +10,7 @@ import System.IO import Data.Maybe import Data.Typeable+import Data.Either import Prelude hiding (catch) import Control.Exception hiding (Handler) import System.Exit@@ -61,6 +62,7 @@ dot { Tk _ TDot } slash { Tk _ TSlash } stringval { Tk _ (TString $$) }+ verbatim { Tk _ (TVerbatim _) } word32 { Tk _ TWord32 } word64 { Tk _ TWord64 } int32 { Tk _ TInt32 }@@ -149,6 +151,7 @@ %% + dbModule : maybeModuleName pushScope imports defs popScope {% do@@ -158,7 +161,8 @@ ((reverse . getEnums) $4) ((reverse . getRoutes) $4) ((reverse . getDefines) $4)- return $ mergeModules $ (path,m):$3+ (rights $3)+ return $ mergeModules $ (path,m):lefts $3 } upperId: upperIdTk { tkString $1 }@@ -172,19 +176,35 @@ return $ Just s2 } imports : { [] }- | importStmt imports { $1++ $2 }+ | import importContent semicolon imports { $2++ $4 } -importStmt : import stringval semicolon {% - do- parsed <- getParsed- if not ($2 `elem` parsed)- then do- ps <- getParserState- (m,ps') <- liftIO $parseModule ps $2- setParserState ps'- return [($2,m)]- else return []- }+importContent : stringval {% + do+ parsed <- getParsed+ if not ($1 `elem` parsed)+ then do+ ps <- getParserState+ (m,ps') <- liftIO $ parseModule ps $1+ setParserState ps'+ return [Left ($1,m)]+ else return []+ } | moduleName lparen lowerIdList rparen {%+ do + let (ns,l) = $1+ n = intercalate "." ns+ forM_ $3 $ \f -> do+ declareGlobal l f SFunction+ return [Right $ Import n $3] + }++moduleName: upperIdTk moduleNames {%+ do+ l <- mkLoc $1+ return (tkString $1 : $2, l)+ }+moduleNames: { [] }+ | moduleNames dot upperId moduleNames { $1 ++ [$3] }+ defs : { [] } | defs def { $2 : $1 } def : routeDef { RouteDef $1 }@@ -199,6 +219,7 @@ let n = tkString $2 let d = Define n l $5 $8 declare l n (SDefine d) + lift $ putStrLn $ show l ++ ": Define support is being deprecated. Please switch to external functions." return d } @@ -329,7 +350,8 @@ do return $ $1 $3 }-+fieldRefList : { [ ] }+ | fieldRefList fieldRef { $1 ++ [$2] } fieldRef : lowerIdTk dot idField {% do@@ -462,7 +484,7 @@ l <- mkLoc $1 statement l "update" requireHandlerType l "update" (/=GetHandler)- return $ Update (tkString $3) (fst $6) $7+ return $ Update (tkString $3) $6 $7 } | delete pushScope from declareFromEntity maybeWhere popScope {% do@@ -479,7 +501,7 @@ let (l1,s1) = $1 declare l1 s1 $ SEntity $3 requireHandlerType l "get" (/=GetHandler)- return $ GetById $3 (fst $6) s1+ return $ GetById $3 $6 s1 } | maybeBindResult insert pushScope targetEntity maybeFromInputJson popScope {% do@@ -535,54 +557,14 @@ l <- mkLoc $1 statement l "for" requireHandlerType l "for" (/=GetHandler)- return $ For $3 (fst $5) $7 + return $ For $3 $5 $7 } | lowerIdTk inputRefList {% do l <- mkLoc $1 statement l (tkString $1)- requireHandlerType l (tkString $1) (/=GetHandler) return $ Call (tkString $1) $2 } - | lparen lowerIdTk doublecolon functionType rparen inputRefList {%- do - l2 <- mkLoc $2- let s2 = tkString $2- statement l2 s2- requireHandlerType l2 s2 (/=GetHandler)- when (length $4 /= length $6) $ pError l2 $ "'" ++ s2 - ++ "' expects " ++ show (length $4) ++ " parameters, " - ++ show (length $6) ++ " given"- let types = zip $4 $6- forM_ [ (n,t1,fromJust mt2) | (n,(t1,(_,mt2))) <- zip [1..] types, - Just t1 /= mt2, isJust mt2 ] $ \(n,t1,t2) -> - pError l2 $ "'" ++ s2 ++ "' expects " ++ show t1 ++ " as the parameter #" ++ show n ++ ", got " ++ show t2 ++ " instead."- return $ Call s2 [ (ifr,Just $ fromMaybe t1 t2) | (t1,(ifr,t2)) <- types ]- }--functionType: functionTypes rarrow lowerIdTk lparen rparen { $1 }--functionTypes: type { [$1] }- | functionTypes rarrow type { $1 ++ [$3] }--type: entityId {%- do- l1 <- mkLoc $1- let s1 = tkString $1- withSymbol l1 s1 $ requireEntity $ \_ -> return ()- return $ TypeEntityId s1- }- | upperIdTk {%- do- l1 <- mkLoc $1- let s1 = tkString $1- withSymbol l1 s1 $ requireEnum - return $ TypeEnum s1- }- | lbracket type rbracket { TypeList $2 }- | fieldTypeContent { TypeField (snd $1) }- | maybe type { TypeMaybe $2 }- lowerIdParam: lowerIdTk {% do l1 <- mkLoc $1@@ -663,7 +645,15 @@ maybeWithInputJson: with inputJson { Just $2 } | { Nothing } -maybeFromInputJson: from inputJson { Just $2 }+maybeFromInputJson: from inputJson { Just (Nothing, $2) }+ | from lowerIdTk inputJson {%+ do+ l2 <- mkLoc $2+ let s2 = tkString $2+ tgt <- withSymbolNow Nothing l2 "target entity" $ getEntitySymbol+ withSymbolNow () l2 s2 $ requireEntity $ \e -> when (Just (entityName e) /= tgt) $ pError l2 $ "Reference to " ++ (entityName e) ++ " (expected " ++ (fromMaybe "" tgt) ++ ")"+ return $ Just (Just s2, $3)+ } | { Nothing } inputJson: lbrace inputJsonFields rbrace { $2 }@@ -673,20 +663,27 @@ let s1 = tkString $1 withSymbol l1 "target entity" $ requireEntityField l1 s1 $ \_ -> return ()- let (ir, _) = $3- return (s1, ir) + return (s1, $3, Nothing) }+ | lowerIdTk equals functionRef lparen inputRef rparen {%+ do+ l1 <- mkLoc $1+ let s1 = tkString $1+ withSymbol l1 "target entity" $ + requireEntityField l1 s1 $ \_ -> return ()+ return (s1, $5, Just $3)+ } + inputRefList: { [] } | inputRefList inputRef { $1 ++ [$2] } -inputRef: request dot lowerIdTk { (InputFieldNormal $ tkString $3, Nothing) }+inputRef: request dot lowerIdTk { InputFieldNormal $ tkString $3 } | lowerIdTk {% do l1 <- mkLoc $1 let n1 = tkString $1- mtype <- withSymbolNow Nothing l1 n1 $ getSymbolType- return $ (InputFieldLocalParam n1, mtype) + return $ InputFieldLocalParam n1 } | lowerIdTk dot lowerIdTk {% do@@ -694,27 +691,26 @@ l3 <- mkLoc $3 let (s1,s3) = (tkString $1, tkString $3) withSymbol l1 s1 $ requireEntityField l3 s3 $ \_ -> return ()- return (InputFieldLocalParamField s1 s3, Nothing) + return $ InputFieldLocalParamField s1 s3 } | pathParam {% do l1 <- mkLoc $1 let i1 = tkInt $1- mtype <- withSymbolNow Nothing l1 ("$" ++ show i1) $ getSymbolType - return $ (InputFieldPathParam i1, mtype) + return $ InputFieldPathParam i1 }- | auth dot idField { (InputFieldAuthId, Just $ TypeEntityId "User") }+ | auth dot idField { InputFieldAuthId } | auth dot lowerIdTk {% do l1 <- mkLoc $1 l3 <- mkLoc $3 let n3 = tkString $3 withSymbol l1 "User" $ requireEntityField l3 n3 $ \_ -> return ()- return $ (InputFieldAuth n3, Nothing)+ return $ InputFieldAuth n3 }- | value { (InputFieldConst $1, fieldValueToType $1) } - | now lparen rparen { (InputFieldNow, Just $ TypeField FTUTCTime) }- | checkmarkValue { (InputFieldCheckmark $1, Just TypeCheckmark) }+ | value { InputFieldConst $1 } + | now lparen rparen { InputFieldNow }+ | checkmarkValue { InputFieldCheckmark $1 } checkmarkValue: checkmarkActive { CheckmarkActive } | checkmarkInactive { CheckmarkInactive }@@ -751,8 +747,20 @@ | valexpr binop valexpr { BinOpExpr $1 $2 $3 } | exists lparen pushScope selectQuery popScope rparen { ExistsExpr $4 }- + | lowerIdTk functionParamList {%+ do+ l1 <- mkLoc $1+ let s1 = tkString $1+ withSymbol l1 s1 requireFunction+ return $ ExternExpr s1 $2+ } +functionParamList: { [] }+ | functionParamList functionParam { $1 ++ [$2] }+functionParam: fieldRef { FieldRefParam $1 }+ | verbatim { VerbatimParam (tkString $1) }+ + valbinop : slash { Div } | asterisk { Mul } @@ -848,26 +856,45 @@ withGlobalSymbol l3 s3 requireEntityOrClass declare l n (SField f) return f}- | lowerIdTk maybeMaybe upperIdTk fieldFlags {%+ | lowerIdTk maybeMaybe enumFieldContent fieldFlags {% do l <- mkLoc $1 let n = tkString $1- l3 <- mkLoc $3- let s3 = tkString $3- withGlobalSymbol l3 s3 requireEnum- let f = Field l $2 (FieldInternal `elem` $4) n (EnumField s3) + let f = Field l $2 (FieldInternal `elem` $4) n $3 declare l n (SField f) return f }- | lowerIdTk checkmark fieldFlags {%+ | lowerIdTk checkmark maybeDefaultCheckmarkValue fieldFlags {% do l <- mkLoc $1 let n = tkString $1- let f = Field l False (FieldInternal `elem` $3) n CheckmarkField+ let f = Field l False (FieldInternal `elem` $4) n (CheckmarkField $3) declare l n (SField f) return f } +enumFieldContent: + upperIdTk default upperIdTk {%+ do+ l1 <- mkLoc $1+ let s1 = tkString $1+ withGlobalSymbol l1 s1 requireEnum+ l3 <- mkLoc $3+ let s3 = tkString $3+ withGlobalSymbol l1 s1 $ requireEnumValue l3 s3+ return $ EnumField s1 (Just s3)+ } + | upperIdTk {% + do+ l1 <- mkLoc $1+ let s1 = tkString $1+ withGlobalSymbol l1 s1 requireEnum+ return $ EnumField s1 Nothing+ } +maybeDefaultCheckmarkValue: { Nothing }+ | default checkmarkValue { Just $2 }+ + fieldOptions : { [] } | pushScope fieldOptionsList popScope { $2 } fieldOptionsList : fieldOption { [$1] }@@ -876,9 +903,7 @@ do l2 <- mkLoc $2 let s2 = tkString $2- declare l2 ("check " ++ s2) SReserved- withSymbolNow () l2 "current field type" $ requireFieldType $ \ft ->- addCheck l2 s2 ft+ withSymbol l2 s2 requireFunction return $ FieldCheck s2 } | default value {%@@ -912,8 +937,19 @@ | derives comma upperId { $3 : $1 } checks : { [] }- | check lowerIdList semicolon { reverse $2 }+ | check functionRefList semicolon { $2 } +functionRefList: functionRef { [$1] }+ | functionRefList comma functionRef { $1 ++ [$3] }++functionRef: lowerIdTk {%+ do+ l <- mkLoc $1+ let n = tkString $1+ withSymbol l n requireFunction+ return n+ } + fieldId: lowerIdTk {% do l <- mkLoc $1@@ -925,33 +961,24 @@ fieldIdList : fieldId { [$1] } | fieldIdList comma fieldId { $3 : $1 } -fieldType : fieldTypeContent {%- do- let (l,ft) = $1- declare l "current field type" $ SFieldType ft- return ft - } -fieldTypeContent: - word32 {% fieldTypeWithLoc ($1,FTWord32) }- | word64 {% fieldTypeWithLoc ($1,FTWord64) }- | int32 {% fieldTypeWithLoc ($1,FTInt32) }- | int64 {% fieldTypeWithLoc ($1,FTInt64) }- | text {% fieldTypeWithLoc ($1,FTText) }- | bool {% fieldTypeWithLoc ($1,FTBool) }- | double {% fieldTypeWithLoc ($1,FTDouble) }- | timeofday {% fieldTypeWithLoc ($1,FTTimeOfDay) }- | day {% fieldTypeWithLoc ($1,FTDay) }- | utctime {% fieldTypeWithLoc ($1,FTUTCTime) }- | zonedtime {% fieldTypeWithLoc ($1,FTZonedTime) }+fieldType: + word32 { FTWord32 }+ | word64 { FTWord64 }+ | int32 { FTInt32 }+ | int64 { FTInt64 }+ | text { FTText }+ | bool { FTBool }+ | double { FTDouble }+ | timeofday { FTTimeOfDay }+ | day { FTDay }+ | utctime { FTUTCTime }+ | zonedtime { FTZonedTime } maybeMaybe : { False } | maybe {True } {--fieldTypeWithLoc :: (Token,FieldType) -> ParserMonad (Location, FieldType)-fieldTypeWithLoc (tk,ft) = mkLoc tk >>= \l -> return (l,ft) data ModDef = EntityDef Entity | ClassDef Class
YesodDsl/ParserState.hs view
@@ -8,19 +8,17 @@ ParserState, mkLoc, parseErrorCount, withSymbol, withGlobalSymbol, withSymbolNow, pError, hasReserved,- fieldValueToType,- fieldContentToType,- getSymbolType,+ getEntitySymbol, requireClass, requireEntity, requireEntityOrClass, requireEntityId, requireEntityField, requireField,- requireFieldType, requireEnum, requireEnumValue, requireParam,+ requireFunction, setCurrentHandlerType, getCurrentHandlerType, requireHandlerType,@@ -51,6 +49,7 @@ | SParam | SForParam InputFieldRef | SReserved+ | SFunction instance Show SymType where show st = case st of@@ -67,6 +66,7 @@ SParam -> "param" SForParam _ -> "for-param" SReserved -> "reserved"+ SFunction -> "function" data Sym = Sym Int Location SymType deriving (Show) @@ -98,7 +98,9 @@ show _ = "<entityvalidation>" initParserState :: ParserState initParserState = ParserState {- psSyms = Map.empty,+ psSyms = Map.fromList [+ ("ClassInstance", [ Sym 0 (Loc "<builtin>" 0 0) (SEntity "ClassInstance") ])+ ], psScopeId = 0, psPath = "", psParsed = [],@@ -153,12 +155,12 @@ "timezone_hour", "timezone_minute", "week", "year" ] -validateInsert :: Location -> Entity -> Maybe [InputField] -> ParserMonad ()-validateInsert l e (Just ifs) = do+validateInsert :: Location -> Entity -> Maybe (Maybe VariableName, [InputField]) -> ParserMonad ()+validateInsert l e (Just (Nothing, ifs)) = do case [ fieldName f | f <- entityFields e, (not . fieldOptional) f, isNothing (fieldDefault f) ] - L.\\ [ fn | (fn,_) <- ifs ] of+ L.\\ [ fn | (fn,_,_) <- ifs ] of fs@(_:_) -> pError l $ "Missing required fields without default value: " ++ (show fs) _ -> return () validateInsert _ _ _ = return ()@@ -244,9 +246,10 @@ declare' :: Bool -> Location -> String -> SymType -> ParserMonad () declare' global l n t = do ps <- get- let sym = [Sym (if global then 0 else psScopeId ps) l t] + let scopeId = if global then 0 else psScopeId ps+ sym = [Sym scopeId l t ] case Map.lookup n (psSyms ps) of- Just ((Sym s l' _):_) -> if s == psScopeId ps+ Just ((Sym s l' _):_) -> if s == scopeId then do pError l $ "'" ++ n ++ "' already declared in " ++ show l'@@ -314,26 +317,10 @@ withGlobalSymbol l n f = addGlobalPendingValidation $ \syms -> void $ withSymbol' syms () l n f -fieldValueToType :: FieldValue -> Maybe Type-fieldValueToType fv = case fv of- StringValue _ -> Just $ TypeField FTText- IntValue _ -> Just $ TypeField FTInt32- FloatValue _ -> Just $ TypeField FTDouble- BoolValue _ -> Just $ TypeField FTBool- NothingValue -> Nothing- -fieldContentToType :: FieldContent -> Type-fieldContentToType fc = case fc of- NormalField ft _ -> TypeField ft- EntityField en -> TypeEntityId en- EnumField en -> TypeEnum en -getSymbolType :: Location -> Location -> SymType -> ParserMonad (Maybe Type)-getSymbolType l1 l2 st = return $ case st of- SEnum et -> Just $ TypeEnum $ enumName et- SEntityId en -> Just $ TypeEntityId en- SField f -> Just $ fieldContentToType $ fieldContent f- _ -> Nothing+getEntitySymbol :: Location -> Location -> SymType -> ParserMonad (Maybe EntityName)+getEntitySymbol _ _ (SEntity en) = return $ Just en+getEntitySymbol _ _ _ = return Nothing requireClass :: (Class -> ParserMonad ()) -> (Location -> Location -> SymType -> ParserMonad ()) requireClass f = f'@@ -377,14 +364,14 @@ fun' _ _ (SEnum e) = return () fun' l1 l2 st = pError l1 $ "Reference to " ++ show st ++ " declared in " ++ show l2 ++ " (expected enum)" -requireEnumValue :: Location -> FieldName -> (Location -> Location -> SymType -> ParserMonad ())-requireEnumValue l fn = fun'+requireEnumValue :: Location -> EnumValue -> (Location -> Location -> SymType -> ParserMonad ())+requireEnumValue l ev = fun' where fun' _ _ (SEnum e) = - case L.find (\ev' -> ev' == fn) $ enumValues e of+ case L.find (\ev' -> ev' == ev) $ enumValues e of Just ev -> return () Nothing -> pError l $ "Reference to undeclared enum value '"- ++ fn ++ "' of enum '" ++ enumName e ++ "'"+ ++ ev ++ "' of enum '" ++ enumName e ++ "'" fun' l1 l2 st = pError l1 $ "Reference to " ++ show st ++ " declared in " ++ show l2 ++ " (expected enum)" requireParam :: (Location -> Location -> SymType -> ParserMonad ())@@ -399,3 +386,10 @@ requireField f = f' where f' _ _ (SField sf) = f sf f' l1 l2 st = pError l1 $ "Reference to " ++ show st ++ " declared in " ++ show l2 ++ " (expected field)"++requireFunction :: (Location -> Location -> SymType -> ParserMonad ())+requireFunction = fun'+ where + fun' _ _ SFunction = return ()+ fun' l1 l2 st = pError l1 $ "Reference to " ++ show st ++ " declared in " ++ show l2 ++ " (expected function)" +
codegen/class-entity-instance-field-entity.cg view
@@ -1,1 +1,1 @@-~{className c}Instance~{entityName e} (Entity _ e) -> ~{entityFieldName e f} e+~{className c}Instance~{entityName e} (Entity _ e) -> ~{mapper e}~{entityFieldName e f} e
codegen/class-instance-field.cg view
@@ -1,1 +1,1 @@- ~{classFieldName c f} = ~{entityFieldName e f}+ ~{classFieldName c f} = ~{mapper}~{entityFieldName e f}
codegen/class-select-filter-data-type.cg view
@@ -1,1 +1,1 @@-data ~{className c}InstanceFilterType = ~{intercalate " | " $ map fieldFilterDataType $ classFields c}+data ~{className c}InstanceFilterType = ~{intercalate " | " $ mapMaybe fieldFilterDataType $ classFields c}
codegen/class-update-data-type.cg view
@@ -1,1 +1,1 @@-data ~{className c}InstanceUpdateType = ~{intercalate " | " $ map fieldUpdateDataType $ classFields c}+data ~{className c}InstanceUpdateType = ~{intercalate " | " $ mapMaybe fieldUpdateDataType $ classFields c}
codegen/dispatch.cg view
@@ -24,7 +24,6 @@ type ~{moduleName m}Route = Route ~{moduleName m} instance (YesodAuthPersist master,- ~{moduleName m}Interface master, AuthId master ~ Key User, AuthEntity master ~ User, YesodPersistBackend master ~ SqlBackend) => YesodSubDispatch ~{moduleName m} (HandlerT master IO) where
codegen/enum.cg view
@@ -1,4 +1,4 @@-data ~{enumName e} = ~{prefixedValues e} deriving (Eq)+data ~{enumName e} = ~{prefixedValues e} deriving (Eq, Ord, Enum) instance Read ~{enumName e} where ~{readsPrecs} readsPrec _ _ = [ ]
codegen/get-by-id.cg view
@@ -1,4 +1,4 @@- ~{vn} <- do+ result_~{vn} <- do r <- get $ ((~{ifr}) :: ~{en}Id) case r of Just e -> return e
+ codegen/get-call.cg view
@@ -0,0 +1,1 @@+ ~{fn} (~{intercalate ") (" ifrs})
codegen/get-handler-select.cg view
@@ -1,1 +1,1 @@- ~{result} <- lift $ runDB $ select $ from $ \(~{selectFromVariable}~{concatMap getHandlerJoinDef joins}) -> do+ ~{result} <- select $ from $ \(~{selectFromVariable}~{concatMap getHandlerJoinDef joins}) -> do
codegen/handler-header.cg view
@@ -1,7 +1,7 @@-~{hsHandlerMethod ht}~{hsRouteName (routePath r)} :: forall master. (~{moduleName m}Interface master, +~{hsHandlerMethod ht}~{hsRouteName (routePath r)} :: forall master. ( YesodAuthPersist master, AuthEntity master ~ User, AuthId master ~ Key User, YesodPersistBackend master ~ SqlBackend) => ~{hsRouteType (routePath r)}HandlerT ~{moduleName m} (HandlerT master IO) A.Value-~{hsHandlerMethod ht}~{hsRouteName (routePath r)} ~{hsRouteParams (routePath r)} = do+~{hsHandlerMethod ht}~{hsRouteName (routePath r)} ~{hsRouteParams (routePath r)} = lift $ runDB $ do
+ codegen/import.cg view
@@ -0,0 +1,1 @@+import ~{importModule i} (~{intercalate "," $ importFunctions i})
codegen/input-field-local-param-field.cg view
@@ -1,1 +1,1 @@-(~{lowerFirst en}~{upperFirst fn} ~{vn})+(~{lowerFirst en}~{upperFirst fn} result_~{vn})
− codegen/interface-header.cg
@@ -1,12 +0,0 @@-checkResult :: forall (m :: * -> *). (Monad m) => Text -> m Bool -> m (Maybe Text)-checkResult msg f = do- result <- f- return $ if result then Nothing else (Just msg)--class Validatable a where- validate :: forall master. (SqlBackend ~ YesodPersistBackend master,- YesodPersist master,- ~{moduleName m}Interface master) - => a -> HandlerT master IO [Text]--class Yesod master => ~{moduleName m}Interface master where
+ codegen/prepare-request-input-field.cg view
@@ -0,0 +1,2 @@+ attr_~{fn}' <- lookupGetParam "~{fn}"+ let attr_~{fn} = attr_~{fn}' >>= PP.fromPathPiece
codegen/read-input-object-fields.cg view
@@ -1,5 +1,5 @@ e~{show pId} <- do ~{maybeExisting}- return $ ~{entityName e} {+ return $ ~{entityToUpdate} { ~{indent 16 $ fieldMappers} }
codegen/require-select-query.cg view
@@ -1,5 +1,5 @@ _ <- do- result <- lift $ runDB $ select $ from $ \(~{selectVar} ~{concatMap joinDef (sqJoins sq)}) -> do+ result <- select $ from $ \(~{selectVar} ~{concatMap joinDef (sqJoins sq)}) -> do ~{indent 12 $ joinExprs} let ~{selectVar}Id' = ~{selectVar} ^. ~{selectEntity}Id ~{indent 12 $ maybeWhere} limit 1
codegen/route-header.cg view
@@ -17,6 +17,7 @@ import Handler.~{moduleName m}.Enums import Handler.~{moduleName m}.Esqueleto import Handler.~{moduleName m}.Internal+import Handler.~{moduleName m}.Validation import qualified Handler.~{moduleName m}.PathPieces as PP import Prelude import Database.Esqueleto@@ -55,4 +56,4 @@ import Control.Applicative ((<$>), (<*>)) import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS-+~{imports}
codegen/rundb.cg view
@@ -1,1 +1,1 @@- runDB_result <- lift $ runDB $ do+ runDB_result <- do
+ codegen/select-bound-result.cg view
@@ -0,0 +1,1 @@+ let e = result_~{vn}
codegen/select-count.cg view
@@ -1,4 +1,4 @@- count <- lift $ runDB $ select $ do+ count <- select $ do baseQuery False let countRows' = countRows orderBy []
codegen/select-existing.cg view
@@ -1,4 +1,4 @@- es <- lift $ runDB $ select $ from $ \o -> do+ es <- select $ from $ \o -> do where_ (o ^. ~{entityName e}Id ==. (val ~{ifr})) limit 1 return o
codegen/select-results.cg view
@@ -1,1 +1,1 @@- results <- lift $ runDB $ select $ baseQuery True+ results <- select $ baseQuery True
− codegen/validation-function-field.cg
@@ -1,1 +0,0 @@- ~{func} :: (YesodPersist master) => ~{hsFieldType f} -> HandlerT master IO Bool
+ codegen/validation-header.cg view
@@ -0,0 +1,71 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Handler.~{moduleName m}.Validation where+import Handler.~{moduleName m}.Internal+import qualified Handler.~{moduleName m}.PathPieces as PP+import Prelude+import Control.Monad (forM_, when)+import Control.Monad.Catch (MonadThrow)+import Database.Esqueleto+import Database.Esqueleto.Internal.Sql (unsafeSqlBinOp, unsafeSqlExtractSubField, UnsafeSqlFunctionArgument)+import qualified Database.Persist as P+import Database.Persist.TH+import Yesod.Auth (requireAuth, requireAuthId, YesodAuth, AuthId, YesodAuthPersist)+import Yesod.Core hiding (fileName, fileContentType)+import Yesod.Persist (runDB, YesodPersist, YesodPersistBackend)+import Data.Aeson ((.:), (.:?), (.!=), FromJSON, parseJSON, decode)+import Data.Aeson.TH+import Data.Int+import Data.Word+import Data.Time+import Data.Text.Encoding (encodeUtf8)+import Data.Typeable (Typeable)+import qualified Data.Attoparsec as AP+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as AT+import qualified Data.ByteString.Lazy as LBS+import Data.Maybe+import qualified Data.Text.Read+import qualified Data.Text as T+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.List as DL+import Control.Monad (mzero)+import Control.Monad.Trans.Resource (runResourceT)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Conduit as C+import qualified Network.Wai as W+import Data.Conduit.Lazy (lazyConsume)+import Network.HTTP.Types (status200, status400, status403, status404)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Control.Applicative ((<$>), (<*>)) +import qualified Data.HashMap.Lazy as HML+import qualified Data.HashMap.Strict as HMS+import qualified Data.Text.Lazy.Builder as TLB+~{allImports m}++checkResult :: forall (m :: * -> *). (Monad m) => Text -> m Bool -> m (Maybe Text)+checkResult msg f = do+ result <- f+ return $ if result then Nothing else (Just msg)++class Validatable a where+ validate :: forall master. (SqlBackend ~ YesodPersistBackend master,+ YesodPersist master)+ => a -> HandlerT master IO [Text]++
main/main.hs view
@@ -1,3 +1,5 @@+import Paths_yesod_dsl (version)+import Data.Version (showVersion) import YesodDsl.Lexer import YesodDsl.Parser import System.Environment@@ -9,11 +11,12 @@ import System.IO import YesodDsl.ExpandMacros -data Flag = - FayPath String deriving Eq+data Flag = Version + | FayPath String deriving Eq options :: [OptDescr Flag] options = [- Option ['f'] ["fay"] (ReqArg FayPath "FILE") "translate DSL definition to Fay compatible code and store it in FILE"+ Option ['f'] ["fay"] (ReqArg FayPath "FILE") "translate DSL definition to Fay compatible code and store it in FILE",+ Option ['v'] ["version"] (NoArg Version) "print version number" ] header :: String@@ -24,18 +27,22 @@ args <- getArgs case getOpt RequireOrder options args of (o, (path:_), []) -> main' o path- (_, _, msgs) -> error $ concat msgs ++ usageInfo header options+ (o, _, msgs) -> if Version `elem` o+ then versionInfo + else error $ concat msgs ++ usageInfo header options where- + versionInfo = putStrLn $ "yesod-dsl " ++ showVersion version main' o path = do- mast <- parse path- case mast of- Just ast -> do- generate path $ ast - forM_ o (processFlag ast)- Nothing -> return ()+ if Version `elem` o+ then versionInfo+ else do+ mast <- parse path+ case mast of+ Just ast -> do+ generate path $ ast + forM_ o (processFlag ast)+ Nothing -> return () processFlag ast (FayPath path) = genFay path ast- processFlag _ _ = return ()
yesod-dsl.cabal view
@@ -1,5 +1,5 @@ name: yesod-dsl-version: 0.1.1.22+version: 0.1.1.23 license: BSD3 license-file: LICENSE author: Tero Laitinen @@ -17,6 +17,7 @@ library build-depends: base >= 4 && < 5+ , shakespeare , shakespeare-text >= 1.0 && < 1.1 , text >= 0.11 , directory >= 1.1.0.2@@ -29,6 +30,7 @@ , strict , Cabal , syb+ , uniplate Build-tools: alex, happy ghc-options: -Wall -O0 exposed: True@@ -43,13 +45,14 @@ YesodDsl.ModuleMerger YesodDsl.Generator.Classes YesodDsl.Generator.Common+ YesodDsl.Generator.Input YesodDsl.Generator.Esqueleto YesodDsl.Generator.GetHandler YesodDsl.Generator.Handlers YesodDsl.Generator.Models YesodDsl.Generator.Routes YesodDsl.Generator.UpdateHandlers- YesodDsl.Generator.Interface+ YesodDsl.Generator.Validation YesodDsl.Generator.Require YesodDsl.Generator.Cabal YesodDsl.Generator.EsqueletoInstances