module YesodDsl.Generator.Esqueleto where
import YesodDsl.AST
import Data.Maybe
import qualified Data.Text as T
import Data.List
import Text.Shakespeare.Text hiding (toText)
import YesodDsl.Generator.Common
import Data.String.Utils (lstrip, rstrip)
import Control.Monad.State
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`"
type TypeName = String
data Context = Context {
ctxNames :: [(EntityName, VariableName, MaybeFlag)],
ctxModule :: Module,
ctxRoute :: Maybe Route,
ctxHandlerParams :: [HandlerParam],
ctxExprType :: Maybe String,
ctxExprMaybeLevel :: Int,
ctxExprListValue :: Bool,
ctxCalls :: [ (FunctionName, [TypeName]) ],
ctxTypes :: Map.Map InputFieldRef TypeName
}
emptyContext :: Module -> Context
emptyContext m = Context {
ctxNames = [],
ctxModule = m,
ctxRoute = Nothing,
ctxHandlerParams = [],
ctxExprType = Nothing,
ctxExprMaybeLevel = 0,
ctxExprListValue = False,
ctxCalls = [],
ctxTypes = Map.empty
}
ctxLookupEntity :: VariableName -> State Context (Maybe EntityName)
ctxLookupEntity vn = do
names <- gets ctxNames
return $ maybe Nothing (\(en,_,_) -> Just en) $ find (\(_,vn',_) -> vn == vn') names
ctxLookupVariable :: EntityName -> State Context (Maybe VariableName)
ctxLookupVariable en = do
names <- gets ctxNames
return $ maybe Nothing (\(_,vn,_) -> Just vn) $ find (\(en',_,_) -> en == en') names
ctxLookupField :: VariableName -> FieldName -> State Context (Maybe Field)
ctxLookupField vn fn = do
m <- gets ctxModule
men <- ctxLookupEntity vn
return $ men >>= \en -> lookupField m en fn
boolToInt :: Bool -> Int
boolToInt True = 1
boolToInt False = 0
ctxMaybeLevel :: VariableName -> State Context Int
ctxMaybeLevel vn = do
names <- gets ctxNames
return $ boolToInt $ maybe False (\(_,_,f) -> f) $ find (\(_,vn',_) -> vn == vn') names
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 :: String -> State Context String
normalFieldRef content = do
j <- gets ctxExprMaybeLevel
lv <- gets ctxExprListValue
et <- gets ctxExprType
return $ brackets (isJust et) $ valueOrValueList lv j ++" " ++ annotateType lv et content
hsFieldRef :: FieldRef -> State Context String
hsFieldRef (FieldRefId vn) = do
j <- gets ctxExprMaybeLevel
m <- ctxMaybeLevel vn
men <- ctxLookupEntity vn
return $ makeJust j $ vn ++ projectField (m > 0) ++ fromMaybe "(Nothing)" men ++ "Id"
hsFieldRef (FieldRefNormal vn fn) = do
j <- gets ctxExprMaybeLevel
m <- ctxMaybeLevel vn
men <- ctxLookupEntity vn
return $ makeJust j $ vn ++ projectField (m > 0) ++ fromMaybe "(Nothing)" men
++ (upperFirst fn)
hsFieldRef FieldRefAuthId = do
j <- gets ctxExprMaybeLevel
lv <- gets ctxExprListValue
return $ valueOrValueList lv j ++ " authId"
hsFieldRef (FieldRefPathParam p) = normalFieldRef $ "p" ++ show p
hsFieldRef FieldRefLocalParam = normalFieldRef $ "localParam"
hsFieldRef (FieldRefRequest fn) = normalFieldRef $ "attr_" ++ fn
hsFieldRef (FieldRefEnum en vn) = normalFieldRef $ en ++ vn
hsFieldRef (FieldRefNamedLocalParam vn) = normalFieldRef $ "result_" ++ vn
hsFieldRef (FieldRefParamField vn pn) = return $ "{- param field " ++ vn ++ " " ++ pn ++ "-}"
hsOrderBy :: (FieldRef, SortDir) -> State Context String
hsOrderBy (f,d) = do
content <- hsFieldRef 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 -> "++."
resetMaybe :: State Context String -> State Context String
resetMaybe = localCtx $ \ctx -> ctx { ctxExprMaybeLevel = 0 }
hsValExpr :: ValExpr -> State Context String
hsValExpr ve = do
c <- content
maybePromoteJust c
where
maybePromoteJust c = case ve of
SubQueryExpr _ -> return c
FieldExpr _ -> return c
_ -> do
j <- gets ctxExprMaybeLevel
return $ makeJust j c
content = case ve of
FieldExpr fr -> hsFieldRef fr
ConstExpr (fv@(NothingValue)) -> do
return $ fieldValueToEsqueleto fv
ConstExpr fv -> do
return $ "(val " ++ fieldValueToEsqueleto fv ++ ")"
ConcatManyExpr ves -> resetMaybe $ do
rs <- mapM hsValExpr ves
return $ "(concat_ [" ++ intercalate ", " rs ++ "])"
ValBinOpExpr e1 vop e2 -> resetMaybe $ do
r1 <- hsValExpr e1
r2 <- hsValExpr e2
return $ "(" ++ r1 ++ ") " ++ hsValBinOp vop ++ " (" ++ r2 ++ ")"
RandomExpr -> return "random_"
FloorExpr ve -> resetMaybe $ do
r <- hsValExpr ve
return $ "(floor_ $ " ++ r ++ ")"
CeilingExpr ve -> resetMaybe $ do
r <- hsValExpr ve
return $ "(ceiling_ $ " ++ r ++ ")"
ExtractExpr fn ve -> resetMaybe $ do
r <- hsValExpr ve
return $ "(extractSubField " ++ (quote $ extractSubField fn) ++ " $ " ++ r++ ")"
SubQueryExpr sq -> subQuery "subList_select" sq
fieldRefMaybeLevel :: FieldRef -> State Context Int
fieldRefMaybeLevel (FieldRefId vn) = ctxMaybeLevel vn
fieldRefMaybeLevel (FieldRefNormal vn fn) = do
m <- ctxMaybeLevel vn
mf <- ctxLookupField vn fn
return $ m + (boolToInt $ fromMaybe False $ mf >>= return . fieldOptional)
fieldRefMaybeLevel _ = return 0
exprMaybeLevel :: ValExpr -> State Context Int
exprMaybeLevel ve = case ve of
FieldExpr fr -> fieldRefMaybeLevel fr
ConstExpr NothingValue -> return 1
ConstExpr _ -> return 0
ConcatManyExpr ves -> do
es <- mapM exprMaybeLevel ves
return $ maximum es
ValBinOpExpr e1 _ e2 -> do
e1m <- exprMaybeLevel e1
e2m <- exprMaybeLevel e2
return $ max e1m e2m
FloorExpr e -> exprMaybeLevel e
CeilingExpr e -> exprMaybeLevel e
ExtractExpr _ e -> exprMaybeLevel e
SubQueryExpr sq -> do
ctx <- get
withScope (sqAliases sq) $ do
fs <- liftM concat $ mapM selectFieldExprs $ sqFields sq
mls <- mapM exprMaybeLevel fs
return $ fromMaybe 0 $ listToMaybe mls
exprReturnType :: ValExpr -> State Context (Maybe String)
exprReturnType e = return $ case e of
FloorExpr _ -> Just "Double"
CeilingExpr _ -> Just "Double"
ExtractExpr _ _ -> Just "Double"
_ -> Nothing
mapJoinExpr :: Join -> State Context String
mapJoinExpr (Join _ en vn (Just expr)) = do
e <- hsBoolExpr expr
return $ "on (" ++ e ++ ")\n"
mapJoinExpr _ = return ""
selectFieldExprs :: SelectField -> State Context [ValExpr]
selectFieldExprs sf = do
ctx <- get
m <- gets ctxModule
case sf of
(SelectAllFields vn) -> do
men <- ctxLookupEntity vn
let me = men >>= \en -> lookupEntity m en
return $ case me of
Just e -> [ FieldExpr $ FieldRefNormal vn (fieldName f)
| f <- entityFields e,
fieldInternal f == False ]
Nothing -> []
(SelectField vn fn _) -> return [ FieldExpr $ FieldRefNormal vn fn]
(SelectIdField vn _) -> return [ FieldExpr $ FieldRefId vn ]
(SelectValExpr ve _) -> return [ ve ]
selectReturnFields :: SelectQuery -> State Context String
selectReturnFields sq = do
fieldExprs <- liftM concat $ mapM selectFieldExprs (sqFields sq)
ves <- mapM hsValExpr fieldExprs
return $ "return (" ++ (intercalate ", " ves) ++ ")"
joinDef :: Join-> String
joinDef (Join jt _ vn _) = "`" ++ show jt ++ "` " ++ vn
subQuery :: String -> SelectQuery -> State 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 <- hsBoolExpr expr
return $ "where_ (" ++ e ++ ")"
Nothing -> return ""
return $ sqFunc ++ " $ from $ \\(" ++ vn ++
(concatMap joinDef (sqJoins sq)) ++ ") -> do { " ++
jes
++ " ; " ++ maybeWhere
++ " ; " ++ (makeInline $ rfs)
++ " }"
where
makeInline = (++" ;") . lstrip . rstrip
(en, vn) = sqFrom sq
withScope :: [(EntityName, VariableName, MaybeFlag)] -> State Context a -> State Context a
withScope names = localCtx (\ctx -> ctx { ctxNames = ctxNames ctx ++ names })
localCtx :: (Context -> Context) -> (State Context a) -> (State Context a)
localCtx f st = do
ctx <- get
put $ f ctx
r <- st
ctx' <- get
put $ ctx { ctxCalls = ctxCalls ctx' }
return r
hsBoolExpr :: BoolExpr -> State Context String
hsBoolExpr expr = 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
e1m <- exprMaybeLevel e1
e2m <- exprMaybeLevel e2
e1rt <- exprReturnType e1
e2rt <- exprReturnType e2
r1 <- localCtx
(\ctx -> ctx {
ctxExprMaybeLevel = max 0 $ e2m e1m ,
ctxExprType = e2rt
} )
(hsValExpr e1)
r2 <- localCtx
(\ctx -> ctx {
ctxExprType = case op of
Ilike -> Just "Text"
Like -> Just "Text"
_ -> e1rt,
ctxExprMaybeLevel = max 0 $ e1m e2m,
ctxExprListValue = op `elem` [In, NotIn]
})
(hsValExpr e2)
return $ "(" ++ r1 ++ ") " ++ hsBinOp op ++ " (" ++ r2 ++ ")"
ExistsExpr sq -> subQuery "exists" sq