109 lines
3.3 KiB
Haskell
109 lines
3.3 KiB
Haskell
module ChuSQL.Algebra.Eval (evalRelOp, evalRelOpM) where
|
||
|
||
import ChuSQL.Algebra.Expr (evalCondForRow)
|
||
import ChuSQL.Algebra.Op
|
||
import ChuSQL.Algebra.Sort (sortRows)
|
||
import ChuSQL.Model
|
||
import ChuSQL.Storage (MonadStorage (..))
|
||
import ChuSQL.Syntax.AST (Expr (..))
|
||
import Control.Monad (filterM, foldM)
|
||
|
||
-- 执行：按算子树算出结果行（Scan 阶段会加别名前缀）。
|
||
|
||
-- * 工具
|
||
|
||
-- | 只保留清单里的列
|
||
project :: [String] -> Row -> Row
|
||
project ["*"] row = row
|
||
project cs row = [(c, v) | (c, v) <- row, c `elem` cs]
|
||
|
||
-- | 给列名加别名前缀
|
||
addPrefix :: String -> Row -> Row
|
||
addPrefix prefix = map (\(k, v) -> (prefix ++ k, v))
|
||
|
||
-- | 主键匹配条件（id = k）
|
||
keyCondition :: Int -> Expr
|
||
keyCondition k = Eq (Col "id") (LitInt k)
|
||
|
||
-- | 扫描一张表
|
||
evalScan :: Database -> Maybe String -> String -> Either String [Row]
|
||
evalScan db mAlias tbl = do
|
||
table <- lookupTable db tbl
|
||
let prefix = maybe "" (++ ".") mAlias
|
||
Right (map (addPrefix prefix) (tableRows table))
|
||
|
||
-- | 把两边的行按条件配对（边配边筛，不先建整张积表）
|
||
filterPairs :: (Row -> Either String Bool) -> [Row] -> [Row] -> Either String [Row]
|
||
filterPairs cond lrows rrows = go lrows []
|
||
where
|
||
go [] acc = Right (reverse acc)
|
||
go (l : ls) acc = do
|
||
acc' <- foldM (keep l) acc rrows
|
||
go ls acc'
|
||
keep l acc r = do
|
||
let row = l ++ r
|
||
ok <- cond row
|
||
pure (if ok then row : acc else acc)
|
||
|
||
-- * 求值
|
||
|
||
-- | 纯求值（不需要存储）
|
||
evalRelOp :: Database -> RelOp -> Either String [Row]
|
||
evalRelOp db (Scan mAlias tbl) = evalScan db mAlias tbl
|
||
evalRelOp db (Lookup tbl k) = do
|
||
rows <- evalScan db Nothing tbl
|
||
filterM (evalCondForRow (keyCondition k)) rows
|
||
evalRelOp db (Filter e op) = do
|
||
rows <- evalRelOp db op
|
||
filterM (evalCondForRow e) rows
|
||
evalRelOp db (Project cols op) = do
|
||
rows <- evalRelOp db op
|
||
Right (map (project cols) rows)
|
||
evalRelOp db (Sort spec op) = do
|
||
rows <- evalRelOp db op
|
||
Right (sortRows spec rows)
|
||
evalRelOp db (Limit n op) = do
|
||
rows <- evalRelOp db op
|
||
Right (take n rows)
|
||
evalRelOp db (Join left right cond) = do
|
||
lrows <- evalRelOp db left
|
||
rrows <- evalRelOp db right
|
||
filterPairs (evalCondForRow cond) lrows rrows
|
||
|
||
-- | 单子求值：Lookup 问存储
|
||
evalRelOpM :: (MonadStorage m) => RelOp -> m (Either String [Row])
|
||
evalRelOpM (Scan mAlias t) = do
|
||
result <- scan t
|
||
pure $ do
|
||
rows <- result
|
||
case mAlias of
|
||
Nothing -> Right rows
|
||
Just a -> Right (map (addPrefix (a ++ ".")) rows)
|
||
evalRelOpM (Lookup t k) = do
|
||
result <- lookupByKey t k
|
||
pure $ case result of
|
||
Left e -> Left e
|
||
Right Nothing -> Right []
|
||
Right (Just row) -> Right [row]
|
||
evalRelOpM (Filter p x) = do
|
||
result <- evalRelOpM x
|
||
pure $ do
|
||
rows <- result
|
||
filterM (evalCondForRow p) rows
|
||
evalRelOpM (Project cols x) = do
|
||
result <- evalRelOpM x
|
||
pure (fmap (map (project cols)) result)
|
||
evalRelOpM (Sort spec x) = do
|
||
result <- evalRelOpM x
|
||
pure (fmap (sortRows spec) result)
|
||
evalRelOpM (Limit n x) = do
|
||
result <- evalRelOpM x
|
||
pure (fmap (take n) result)
|
||
evalRelOpM (Join l r cond) = do
|
||
ls <- evalRelOpM l
|
||
rs <- evalRelOpM r
|
||
pure $ do
|
||
left <- ls
|
||
right <- rs
|
||
filterPairs (evalCondForRow cond) left right
|