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