module YesodDsl.Generator.GetHandler where
import Data.String.Utils (rstrip)
import YesodDsl.AST
import Text.Shakespeare.Text hiding (toText)
import qualified Data.Text as T
import Data.List
import Data.Maybe
import YesodDsl.Generator.Common
import YesodDsl.Generator.Esqueleto
import YesodDsl.Generator.Models
import YesodDsl.Generator.Require
import YesodDsl.Generator.Input
import Control.Monad.Reader
import Data.Generics.Uniplate.Data
import qualified Data.Map as Map
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")
where forceType = if useFlag == True then (""::String) else " :: Maybe Text"
getStmt _ = ""
ctxFields :: SelectQuery -> Reader Context [(Entity, VariableName, Field, VariableName, MaybeFlag)]
ctxFields sq = do
names <- asks ctxNames
let fields = [ (e,vn,f,mf) | (vn,(e,mf)) <- Map.toList names, f <- entityFields e, fieldInternal f == False ]
usage = Map.fromListWith (+) [ (fieldJsonName f,1::Int) | (_,_,f,_) <- fields ]
return $ [
(e,vn,f,if Map.findWithDefault 1 (fieldJsonName f) usage == 1 || vn == fromVn then fieldJsonName f else vn ++ "." ++ fieldJsonName f,mf)
| (e,vn,f,mf) <- fields
]
where
(_,fromVn) = sqFrom sq
defaultFilterField :: (Entity, VariableName, Field,VariableName,MaybeFlag) -> Reader Context String
defaultFilterField (e,vn,f,alias,isMaybe) = do
let maybeLevel = boolToInt isMaybe + boolToInt (fieldOptional f)
return $ T.unpack $ if maybeLevel > 0
then $(codegenFile "codegen/default-filter-field-maybe.cg")
else $(codegenFile "codegen/default-filter-field.cg")
defaultFilterFields :: SelectQuery -> Reader Context String
defaultFilterFields sq = do
fs <- ctxFields sq
fields' <- liftM concat $ mapM defaultFilterField fs
let (er,vn) = sqFrom sq
en = entityRefName er
let fields = (T.unpack $(codegenFile "codegen/default-filter-id-field.cg")
++ fields')
return $ T.unpack $(codegenFile "codegen/default-filter-fields.cg")
defaultSortField :: (Entity, VariableName, Field, ParamName, MaybeFlag) -> Reader Context String
defaultSortField (e,vn,f,pn,isMaybe) = do
return $ T.unpack $(codegenFile "codegen/default-sort-field.cg")
defaultSortFields :: SelectQuery -> Reader Context String
defaultSortFields 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
return [ (e,vn, f, maybe (fieldName f) id an,mf)
| f <- entityFields e,
fieldName f == fn ]
fromSelectField (SelectIdField _ _) = return []
fromSelectField _ = return []
implicitJoinExpr :: Join -> Reader Context String
implicitJoinExpr (Join _ _ _ (Just expr)) = do
e <- hsBoolExpr expr
return $ "where_ (" ++ e ++ ")\n"
implicitJoinExpr _ = return ""
baseIfFilter :: IfFilterParams -> Reader Context String
baseIfFilter (pn,joins,bExpr,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
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")
getHandlerSelect :: [Stmt] -> String
getHandlerSelect ps =
case listToMaybe [ sq | Select sq <- universeBi ps ] of
Just sq -> runReader (do
let defaultFilterSort = DefaultFilterSort `elem` ps
ifFilters = map (\(IfFilter f) -> f) $ filter isIfFilter ps
isIfFilter (IfFilter _) = True
isIfFilter _ = False
(limit, offset) = sqLimitOffset sq
(selectEntity, selectVar) = sqFrom sq
maybeDefaultLimitOffset =
if defaultFilterSort
then T.unpack $(codegenFile "codegen/default-offset-limit.cg")
else ""
maybeWhere <- case sqWhere sq of
Just expr -> do
e <- hsBoolExpr expr
return $ "where_ (" ++ e ++ ")\n"
Nothing -> return ""
joinExprs <- liftM concat $ mapM mapJoinExpr $ reverse $ sqJoins sq
ifFiltersStr <- liftM concat $ mapM baseIfFilter ifFilters
filterFieldsStr <- defaultFilterFields sq
returnFieldsStr <- selectReturnFields sq
maybeDefaultSortFields <- if defaultFilterSort
then defaultSortFields sq
else do
staticSortFields <- mapM hsOrderBy $ sqOrderBy sq
return $ T.unpack $(codegenFile "codegen/static-order-by.cg")
return $ concat [
(T.unpack $(codegenFile "codegen/base-select-query.cg")),
(if defaultFilterSort
then filterFieldsStr
++ ifFiltersStr
else ""),
(indent 8 returnFieldsStr),
(T.unpack $(codegenFile "codegen/select-count.cg")),
(T.unpack $(codegenFile "codegen/select-results.cg")),
getHandlerReturn sq
]) (emptyContext { ctxNames = sqAliases sq })
Nothing -> ""
getHandlerReturn :: SelectQuery -> String
getHandlerReturn sq = T.unpack $(codegenFile "codegen/get-handler-return.cg")
where
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 _ = []
mapResultField (fn,i) = T.unpack $(codegenFile "codegen/map-result-field.cg")
getHandlerMaybeAuth :: [Stmt] -> String
getHandlerMaybeAuth ps
| (not . null) (filter isAuthField fieldRefs) = T.unpack $(codegenFile "codegen/load-auth.cg")
| otherwise = ""
where fieldRefs = concatMap universeBi ps
isAuthField (AuthField _) = True
isAuthField _ =False
callStmts :: [Stmt]-> String
callStmts ps = concatMap f $ zip ([1..] :: [Int]) ps
where
f (_,(Call fn frs)) =
let ifrs = map inputFieldRef frs
in T.unpack $(codegenFile "codegen/get-call.cg")
f _ = ""
getHandlerReadRequestFields :: [Stmt] -> String
getHandlerReadRequestFields ps =
let attrs = nub $ concatMap getJsonAttrs ps
defaults = getParamDefaults ps
prepareRequestInputField fn Nothing = T.unpack $(codegenFile "codegen/prepare-request-input-field.cg")
prepareRequestInputField fn (Just d) = T.unpack $(codegenFile "codegen/prepare-request-input-field-default.cg")
in if null attrs
then ""
else concatMap (\attr -> prepareRequestInputField attr (Map.lookup attr defaults)) attrs
getHandler :: [Stmt]-> String
getHandler ps = concat [
getHandlerMaybeAuth ps,
concatMap getStmt ps,
getHandlerReadRequestFields ps,
requireStmts ps,
callStmts ps,
getHandlerSelect ps
]