module YesodDsl.Generator.Esqueleto where
import YesodDsl.AST
import Data.Maybe
import Data.List
import YesodDsl.Generator.Common
import Data.String.Utils (lstrip, rstrip)
import Control.Monad.Reader
import qualified Data.Map as Map
hsBinOp :: BinOp -> String
hsBinOp op = case op of
Eq -> "==."
Ne -> "!=."
Lt -> "<."
Gt -> ">."
Le -> "<=."
Ge -> ">=."
Like -> "`like`"
Ilike -> "`ilike`"
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),
ctxExprType :: Maybe String,
ctxExprListValue :: Bool
}
emptyContext :: Context
emptyContext = Context {
ctxNames = Map.empty,
ctxExprType = Nothing,
ctxExprListValue = False
}
boolToInt :: Bool -> Int
boolToInt True = 1
boolToInt False = 0
annotateType :: Bool -> Maybe String -> String -> String
annotateType listValue (Just exprType) s = "(" ++ s ++ " :: " ++ (if listValue then "[" ++ exprType ++ "]" else exprType) ++ ")"
annotateType _ Nothing s = s
projectField :: MaybeFlag -> String
projectField True = " ?. "
projectField False = " ^. "
extractSubField :: FieldName -> String
extractSubField fn = case fn of
"century" -> "CENTURY"
"day" -> "DAY"
"decade" -> "DECADE"
"dow" -> "DOW"
"doy" -> "DOY"
"epoch" -> "EPOCH"
"hour" -> "HOUR"
"isodow" -> "ISODOW"
"microseconds" -> "MICROSECONDS"
"millennium" -> "MILLENNIUM"
"millseconds" -> "MILLISECONDS"
"minute" -> "MINUTE"
"month" -> "MONTH"
"quarter" -> "QUARTER"
"second" -> "SECOND"
"timezone" -> "TIMEZONE"
"timezone_hour" -> "TIMEZONE_HOUR"
"timezone_minute" -> "TIMEZONE_MINUTE"
"week" -> "WEEK"
"year" -> "YEAR"
fn' -> error $ "Unknown subfield : " ++ fn'
valueOrValueList :: Bool -> Int -> String
valueOrValueList listValue promoteJust = if listValue
then "valList" ++ (if promoteJust > 0 then " $ map Just" else "")
else "val" ++ (if promoteJust > 0 then " $ Just" else "")
normalFieldRef :: MaybeLevel -> String -> Reader Context String
normalFieldRef ml content = do
lv <- asks ctxExprListValue
et <- asks ctxExprType
return $ brackets (isJust et) $ valueOrValueList lv ml ++" " ++ annotateType lv et content
hsFieldRef :: MaybeLevel -> FieldRef -> Reader Context String
hsFieldRef ml (SqlId (Var vn (Right e) mf)) = do
return $ makeJust ml $ vn ++ projectField mf ++ entityName e ++ "Id"
hsFieldRef ml (SqlField (Var vn (Right e) mf) fn) = do
return $ makeJust ml $ vn ++ projectField mf ++ entityName e ++ (upperFirst fn)
hsFieldRef ml AuthId = do
lv <- asks ctxExprListValue
return $ valueOrValueList lv ml ++ " authId"
hsFieldRef ml (PathParam p) = normalFieldRef ml $ "p" ++ show p
hsFieldRef ml LocalParam = normalFieldRef ml "localParam"
hsFieldRef ml (LocalParamField (Var vn (Right e) _) fn) = normalFieldRef ml $ entityName e ++ upperFirst fn ++ " $ result_" ++ vn
hsFieldRef ml (RequestField fn) = normalFieldRef ml $ "attr_" ++ fn
hsFieldRef ml (EnumValueRef en vn) = normalFieldRef ml $ en ++ vn
hsFieldRef ml (NamedLocalParam vn) = normalFieldRef ml $ "result_" ++ vn
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 :: (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) ++ "))"
hsExpr :: MaybeLevel -> Expr -> Reader Context String
hsExpr ml ve = do
c <- content
maybePromoteJust c
where
maybePromoteJust c = case ve of
SubQueryExpr _ -> return c
FieldExpr fr -> case fr of
_ -> return c
_ -> do
return $ makeJust ml c
content = case ve of
FieldExpr fr -> hsFieldRef ml fr
ConcatManyExpr ves -> local noListValue $ do
rs <- mapM (hsExpr 0) ves
return $ "(concat_ [" ++ intercalate ", " rs ++ "])"
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)
fieldRefMaybeLevel (Const NothingValue) = 1
fieldRefMaybeLevel _ = 0
exprMaybeLevel :: Expr -> Int
exprMaybeLevel ve = case ve of
FieldExpr fr -> fieldRefMaybeLevel fr
ConcatManyExpr _ -> 0
BinOpExpr e1 _ e2 -> 0
UnOpExpr _ e -> 0
SubQueryExpr sq -> fromMaybe 0 $ listToMaybe $ map exprMaybeLevel $ concatMap (selectFieldExprs) $ sqFields sq
_ -> 0
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
UnOpExpr Floor _ -> Just "Double"
UnOpExpr Ceiling _ -> Just "Double"
UnOpExpr (Extract _) _ -> Just "Double"
_ -> Nothing
mapJoinExpr :: Join -> Reader Context String
mapJoinExpr (Join _ _ _ (Just expr)) = do
e <- hsExpr 0 expr
return $ "on (" ++ e ++ ")\n"
mapJoinExpr _ = return ""
selectReturnFields :: SelectQuery -> Reader Context String
selectReturnFields sq = do
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
subQuery :: String -> SelectQuery -> Reader Context String
subQuery sqFunc sq = withScope (sqAliases sq) $ do
jes <- liftM (concat . (map makeInline)) $ mapM mapJoinExpr (reverse $ sqJoins sq)
rfs <- selectReturnFields sq
maybeWhere <- case sqWhere sq of
Just expr -> do
e <- hsExpr 0 expr
return $ "where_ (" ++ e ++ ")"
Nothing -> return ""
return $ sqFunc ++ " $ from $ \\(" ++ vn ++
(concatMap joinDef (sqJoins sq)) ++ ") -> do { " ++
jes
++ " ; " ++ maybeWhere
++ " ; " ++ (makeInline $ rfs)
++ " }"
where
makeInline = (++" ;") . lstrip . rstrip
(_, vn) = sqFrom sq
withScope :: Map.Map VariableName (Entity, MaybeFlag) -> Reader Context a -> Reader Context a
withScope names = local $ \ctx -> ctx { ctxNames = Map.union names $ ctxNames ctx }
scopedExpr :: Map.Map VariableName (Entity, MaybeFlag) -> Expr -> String
scopedExpr names e = runReader (hsExpr 0 e) $ emptyContext { ctxNames = names }