修bug，完善功能

chusql-core/engine/chusql-core-engine.cabal

@@ -10,7 +10,8 @@ build-type:     Simple
 
 library
     hs-source-dirs:   src
-    exposed-modules:  ChuSQL.Core.Engine.Algebra.Cost
+    exposed-modules:  ChuSQL.Core.Engine.Domain
+                      ChuSQL.Core.Engine.Algebra.Cost
                       ChuSQL.Core.Engine.Algebra.Eval
                       ChuSQL.Core.Engine.Algebra.Expr
                       ChuSQL.Core.Engine.Algebra.JoinOrder

chusql-core/engine/src/ChuSQL/Core/Engine.hs

@@ -1,18 +1,19 @@
-module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf, BoundWrite, bindWrite, executeWriteM) where
+module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf, BoundWrite, bindWrite, executeWriteM, validateTableRows) where
 
 import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM)
 import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
+import ChuSQL.Core.Engine.Domain
+import ChuSQL.Core.Engine.Runtime.Dependencies (domainDependencies, queryTables, typeDependencies, validateDependencies)
 import ChuSQL.Core.Engine.Runtime.Query (bindQuery, executeQueryM)
 import ChuSQL.Core.Engine.Runtime.Relation (bindWriteColumns, orderRow)
-import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, typeDependencies, validateDependencies)
 import ChuSQL.Core.Engine.Semantic (prepare, prepareCheckExpression)
 import ChuSQL.Core.Engine.Storage (MonadStorage (..))
 import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
 import ChuSQL.Core.Model
-import Data.HashSet qualified as HS
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Data.Maybe (mapMaybe)
 
 -- 引擎入口：检查语义、按语句分发执行，另有内存实现与泛型版本。
@@ -69,26 +70,27 @@ bindWrite :: Database -> Statement -> Either String BoundWrite
 bindWrite db statement = case statement of
     Select{} -> unsupported
     SelectDistinct{} -> unsupported
-    _ | null (queryTables statement) -> unsupported
-      | otherwise -> do
-        resolved <- prepare catalog statement >>= bindWriteColumns catalog
-        let sources = queryTables resolved
-        mapM_ (lookupTable catalog) sources
-        let names = sources ++ domainDependencies catalog sources ++ typeDependencies catalog (declaredTypes resolved)
-            dependencies = [(name, table) | (name, table) <- catalog, name `elem` names]
-        action <- bindWriteAction catalog resolved
-        Right (BoundWrite catalog dependencies action)
+    _
+        | null (queryTables statement) -> unsupported
+        | otherwise -> do
+            resolved <- prepare catalog statement >>= bindWriteColumns catalog
+            let sources = queryTables resolved
+            mapM_ (lookupTable catalog) sources
+            let names = sources ++ domainDependencies catalog sources ++ typeDependencies catalog (declaredTypes resolved)
+                dependencies = [(name, table) | (name, table) <- catalog, name `elem` names]
+            action <- bindWriteAction catalog resolved
+            Right (BoundWrite catalog dependencies action)
   where
     catalog = [(name, table{tableRows = []}) | (name, table) <- db]
     unsupported = Left "bound writes require an existing table target"
-    -- | 新声明类型也须保留领域依赖
+    -- \| 新声明类型也须保留领域依赖
     declaredTypes resolved = case resolved of
         AddColumn _ (_, column) -> [columnType column]
         AlterColumnType _ _ ty -> [ty]
         _ -> []
 
 -- | 复查结构后执行可复用的绑定写计划
-executeWriteM :: MonadStorage m => BoundWrite -> m (Either String [Row])
+executeWriteM :: (MonadStorage m) => BoundWrite -> m (Either String [Row])
 executeWriteM (BoundWrite catalog dependencies action) = do
     current <- schema
     case current >>= validateDependencies dependencies of
@@ -99,15 +101,24 @@ executeWriteM (BoundWrite catalog dependencies action) = do
 bindWriteAction :: Database -> Statement -> Either String WriteAction
 bindWriteAction catalog statement = case statement of
     Insert target columns rows -> do
-        table <- lookupTable catalog target
-        checks <- checkPlan table
-        let plan = InsertPlan (bindInsertTargets (tableCols table) columns) (length columns)
-                (autoColumn table) checks (constraintPlan (tableCols table))
+        declared <- lookupTable catalog target
+        columnsEffective <- effectiveColumns catalog (tableCols declared)
+        let table = declared{tableCols = columnsEffective}
+        checks <- checkPlan catalog table
+        let plan =
+                InsertPlan
+                    (bindInsertTargets (tableCols table) columns)
+                    (length columns)
+                    (autoColumn table)
+                    checks
+                    (constraintPlan (tableCols table))
         Right (InsertAction target plan rows)
     Update target assignments condition -> do
-        table <- lookupTable catalog target
+        declared <- lookupTable catalog target
+        columnsEffective <- effectiveColumns catalog (tableCols declared)
+        let table = declared{tableCols = columnsEffective}
         bound <- bindUpdateTargets (tableCols table) assignments
-        checks <- checkPlan table
+        checks <- checkPlan catalog table
         let plan = UpdatePlan (map fst (tableCols table)) bound condition checks (constraintPlan (tableCols table))
         Right (UpdateAction target plan)
     Delete target condition -> do
@@ -116,7 +127,7 @@ bindWriteAction catalog statement = case statement of
     _ -> Right (StructureAction statement)
 
 -- | 直接执行已绑定的数据修改或结构动作
-executeWriteActionM :: MonadStorage m => Database -> WriteAction -> m (Either String [Row])
+executeWriteActionM :: (MonadStorage m) => Database -> WriteAction -> m (Either String [Row])
 executeWriteActionM _ (InsertAction target plan rows) = do
     current <- existingRows target plan
     case current >>= \current' -> buildRows plan current' rows of
@@ -151,14 +162,14 @@ executeWriteActionM catalog (DeleteAction target columns condition) = do
                         result <- replaceAll target kept
                         pure (result >> Right [])
   where
-    -- | 取整数主键，否则使用原有整表删除路径
+    -- \| 取整数主键，否则使用原有整表删除路径
     rowId row = case lookup "id" row of
         Just (VInt key) -> Right key
         _ -> Left "row has no integer id"
 executeWriteActionM catalog (StructureAction statement) = runStatementUncheckedM catalog statement
 
 -- | 绑定并执行查询语句
-runQueryM :: MonadStorage m => Database -> Statement -> m (Either String [Row])
+runQueryM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
 runQueryM db q = case bindQuery db q of
     Left e -> pure (Left e)
     Right bound -> executeQueryM bound
@@ -170,11 +181,19 @@ runStatementUncheckedM db q@Select{} = runQueryM db q
 runStatementUncheckedM _ Insert{} = pure (Left "INSERT requires a bound write plan")
 runStatementUncheckedM _ Update{} = pure (Left "UPDATE requires a bound write plan")
 runStatementUncheckedM _ Delete{} = pure (Left "DELETE requires a bound write plan")
-runStatementUncheckedM _ (CreateTable name cols) = do
-    result <- createTable name cols
-    pure (result >> Right [])
-runStatementUncheckedM _ (CreateDomain name base) = do
-    result <- createTable (domainTableName name) [("base", plainColumn base)]
+runStatementUncheckedM db (CreateTable name cols) = case validateDomainDefaults db cols of
+    Left err -> pure (Left err)
+    Right () -> do
+        result <- guardDomainCreation db (map (columnType . snd) cols) (createTable name cols)
+        pure (result >> Right [])
+runStatementUncheckedM db (CreateDomain name definition) = case canonicalDomain db name definition of
+    Left err -> pure (Left err)
+    Right normalized -> do
+        let DomainDefinition column _ = normalized
+        result <- guardDomainCreation db [columnType column] (createTable (domainTableName name) (domainColumns normalized))
+        pure (result >> Right [])
+runStatementUncheckedM _ (AlterDomain name action) = do
+    result <- alterDomain (domainTableName name) (prepareDomainAlter name action)
     pure (result >> Right [])
 runStatementUncheckedM _ (DropDomain name) = do
     result <- dropTable (domainTableName name)
@@ -201,7 +220,7 @@ runStatementUncheckedM _ (DropColumn tbl col) = do
     result <- dropColumn tbl col
     pure (result >> Right [])
 runStatementUncheckedM db (AddColumn tbl def) =
-    alterTable db tbl (\table -> addColumnTo def (tableCols table) (tableRows table))
+    alterTable db tbl (\table -> addColumnTo db def (tableCols table) (tableRows table))
 runStatementUncheckedM db (RenameColumn tbl old new) =
     alterTable db tbl (\table -> renameColumnIn old new (tableCols table) (tableRows table))
 runStatementUncheckedM db (AlterColumnType tbl col ty) =
@@ -228,12 +247,22 @@ runStatementUncheckedM _ q@DropDatabase{} = runStatementM q
 runStatementUncheckedM _ q@UseDatabase{} = runStatementM q
 runStatementUncheckedM _ ShowDatabases = runStatementM ShowDatabases
 runStatementUncheckedM _ BeginTransaction = pure (Left "BEGIN is executed by the session")
+runStatementUncheckedM _ BeginSerializableTransaction = pure (Left "BEGIN is executed by the session")
 runStatementUncheckedM _ CommitTransaction = pure (Left "COMMIT is executed by the session")
 runStatementUncheckedM _ RollbackTransaction = pure (Left "ROLLBACK is executed by the session")
 runStatementUncheckedM _ Savepoint{} = pure (Left "SAVEPOINT is executed by the session")
 runStatementUncheckedM _ RollbackToSavepoint{} = pure (Left "ROLLBACK TO is executed by the session")
 runStatementUncheckedM _ ReleaseSavepoint{} = pure (Left "RELEASE is executed by the session")
 
+-- | 建表时在实际发布点复查领域定义
+guardDomainCreation :: (MonadStorage m) => Database -> [ColumnType] -> m (Either String a) -> m (Either String a)
+guardDomainCreation db types action
+    | null dependencies = action
+    | otherwise = withWriteSchemaGuard dependencies action
+  where
+    names = typeDependencies db types
+    dependencies = [(name, table) | (name, table) <- db, name `elem` names]
+
 -- | 只有需要读全表才能判断约束时才扫表
 existingRows :: (MonadStorage m) => String -> InsertPlan -> m (Either String [Row])
 existingRows tbl (InsertPlan _ _ auto _ (ConstraintPlan _ _ unique))
@@ -317,11 +346,14 @@ autoStart (Just (name, _)) rows = case [n | r <- rows, Just (VInt n) <- [lookup
     ns -> maximum ns + 1
 
 -- | 一次解析出来的 CHECK 条件
-data CheckPlan = CheckPlan [String] [(String, Expr)]
+data CheckPlan = CheckPlan [String] [(String, Expr)] [(String, Int, Expr)]
 
 -- | 按 schema 解析并绑定表上全部 CHECK
-checkPlan :: Table -> Either String CheckPlan
-checkPlan table = CheckPlan (map fst (tableCols table)) <$> mapM parse (mapMaybe checked (tableCols table))
+checkPlan :: Database -> Table -> Either String CheckPlan
+checkPlan db table = do
+    local <- mapM parse (mapMaybe checked (tableCols table))
+    domains <- domainCheckPlan db (tableCols table)
+    Right (CheckPlan (map fst (tableCols table)) local domains)
   where
     -- \| 只挑出带 CHECK 文本的列
     checked (name, col) = (,) name <$> columnCheck col
@@ -334,9 +366,10 @@ checkPlan table = CheckPlan (map fst (tableCols table)) <$> mapM parse (mapMaybe
 
 -- | 执行解析好的 CHECK 条件
 runChecks :: CheckPlan -> Row -> Either String ()
-runChecks (CheckPlan columns plan) row = do
+runChecks (CheckPlan columns plan domains) row = do
     ordered <- orderRow columns row
     mapM_ (check ordered) plan
+    runDomainChecks domains ordered
   where
     -- \| 跑一条 CHECK
     check ordered (name, e) = case evalCondForRow e ordered of
@@ -344,6 +377,16 @@ runChecks (CheckPlan columns plan) row = do
         Right True -> Right ()
         Right False -> Left ("CHECK on " ++ name ++ " failed")
 
+-- 校验最终行集的领域、检查与唯一约束。
+validateTableRows :: Database -> Table -> Either String ()
+validateTableRows db table = do
+    effective <- effectiveColumns db (tableCols table)
+    plan <- checkPlan db table
+    let rows = tableRows table
+    mapM_ (runChecks plan) rows
+    ordered <- mapM (orderRow (map fst effective)) rows
+    enforceConstraints (constraintPlan effective) [] ordered
+
 -- | 只取第一行（报错提示用）
 firstLine :: String -> String
 firstLine = takeWhile (/= '\n')
@@ -370,7 +413,7 @@ enforceConstraints (ConstraintPlan columns required unique) current rows = do
 enforceNotNull :: [(String, Expr)] -> [Row] -> Either String ()
 enforceNotNull targets rows = mapM_ check targets
   where
-    -- | 按 schema 槽位检查 NOT NULL
+    -- \| 按 schema 槽位检查 NOT NULL
     check (name, reference) = do
         values <- mapM (evalExpr reference) rows
         if VNull `elem` values
@@ -411,7 +454,7 @@ data BoundAssignment = BoundAssignment Int String Column Expr
 bindUpdateTargets :: [(String, Column)] -> [(String, Expr)] -> Either String [BoundAssignment]
 bindUpdateTargets columns = mapM bindTarget
   where
-    -- | 只接受唯一目标并保留列定义
+    -- \| 只接受唯一目标并保留列定义
     bindTarget (name, expression) = case [(slot, column) | (slot, (key, column)) <- zip [0 ..] columns, key == name] of
         [(slot, column)] -> Right (BoundAssignment slot name column expression)
         [] -> Left ("UPDATE: unknown target column: " ++ name)
@@ -429,9 +472,11 @@ applyUpdatesM db (assignment@(BoundAssignment _ _ _ e) : rest) row = do
 -- | 校验目标位置并只覆盖该槽位的值
 writeAssignment :: BoundAssignment -> Row -> Value -> Either String Row
 writeAssignment (BoundAssignment slot name column _) row value = case splitAt slot row of
-    (before, (key, _) : after) | slot >= 0, key == name -> do
-        coerced <- coerceValue (columnType column) value
-        Right (before ++ ((name, coerced) : after))
+    (before, (key, _) : after)
+        | slot >= 0
+        , key == name -> do
+            coerced <- coerceValue (columnType column) value
+            Right (before ++ ((name, coerced) : after))
     (_, []) -> Left ("missing bound column: " ++ name)
     _ -> Left ("bound column position mismatch: " ++ name)
 
@@ -471,20 +516,23 @@ alterTable db tbl change = case lookupTable db tbl of
     -- \| 改完再统一查一遍约束
     checkAltered (cols, rows) = do
         let table = Table tbl cols rows Nothing Nothing Nothing
-        plan <- checkPlan table
-        mapM_ (runChecks plan) rows
-        enforceConstraints (constraintPlan cols) [] rows
+        validateDomainDefaults db cols
+        validateTableRows db table
         Right (cols, rows)
 
 -- | ADD COLUMN：老行补默认值或 NULL
-addColumnTo :: (String, Column) -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
-addColumnTo (name, col) cols rows
+addColumnTo :: Database -> (String, Column) -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
+addColumnTo db (name, declared) cols rows
     | name `elem` map fst cols = Left ("ADD COLUMN: column already exists: " ++ name)
     | otherwise = do
-        values <- fill
-        Right (cols ++ [(name, col)], [r ++ [(name, v)] | (r, v) <- zip rows values])
+        effective <- effectiveColumns db [(name, declared)]
+        values <- case effective of
+            [(_, column)] -> fill column
+            _ -> Left "invalid added column layout"
+        Right (cols ++ [(name, declared)], [r ++ [(name, v)] | (r, v) <- zip rows values])
   where
-    fill
+    -- \| 使用领域继承属性填充已有行
+    fill col
         | columnAutoIncrement col = mapM (coerceValue (columnType col) . VInt) [1 .. length rows]
         | Just d <- columnDefault col = mapM (\_ -> coerceValue (columnType col) d) rows
         | columnNullable col = mapM (\_ -> coerceValue (columnType col) VNull) rows

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Cost.hs

@@ -1,7 +1,7 @@
 module ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf, probeCost, pointRows, rangeRows, selectivityOf, indexCheaper) where
 
-import Data.Maybe (fromMaybe)
 import ChuSQL.Core.Model
+import Data.Maybe (fromMaybe)
 
 -- 统计与成本估算：行数、不同值数、列直方图与索引探路页数。
 
@@ -33,9 +33,9 @@ estimateRows h lo hi = max 0 (min total (round (sum (zipWith overlap [0 ..] (his
   where
     total = sum (histBuckets h)
     width = if histHigh h > histLow h then (histHigh h - histLow h) / fromIntegral (length (histBuckets h)) else 0
-    lower = fromMaybe (- (1 / 0)) (boundOf lo)
+    lower = fromMaybe (-(1 / 0)) (boundOf lo)
     upper = fromMaybe (1 / 0) (boundOf hi)
-    -- | 第 i 个桶与区间重叠的行数
+    -- \| 第 i 个桶与区间重叠的行数
     overlap :: Int -> Int -> Double
     overlap i count
         | width <= 0 = if lower <= histLow h && histLow h <= upper then fromIntegral count else 0

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Eval.hs

@@ -1,24 +1,26 @@
 {-# LANGUAGE TupleSections #-}
+
 module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
 
 import ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf)
-import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr, hasSubquery, quantifiedCompare, subquerySlotsIn, subqueryColumns)
-import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
+import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr, hasSubquery, quantifiedCompare, subqueryColumns, subquerySlotsIn)
 import ChuSQL.Core.Engine.Algebra.Op
+import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
 import ChuSQL.Core.Engine.Algebra.Planner (translate)
-import ChuSQL.Core.Engine.Algebra.Sort (sortRows, sortBoundRows)
+import ChuSQL.Core.Engine.Algebra.Sort (sortBoundRows, sortRows)
+import ChuSQL.Core.Engine.Builtin (aggregateArg, builtinOfExpr, inValues, invokeBuiltin, unsupportedAggregate)
 import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns, orderRow)
-import ChuSQL.Core.Engine.Builtin (aggregateArg, builtinOfExpr, invokeBuiltin, unsupportedAggregate, inValues)
-import ChuSQL.Core.Model
 import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
 import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
 import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
+import ChuSQL.Core.Model
 import Control.Monad (filterM)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Strict (StateT, evalStateT, gets, modify')
+import Data.Bifunctor (first)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Data.List (nub)
-import qualified Data.HashMap.Strict as HM
-import qualified Data.HashSet as HS
 
 -- 执行：按算子树算出结果行，外层行供相关子查询引用。
 
@@ -26,7 +28,7 @@ import qualified Data.HashSet as HS
 type Execution m a = StateT (HM.HashMap String [Row]) m a
 
 -- | 首次使用时执行，成功结果供后续引用复用
-materialize :: Monad m => String -> Execution m (Either String [Row]) -> Execution m (Either String [Row])
+materialize :: (Monad m) => String -> Execution m (Either String [Row]) -> Execution m (Either String [Row])
 materialize key action = do
     cached <- gets (HM.lookup key)
     case cached of
@@ -46,7 +48,7 @@ project cs row = [(c, v) | c <- cs, Just v <- [lookup c row]]
 
 -- | 给列名加别名前缀
 addPrefix :: Maybe String -> Row -> Row
-addPrefix mAlias = map (\(k, v) -> (qualify mAlias k, v))
+addPrefix mAlias = map (first (qualify mAlias))
 
 -- | 给一批行加别名前缀
 prefixRows :: Maybe String -> [Row] -> [Row]
@@ -74,7 +76,7 @@ rangeCondition mAlias col lo hi = case (lo, hi) of
     (Nothing, Nothing) -> LitBool True
   where
     c = Col (qualify mAlias col)
-    -- | 一个端点的比较，闭端再加上等号
+    -- \| 一个端点的比较，闭端再加上等号
     bound rel (v, inclusive)
         | inclusive = Or (rel c (valueLiteral v)) (Eq c (valueLiteral v))
         | otherwise = rel c (valueLiteral v)
@@ -102,10 +104,18 @@ data EquiKeys = EquiKeys
 -- | 认出 a = b 这种两列等值条件，并且能分清谁在左谁在右
 equiKeys :: [String] -> [String] -> Expr -> Maybe EquiKeys
 equiKeys lcols rcols (Eq left right)
-    | Just a <- columnName left, Just b <- columnName right
-    , a /= b, a `elem` lcols, b `elem` rcols = Just (EquiKeys a b)
-    | Just a <- columnName left, Just b <- columnName right
-    , a /= b, b `elem` lcols, a `elem` rcols = Just (EquiKeys b a)
+    | Just a <- columnName left
+    , Just b <- columnName right
+    , a /= b
+    , a `elem` lcols
+    , b `elem` rcols =
+        Just (EquiKeys a b)
+    | Just a <- columnName left
+    , Just b <- columnName right
+    , a /= b
+    , b `elem` lcols
+    , a `elem` rcols =
+        Just (EquiKeys b a)
 equiKeys _ _ _ = Nothing
 
 -- | 提取执行列的诊断名称
@@ -144,26 +154,32 @@ semiRows kind left right outer leftRows rightRows = do
     let keys = HS.fromList [canonicalValue value | value <- values, value /= VNull]
         hasNull = VNull `elem` values
         hashSafe = all safeNumber values
-        -- | NULL 与数值边界沿用表达式比较规则
+        -- \| NULL 与数值边界沿用表达式比较规则
         keep row = do
             value <- evalExpr left (row ++ outer)
             if value == VNull
                 then Right (kind == NonMatching || kind == NotIn && null values)
-                else if hashSafe && safeNumber value
-                    then let found = HS.member (canonicalValue value) keys
-                         in Right (case kind of
-                             Matching -> found
-                             NonMatching -> not found
-                             NotIn -> not found && not hasNull)
-                    else do
-                        result <- inValues value values
-                        Right (case kind of
-                            Matching -> result == VBool True
-                            NonMatching -> result /= VBool True
-                            NotIn -> result == VBool False)
+                else
+                    if hashSafe && safeNumber value
+                        then
+                            let found = HS.member (canonicalValue value) keys
+                             in Right
+                                    ( case kind of
+                                        Matching -> found
+                                        NonMatching -> not found
+                                        NotIn -> not found && not hasNull
+                                    )
+                        else do
+                            result <- inValues value values
+                            Right
+                                ( case kind of
+                                    Matching -> result == VBool True
+                                    NonMatching -> result /= VBool True
+                                    NotIn -> result == VBool False
+                                )
     filterM keep leftRows
   where
-    -- | 大数混合比较退回既有逐值语义
+    -- \| 大数混合比较退回既有逐值语义
     safeNumber (VInt value) = abs (toInteger value) <= 9007199254740992
     safeNumber (VFloat value) = abs value <= 9007199254740992
     safeNumber _ = True
@@ -178,7 +194,7 @@ hashJoin :: JoinKind -> EquiKeys -> [String] -> [Row] -> [Row] -> [Row]
 hashJoin kind ks ncols lrows rrows = concatMap probe lrows
   where
     buckets = HM.fromListWith (flip (++)) [(v, [r]) | r <- rrows, Just v <- [joinKeyOf (ekRight ks) r]]
-    -- | 拿左行的键去桶里找
+    -- \| 拿左行的键去桶里找
     probe l =
         let miss = case kind of
                 InnerJoin -> []
@@ -204,7 +220,7 @@ filterPairsM ::
 filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
   where
     refs = subquerySlotsIn cond
-    -- | 逐左行配对，左连接没配上就补 NULL
+    -- \| 逐左行配对，左连接没配上就补 NULL
     go [] acc _ = pure (Right (reverse acc))
     go (l : ls) acc cache = do
         hits <- keep l rrows [] cache
@@ -215,7 +231,7 @@ filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
                         (LeftJoin, []) -> [l ++ nullRow]
                         _ -> hs
                 go ls (reverse hs' ++ acc) nextCache
-    -- | 拿一行右行去比条件
+    -- \| 拿一行右行去比条件
     keep _ [] acc cache = pure (Right (reverse acc, cache))
     keep l (r : rs) acc cache = do
         let env = l ++ r ++ outer
@@ -259,13 +275,18 @@ probeIndexJoin db outer kind mAlias t ks rcols cond l = case lookup (ekLeft ks)
                         Left err -> pure (Left err)
                         Right ordered -> fmap (fmap Just) (joinRowsIn db outer kind rcols cond [l] ordered)
 
--- | 列与键都不是浮点时才敢用索引
+-- | 仅用已支持且无浮点歧义的索引键
 indexSafe :: Database -> String -> String -> Value -> Bool
 indexSafe db t col k = case lookupTable db t of
     Left _ -> False
     Right tbl -> case lookup col (tableCols tbl) of
         Nothing -> False
-        Just c -> not (floatType (columnType c)) && not (floatValue k)
+        Just c -> scalarKey k && not (floatType (columnType c)) && not (floatValue k)
+  where
+    -- \| 只有已实现编码的键可以点查
+    scalarKey VInt{} = True
+    scalarKey VStr{} = True
+    scalarKey _ = False
 
 -- | 是不是浮点列类型
 floatType :: ColumnType -> Bool
@@ -288,7 +309,7 @@ groupKey outer keys row = mapM (\key -> evalExpr key (row ++ outer)) keys
 groupRows :: Row -> [Expr] -> [Row] -> Either String [([Value], [Row])]
 groupRows outer keys rows = go rows (HM.empty, [])
   where
-    -- | 逐行塞进对应分组，并记住分组首次出现的顺序
+    -- \| 逐行塞进对应分组，并记住分组首次出现的顺序
     go [] (acc, order) = Right [(k, reverse (HM.lookupDefault [] k acc)) | k <- reverse order]
     go (r : rs) (acc, order) = do
         k <- groupKey outer keys r
@@ -342,7 +363,7 @@ bindingValue column env = case lookup column env of
 bindingSamples :: [Expr] -> Row -> [Row] -> Either String [(String, Row)]
 bindingSamples refs outer rows = go rows HM.empty []
   where
-    -- | 逐行按绑定键去重
+    -- \| 逐行按绑定键去重
     go [] _ acc = Right (reverse acc)
     go (r : rs) seen acc = do
         let env = r ++ outer
@@ -366,7 +387,7 @@ bindingsTableM db outer exprs rows = case bindingSamples refs outer rows of
         pure (fmap HM.fromList (sequence built))
   where
     refs = nub (concatMap subquerySlotsIn exprs)
-    -- | 一个绑定样本上把子查询全换成字面量
+    -- \| 一个绑定样本上把子查询全换成字面量
     swap (key, env) = do
         es <- mapM (\e -> substSubqueries db e env) exprs
         pure (fmap (key,) (sequence es))
@@ -391,7 +412,7 @@ boundExpr refs env table = do
 filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row])
 filterRowsM p = go []
   where
-    -- | 逐行留下通过条件的
+    -- \| 逐行留下通过条件的
     go acc [] = pure (Right (reverse acc))
     go acc (r : rs) = do
         keep <- p r
@@ -404,7 +425,7 @@ filterRowsM p = go []
 computeM :: (MonadStorage m) => Database -> Row -> [(String, Expr)] -> Row -> Execution m (Either String Row)
 computeM db outer items row = go items []
   where
-    -- | 逐项求值并攒成一行
+    -- \| 逐项求值并攒成一行
     go [] acc = pure (Right (reverse acc))
     go ((label, e) : rest) acc = do
         v <- evalExprIn db e (row ++ outer)
@@ -417,7 +438,7 @@ evalExprM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Val
 evalExprM db e env = evalStateT (evalExprIn db e env) HM.empty
 
 -- | 在当前执行中求值并共享子查询物化
-evalExprIn :: MonadStorage m => Database -> Expr -> Row -> Execution m (Either String Value)
+evalExprIn :: (MonadStorage m) => Database -> Expr -> Row -> Execution m (Either String Value)
 evalExprIn db e env = do
     e' <- substSubqueries db e env
     pure (e' >>= \x -> evalExpr x env)
@@ -427,7 +448,7 @@ evalCondForRowM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either Stri
 evalCondForRowM db e env = evalStateT (evalCondIn db e env) HM.empty
 
 -- | 在当前执行中判定条件并共享物化
-evalCondIn :: MonadStorage m => Database -> Expr -> Row -> Execution m (Either String Bool)
+evalCondIn :: (MonadStorage m) => Database -> Expr -> Row -> Execution m (Either String Bool)
 evalCondIn db e env = do
     e' <- substSubqueries db e env
     pure (e' >>= \x -> evalCondForRow x env)
@@ -465,29 +486,35 @@ substSubqueries db e env = case e of
     InSub a sq negated -> do
         lhs <- substSubqueries db a env
         rows <- runSubqueryRows db sq env
-        pure (do
-            a' <- lhs
-            rs <- rows
-            vs <- mapM rowValue rs
-            Right (InList a' (map valueLiteral vs) negated))
+        pure
+            ( do
+                a' <- lhs
+                rs <- rows
+                vs <- mapM rowValue rs
+                Right (InList a' (map valueLiteral vs) negated)
+            )
     ExistsSub sq negated -> do
         rows <- runSubqueryRows db sq env
         pure (fmap (\rs -> LitBool (if negated then null rs else not (null rs))) rows)
     QuantCmp op a sq q -> do
         lhs <- substSubqueries db a env
         rows <- runSubqueryRows db sq env
-        pure (do
-            a' <- lhs
-            rs <- rows
-            vs <- mapM rowValue rs
-            Right (quantifiedCompare op a' (map valueLiteral vs) q))
+        pure
+            ( do
+                a' <- lhs
+                rs <- rows
+                vs <- mapM rowValue rs
+                Right (quantifiedCompare op a' (map valueLiteral vs) q)
+            )
     InList a es negated -> do
         lhs <- substSubqueries db a env
         es' <- mapM (\x -> substSubqueries db x env) es
-        pure (do
-            a' <- lhs
-            items <- sequence es'
-            Right (InList a' items negated))
+        pure
+            ( do
+                a' <- lhs
+                items <- sequence es'
+                Right (InList a' items negated)
+            )
     Add a b -> bin Add a b
     Sub a b -> bin Sub a b
     Mul a b -> bin Mul a b
@@ -510,7 +537,7 @@ substSubqueries db e env = case e of
     MaxOf a -> un MaxOf a
     _ -> pure (Right e)
   where
-    -- | 递归处理两个子表达式
+    -- \| 递归处理两个子表达式
     bin ctor a b = do
         ra <- substSubqueries db a env
         case ra of
@@ -518,7 +545,7 @@ substSubqueries db e env = case e of
             Right a' -> do
                 rb <- substSubqueries db b env
                 pure (ctor a' <$> rb)
-    -- | 递归处理一个子表达式
+    -- \| 递归处理一个子表达式
     un ctor a = do
         ra <- substSubqueries db a env
         pure (ctor <$> ra)
@@ -531,14 +558,16 @@ runSubqueryRows db sq outer = case translate (subqueryStatement sq) of
         Left err -> pure (Left err)
         Right bindings -> case bindRelOpColumns db (map fst (bindings ++ outer)) (optimize db op) of
             Left err -> pure (Left err)
-            Right bound -> materialize (show ("subquery", subqueryStatement sq, bindings, fallback))
-                (evalRelOpIn db (bindings ++ outer) bound)
+            Right bound ->
+                materialize
+                    (show ("subquery", subqueryStatement sq, bindings, fallback))
+                    (evalRelOpIn db (bindings ++ outer) bound)
   where
-    -- | 原始调用未证明依赖完整，保留整个外层行
+    -- \| 原始调用未证明依赖完整，保留整个外层行
     fallback = case sq of
         Subquery{} -> Just outer
         BoundSubquery{} -> Nothing
-    -- | 给外层物理列补回已解析的限定名
+    -- \| 给外层物理列补回已解析的限定名
     bind (column, expression) = (,) column <$> bindingReferenceValue expression outer
 
 -- | 单子求值：Scan/点查/范围查都问存储
@@ -567,7 +596,7 @@ evalRelOpIn db outer (Compute items op) = do
                 pure (table >>= \t -> traverse (computeBound t) rs)
   where
     refs = nub (concatMap (subquerySlotsIn . snd) items)
-    -- | 用这一行绑定换好的表达式算出一行
+    -- \| 用这一行绑定换好的表达式算出一行
     computeBound table r = do
         es <- boundExprs refs (r ++ outer) table
         mapM (\(label, e) -> (,) label <$> evalExpr e (r ++ outer)) (zip (map fst items) es)
@@ -603,7 +632,7 @@ evalRelOpIn db outer (Filter e op) = do
                 pure (table >>= \t -> filterM (keepBound t) rs)
   where
     refs = nub (subquerySlotsIn e)
-    -- | 用这一行绑定换好的条件判定
+    -- \| 用这一行绑定换好的条件判定
     keepBound table r = do
         e' <- boundExpr refs (r ++ outer) table
         evalCondForRow e' (r ++ outer)
@@ -631,7 +660,7 @@ evalRelOpIn db outer (SemiJoin kind left right l r query) = do
         Left err -> pure (Left err)
         Right [] -> pure (Right [])
         Right leftRows -> do
-            -- | 独立 IN 沿用子查询身份，跨算子复用结果
+            -- \| 独立 IN 沿用子查询身份，跨算子复用结果
             let key = case query of
                     Just statement -> show ("subquery", statement, [] :: Row, Nothing :: Maybe Row)
                     Nothing -> show ("derived", r, outer)
@@ -684,14 +713,14 @@ scanTable db tbl cols = do
         then lift (scanShards width tbl cols)
         else lift (maybe (scan tbl) (scanColumns tbl) cols)
   where
-    -- | 统计里的行数，没有统计算 0
+    -- \| 统计里的行数，没有统计算 0
     rows = maybe 0 metaRowCount (tableMetaOf db tbl)
 
 -- | 按输出值去重并保留首次行序
 distinctRows :: [Row] -> [Row]
 distinctRows = go HS.empty
   where
-    -- | 只输出尚未遇到的值组合
+    -- \| 只输出尚未遇到的值组合
     go _ [] = []
     go seen (row : rows)
         | HS.member key seen = go seen rows

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Expr.hs

@@ -1,9 +1,9 @@
 module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, subqueryRefsIn, subquerySlotsIn, subqueryColumns, aggregatesIn, hasAggregate, bareColumns, hasSubquery, hasDivision, inValues, threeValuedNot, quantifiedCompare) where
 
-import ChuSQL.Core.Model
-import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Builtin (Operator (..), compareNode, executeOperator, inValues, threeValuedNot)
-import ChuSQL.Core.Engine.Runtime.SQL (invokeSQLFunction, constructSQLValue)
+import ChuSQL.Core.Engine.Runtime.SQL (constructSQLValue, invokeSQLFunction)
+import ChuSQL.Core.Engine.Syntax.AST
+import ChuSQL.Core.Model
 
 -- 表达式求值：三值逻辑，NULL 参与运算结果仍是 NULL。
 
@@ -59,9 +59,9 @@ evalExpr (InList a es negated) row = do
     r <- inValues v vs
     Right (if negated then threeValuedNot r else r)
 evalExpr (ScalarSub _) _ = Left subqueryNeedsDatabase
-evalExpr (InSub {}) _ = Left subqueryNeedsDatabase
+evalExpr (InSub{}) _ = Left subqueryNeedsDatabase
 evalExpr (ExistsSub _ _) _ = Left subqueryNeedsDatabase
-evalExpr (QuantCmp {}) _ = Left subqueryNeedsDatabase
+evalExpr (QuantCmp{}) _ = Left subqueryNeedsDatabase
 evalExpr agg _ = Left ("aggregate functions are not allowed here: " ++ show agg)
 
 -- | 子查询要连上存储才能跑
@@ -157,9 +157,9 @@ subqueryReferences references e = case e of
     MaxOf a -> collect a
     _ -> []
   where
-    -- | 递归收集当前提取器的引用
+    -- \| 递归收集当前提取器的引用
     collect = subqueryReferences references
-    -- | 两个子表达式的外层列拼起来
+    -- \| 两个子表达式的外层列拼起来
     both a b = collect a ++ collect b
 
 -- | 表达式里有没有除法（除法可能报错，不能提前或延后求值）
@@ -185,7 +185,7 @@ hasDivision e = case e of
     QuantCmp _ a _ _ -> hasDivision a
     _ -> False
   where
-    -- | 两个子表达式里任意一个有除法
+    -- \| 两个子表达式里任意一个有除法
     both a b = hasDivision a || hasDivision b
 
 -- | 表达式里有没有子查询
@@ -196,10 +196,10 @@ hasSubquery e = case e of
     FunctionCall _ arguments -> any hasSubquery arguments
     BoundFunction _ _ arguments -> any hasSubquery arguments
     ScalarSub _ -> True
-    InSub {} -> True
+    InSub{} -> True
     InList a es _ -> any hasSubquery (a : es)
     ExistsSub _ _ -> True
-    QuantCmp {} -> True
+    QuantCmp{} -> True
     Add a b -> both a b
     Sub a b -> both a b
     Mul a b -> both a b
@@ -222,7 +222,7 @@ hasSubquery e = case e of
     MaxOf a -> hasSubquery a
     _ -> False
   where
-    -- | 两个子表达式里任意一个有
+    -- \| 两个子表达式里任意一个有
     both a b = hasSubquery a || hasSubquery b
 
 -- | 表达式里出现的聚合调用（按出现顺序）
@@ -258,7 +258,7 @@ aggregatesIn e = case e of
     IsNotNull a -> aggregatesIn a
     _ -> []
   where
-    -- | 两个子表达式的聚合拼起来
+    -- \| 两个子表达式的聚合拼起来
     both a b = aggregatesIn a ++ aggregatesIn b
 
 -- | 表达式里有没有聚合调用
@@ -297,7 +297,7 @@ bareColumns e = case e of
     QuantCmp _ a sq _ -> bareColumns a ++ subqueryRefs sq
     _ -> []
   where
-    -- | 两个子表达式的裸列拼起来
+    -- \| 两个子表达式的裸列拼起来
     both a b = bareColumns a ++ bareColumns b
 
 -- | 判断条件真假：只有 TRUE 通过，NULL 当作不通过

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/JoinOrder.hs

@@ -1,12 +1,12 @@
 module ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins) where
 
-import Data.Maybe (fromMaybe)
 import ChuSQL.Core.Engine.Algebra.Cost (pointRows, rangeRows, selectivityOf, tableMetaOf)
 import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision, hasSubquery)
 import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols)
 import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..))
 import ChuSQL.Core.Model
 import Data.List (partition)
+import Data.Maybe (fromMaybe)
 
 -- 内连接链顺序优化：按统计估算中间结果，只在行序不可观察处重排。
 
@@ -40,7 +40,7 @@ innerChain (Join InnerJoin l r c) = do
     (ls, lcs) <- innerChain l
     (rs, rcs) <- innerChain r
     pure (ls ++ rs, lcs ++ rcs ++ [c])
-innerChain (Join {}) = Nothing
+innerChain (Join{}) = Nothing
 innerChain op = Just ([op], [])
 
 -- | 叶子算子的估算行数，拿不到统计就是 Nothing
@@ -81,7 +81,7 @@ scaleRows db p x rows = case p of
     GtE _ _ -> quarter
     LtE _ _ -> quarter
     NotEq _ _ -> quarter
-    QuantCmp {} -> quarter
+    QuantCmp{} -> quarter
     And a b -> max 1 (min (scaleRows db a x rows) (scaleRows db b x rows))
     _ -> quarter
   where
@@ -89,7 +89,8 @@ scaleRows db p x rows = case p of
     pick k lo hi = case leafSource x of
         Just (alias, t)
             | Just m <- tableMetaOf db t
-            , Just s <- selectivityOf m (unqualify alias k) lo hi -> max 1 (round (fromIntegral rows * s))
+            , Just s <- selectivityOf m (unqualify alias k) lo hi ->
+                max 1 (round (fromIntegral rows * s))
         _ -> quarter
 
 -- | 叶子对应的别名与表名
@@ -103,9 +104,10 @@ leafSource _ = Nothing
 
 -- | 某列在叶子统计里的不同值数
 distinctOf :: Database -> RelOp -> String -> Maybe Int
-distinctOf db leaf col = do (alias, t) <- leafSource leaf
-                            m <- tableMetaOf db t
-                            lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
+distinctOf db leaf col = do
+    (alias, t) <- leafSource leaf
+    m <- tableMetaOf db t
+    lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
 
 -- | 若干叶子里某列最大的不同值数
 distinctOn :: Database -> [RelOp] -> String -> Maybe Int
@@ -121,12 +123,12 @@ keyDistinct db have x conds = case [v | Eq (Col a) (Col b) <- conds, Just v <- [
   where
     haveCols = concatMap (relOpCols db) have
     xCols = relOpCols db x
-    -- | 这一对列是不是两侧之间的等值键
+    -- \| 这一对列是不是两侧之间的等值键
     pair a b
         | a `elem` haveCols, b `elem` xCols = bigger (distinctOn db have a) (distinctOf db x b)
         | b `elem` haveCols, a `elem` xCols = bigger (distinctOn db have b) (distinctOf db x a)
         | otherwise = Nothing
-    -- | 两个可选统计取大的那个
+    -- \| 两个可选统计取大的那个
     bigger (Just a) (Just b) = Just (max a b)
     bigger (Just a) Nothing = Just a
     bigger Nothing (Just b) = Just b
@@ -144,7 +146,7 @@ stepRows db have acc x conds = case keyDistinct db have x conds of
 chainCost :: Database -> [RelOp] -> [Expr] -> Int
 chainCost db (l : ls) conds = go [l] (fromMaybe 1 (leafRows db l)) ls
   where
-    -- | 逐步接上后面的叶子
+    -- \| 逐步接上后面的叶子
     go _ _ [] = 0
     go have acc (x : xs) =
         let card = stepRows db have acc x conds
@@ -159,11 +161,11 @@ growOrder db leaves conds have rest = case rest of
         let next = pick rest
          in growOrder db leaves conds (have ++ [next]) (filter (/= next) rest)
   where
-    -- | 候选里成本最低的那个，同价取序号小的
+    -- \| 候选里成本最低的那个，同价取序号小的
     pick (i : is) = foldl cheaper i is
     pick [] = 0
     cheaper i j = if costOf j < costOf i then j else i
-    -- | 这个前缀的估算成本
+    -- \| 这个前缀的估算成本
     costOf i = chainCost db [leaves !! k | k <- have ++ [i]] conds
 
 -- | 每个起点贪心一遍，取最便宜的顺序
@@ -171,13 +173,13 @@ bestOrder :: Database -> [RelOp] -> [Expr] -> [RelOp]
 bestOrder db leaves conds = pick (map start [0 .. n - 1])
   where
     n = length leaves
-    -- | 从第 i 张表开始的贪心顺序
+    -- \| 从第 i 张表开始的贪心顺序
     start i = [leaves !! k | k <- growOrder db leaves conds [i] (filter (/= i) [0 .. n - 1])]
-    -- | 成本最低的那个
+    -- \| 成本最低的那个
     pick (o : os) = foldl cheaper o os
     pick [] = []
     cheaper o o' = if cost o' < cost o then o' else o
-    -- | 一个顺序的估算成本
+    -- \| 一个顺序的估算成本
     cost o = chainCost db o conds
 
 -- | 统计齐全、没有除法且确实更省时给出新顺序
@@ -188,7 +190,7 @@ cheaperOrder db leaves conds
     | bestCost < textCost = Just best
     | otherwise = Nothing
   where
-    -- | 这个叶子是不是拿不到统计
+    -- \| 这个叶子是不是拿不到统计
     unknown x = case leafRows db x of
         Just _ -> False
         Nothing -> True
@@ -200,13 +202,13 @@ cheaperOrder db leaves conds
 rebuildChain :: Database -> [RelOp] -> [Expr] -> RelOp
 rebuildChain db (l : ls) conds = go (relOpCols db l) l ls conds
   where
-    -- | 逐个接上后面的叶子
+    -- \| 逐个接上后面的叶子
     go _ acc [] rest = applyConds rest acc
     go have acc (x : xs) rest =
         let have' = have ++ relOpCols db x
             (now, later) = partition (\c -> colsInExpr c `subsetOf` have') rest
          in go have' (Join InnerJoin acc x (conjOf now)) xs later
-    -- | 若干条件用 AND 串起来
+    -- \| 若干条件用 AND 串起来
     conjOf [] = LitBool True
     conjOf (c : cs) = foldl And c cs
 rebuildChain _ [] _ = Unit

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Op.hs

@@ -1,7 +1,7 @@
 module ChuSQL.Core.Engine.Algebra.Op (RelOp (..), SemiKind (..), relOpCols, renderPlan) where
 
+import ChuSQL.Core.Engine.Syntax.AST (Expr, JoinKind (..), SortDir, Statement)
 import ChuSQL.Core.Model
-import ChuSQL.Core.Engine.Syntax.AST (Expr, Statement, JoinKind (..), SortDir)
 
 -- 关系代数算子定义、输出列推导与算子树文本渲染。
 
@@ -23,8 +23,8 @@ data RelOp
     | BoundSort [(Expr, SortDir)] RelOp
     | Limit Int RelOp
     | Join JoinKind RelOp RelOp Expr
-    -- | 末项仅保存独立 IN 的物化身份
-    | SemiJoin SemiKind Expr Expr RelOp RelOp (Maybe Statement)
+    | -- | 末项仅保存独立 IN 的物化身份
+      SemiJoin SemiKind Expr Expr RelOp RelOp (Maybe Statement)
     | Derived (Maybe String) RelOp
     deriving (Show, Eq)
 
@@ -63,7 +63,7 @@ kindLabel LeftJoin = "LeftJoin"
 renderPlan :: RelOp -> String
 renderPlan = go 0
   where
-    -- | 按缩进渲染一个算子
+    -- \| 按缩进渲染一个算子
     go ind op = case op of
         Scan a t cols -> pad ++ "Scan " ++ show a ++ " " ++ show t ++ maybe "" ((" columns=" ++) . show) cols
         Lookup _ t c k -> pad ++ "Lookup " ++ show t ++ "." ++ show c ++ " = " ++ show k
@@ -80,15 +80,29 @@ renderPlan = go 0
                 ++ "\n"
                 ++ go (ind + 1) x
         Distinct x -> pad ++ "Distinct\n" ++ go (ind + 1) x
-        BoundAggregate keys aggs x -> pad ++ "BoundAggregate keys=" ++ show keys
-            ++ " aggs=" ++ show aggs ++ "\n" ++ go (ind + 1) x
+        BoundAggregate keys aggs x ->
+            pad
+                ++ "BoundAggregate keys="
+                ++ show keys
+                ++ " aggs="
+                ++ show aggs
+                ++ "\n"
+                ++ go (ind + 1) x
         Unit -> pad ++ "Unit"
         Sort s x -> pad ++ "Sort " ++ show s ++ "\n" ++ go (ind + 1) x
         BoundSort s x -> pad ++ "BoundSort " ++ show s ++ "\n" ++ go (ind + 1) x
         Limit n x -> pad ++ "Limit " ++ show n ++ "\n" ++ go (ind + 1) x
         Join k l r c -> pad ++ kindLabel k ++ " on " ++ show c ++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
-        SemiJoin k left right l r _ -> pad ++ "SemiJoin " ++ show k ++ " keys=" ++ show (left, right)
-            ++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
+        SemiJoin k left right l r _ ->
+            pad
+                ++ "SemiJoin "
+                ++ show k
+                ++ " keys="
+                ++ show (left, right)
+                ++ "\n"
+                ++ go (ind + 1) l
+                ++ "\n"
+                ++ go (ind + 1) r
         Derived a x -> pad ++ "Derived " ++ show a ++ "\n" ++ go (ind + 1) x
       where
         pad = replicate (ind * 2) ' '

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Optimize.hs

@@ -5,8 +5,8 @@ import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr, hasDivision)
 import ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins)
 import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), SemiKind (..), relOpCols)
 import ChuSQL.Core.Engine.Algebra.Planner (translate)
+import ChuSQL.Core.Engine.Syntax.AST (Expr (..), FromClause (..), JoinKind (..), Statement (..), Subquery (..))
 import ChuSQL.Core.Model
-import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Statement (..), FromClause (..), Subquery (..))
 import Data.List (nub)
 
 -- 查询优化：谓词下推、投影下推、常量折叠、扫描方式与连接顺序选择。
@@ -30,7 +30,7 @@ combineConj (e : es) = Just (foldl And e es)
 partitionPred :: [String] -> [Expr] -> ([Expr], [Expr])
 partitionPred have = foldr pick ([], [])
   where
-    -- | 按列归属收到左边或右边
+    -- \| 按列归属收到左边或右边
     pick e (yes, no)
         | colsInExpr e `isSubsetOf` have = (e : yes, no)
         | otherwise = (yes, e : no)
@@ -111,8 +111,13 @@ pushProject db _ (Distinct x) = Distinct (pushProject db (relOpCols db x) x)
 pushProject db need (Sort spec x) = Sort spec (pushProject db (need ++ map fst spec) x)
 pushProject db need (Limit n x) = Limit n (pushProject db need x)
 pushProject db need (SemiJoin kind left right l r query) =
-    SemiJoin kind left right (pushProject db (need ++ colsInExpr left) l)
-        (pushProject db (colsInExpr right) r) query
+    SemiJoin
+        kind
+        left
+        right
+        (pushProject db (need ++ colsInExpr left) l)
+        (pushProject db (colsInExpr right) r)
+        query
 pushProject db need (Join kind l r c)
     | needsAll need = Join kind (pushProject db need l) (pushProject db need r) c
     | otherwise =
@@ -128,15 +133,15 @@ pushProject db need leaf@(Scan a t _)
     | otherwise = Scan a t (Just (nub [column | requested <- need, let column = physicalColumn requested, column `elem` available]))
   where
     available = map (unqualify a) (relOpCols db (Scan a t Nothing))
-    -- | 把扫描限定列换成存储物理列名
+    -- \| 把扫描限定列换成存储物理列名
     physicalColumn column = unqualify (Just (deriveQualifier a t)) (unqualify a column)
 pushProject db need (Derived a x)
     | needsAll need || all (`elem` wanted) (relOpCols db x) = Derived a (pushProject db ["*"] x)
     | otherwise = Derived a (Project wanted (pushProject db wanted x))
   where
     wanted = nub (map (unqualify a) need)
-pushProject db need leaf@(Lookup {}) = pushProjectLeaf db need leaf
-pushProject db need leaf@(Range {}) = pushProjectLeaf db need leaf
+pushProject db need leaf@(Lookup{}) = pushProjectLeaf db need leaf
+pushProject db need leaf@(Range{}) = pushProjectLeaf db need leaf
 
 -- | 折一个表达式节点
 foldNode :: Expr -> Expr
@@ -186,9 +191,11 @@ worthRange db t col lo hi = case tableMetaOf db t of
 -- | 将独立 IN 或简单等值 EXISTS 变为半连接
 semiJoin :: Database -> Expr -> RelOp -> Maybe RelOp
 semiJoin db (InSub left query negated) source
-    | null (subqueryRefs query), safeKey left
+    | null (subqueryRefs query)
+    , safeKey left
     , Right right <- translate (subqueryStatement query)
-    , [column] <- relOpCols db right, column /= "*" =
+    , [column] <- relOpCols db right
+    , column /= "*" =
         Just (SemiJoin (if negated then NotIn else Matching) left (Col column) source right (Just (subqueryStatement query)))
 semiJoin db (ExistsSub query negated) source
     | [reference] <- subqueryRefs query
@@ -199,8 +206,15 @@ semiJoin db (ExistsSub query negated) source
     , Just column <- localKey columns reference a b
     , let physical = if reference `elem` relOpCols db source then reference else reverse (takeWhile (/= '.') (reverse reference))
     , physical `elem` relOpCols db source =
-        Just (SemiJoin (if negated then NonMatching else Matching) (Col physical) (Col "$semikey") source
-            (Compute (items ++ [("$semikey", Col column)]) scan) Nothing)
+        Just
+            ( SemiJoin
+                (if negated then NonMatching else Matching)
+                (Col physical)
+                (Col "$semikey")
+                source
+                (Compute (items ++ [("$semikey", Col column)]) scan)
+                Nothing
+            )
 semiJoin _ _ _ = Nothing
 
 -- | 只允许无求值错误的左键
@@ -297,7 +311,7 @@ rewriteNode db op = pushOne db op
 optimizeRelOp :: Database -> RelOp -> RelOp
 optimizeRelOp db = rewriteNode db . descend
   where
-    -- | 先递归处理子算子
+    -- \| 先递归处理子算子
     descend (Filter p x) = Filter p (optimizeRelOp db x)
     descend (Project cols x) = Project cols (optimizeRelOp db x)
     descend (Compute items x) = Compute items (optimizeRelOp db x)

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Planner.hs

@@ -27,7 +27,7 @@ source fromC mWhere = do
 nameAggs :: [(String, Expr)] -> [(String, Expr)]
 nameAggs items = go (1 :: Int) [] (concatMap (aggregatesIn . snd) items)
   where
-    -- | 逐个聚合起名，重复的不再起名
+    -- \| 逐个聚合起名，重复的不再起名
     go :: Int -> [(String, Expr)] -> [Expr] -> [(String, Expr)]
     go _ acc [] = reverse acc
     go n acc (e : es)
@@ -63,7 +63,7 @@ rewriteAggs aggs e = case [label | (label, agg) <- aggs, agg == e] of
         IsNotNull a -> IsNotNull (go a)
         other -> other
   where
-    -- | 递归替换当前查询层的聚合引用
+    -- \| 递归替换当前查询层的聚合引用
     go = rewriteAggs aggs
 
 -- | 排序 + 截断
@@ -82,10 +82,10 @@ translate q = case q of
     SelectDistinct inner -> do
         ordering <- distinctOrdering inner
         plan <- case inner of
-            s@Select{} -> translate s { selectOrderBy = [], selectLimit = Nothing }
+            s@Select{} -> translate s{selectOrderBy = [], selectLimit = Nothing}
             _ -> Left "DISTINCT requires SELECT"
         let labels = case inner of
-                Select { selectItems = items } -> map fst items
+                Select{selectItems = items} -> map fst items
                 _ -> []
         keys <- mapM (distinctKey labels) ordering
         namedOrdering <- mapM (columnKey labels) ordering
@@ -97,32 +97,38 @@ translate q = case q of
     Select items fromC mWhere groupBy having orderBy mLimit -> do
         plan0 <- source fromC mWhere
         expressions <- mapM (orderExpression items . fst) orderBy
-        let aggs = nameAggs (items ++ [("having", expression) | expression <- maybe [] pure having]
-                ++ map ("order",) expressions)
+        let aggs =
+                nameAggs
+                    ( items
+                        ++ [("having", expression) | expression <- maybe [] pure having]
+                        ++ map ("order",) expressions
+                    )
             aggregate = not (null groupBy && null aggs && null having)
             grouped = if aggregate then Aggregate groupBy aggs plan0 else plan0
             plan = maybe grouped (\condition -> Filter (rewriteAggs aggs condition) grouped) having
             items' = [(label, rewriteAggs aggs expression) | (label, expression) <- items]
             ordering = zip (map (rewriteAggs aggs) expressions) (map snd orderBy)
-            -- | 简单列排序保留可优化的名称算子
+            -- \| 简单列排序保留可优化的名称算子
             named (Col column, direction) = Just (column, direction)
             named _ = Nothing
-            -- | 保持普通投影在 LIMIT 之后求值
+            -- \| 保持普通投影在 LIMIT 之后求值
             projected child
                 | all (\(label, expression) -> expression == Col label) items' = Project (map fst items') child
                 | otherwise = Compute items' child
-        Right (case mapM named ordering of
-            Just spec -> projected (limited spec mLimit plan)
-            Nothing -> orderedProjection items' ordering mLimit plan)
+        Right
+            ( case mapM named ordering of
+                Just spec -> projected (limited spec mLimit plan)
+                Nothing -> orderedProjection items' ordering mLimit plan
+            )
     _ -> Left "only SELECT is supported by translate"
   where
-    -- | 简单投影的序号映射到来源列
+    -- \| 简单投影的序号映射到来源列
     columnKey columns (column, direction) = do
         position <- orderPosition (length columns) column
         case position of
             Just slot -> Right (columns !! slot, direction)
             Nothing -> Left "DISTINCT: sorting requires an output position"
-    -- | 去重后按指定输出位置或唯一名称排序
+    -- \| 去重后按指定输出位置或唯一名称排序
     distinctKey columns (column, direction) = do
         position <- orderPosition (length columns) column
         case position of

chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Sort.hs

@@ -1,8 +1,8 @@
 module ChuSQL.Core.Engine.Algebra.Sort (sortRows, sortBoundRows, compareValue) where
 
-import ChuSQL.Core.Model
-import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Algebra.Expr (evalExpr)
+import ChuSQL.Core.Engine.Syntax.AST
+import ChuSQL.Core.Model
 import Data.List (sortBy)
 
 -- 排序：按多列规格排出结果行，每列可升可降。
@@ -34,9 +34,9 @@ sortRows :: [(String, SortDir)] -> [Row] -> [Row]
 sortRows [] rows = rows
 sortRows spec rows = map snd (sortBy cmp (map decorate rows))
   where
-    -- | 取键并带上原行
+    -- \| 取键并带上原行
     decorate row = (sortKey spec row, row)
-    -- | 比较两个带键的行
+    -- \| 比较两个带键的行
     cmp (k1, _) (k2, _) = compareKeys (map snd spec) k1 k2
 
 -- | 用绑定槽位取键并稳定排序
@@ -47,9 +47,9 @@ sortBoundRows spec outer rows = do
     Right (map snd (sortBy compareRows decorated))
   where
     directions = map snd spec
-    -- | 每行只计算一次绑定排序键
+    -- \| 每行只计算一次绑定排序键
     decorate row = do
         keys <- mapM (\(expression, _) -> evalExpr expression (row ++ outer)) spec
         Right (map Just keys, row)
-    -- | 比较排序键并保留同键行序
+    -- \| 比较排序键并保留同键行序
     compareRows (left, _) (right, _) = compareKeys directions left right

chusql-core/engine/src/ChuSQL/Core/Engine/Builtin.hs

@@ -19,7 +19,8 @@ module ChuSQL.Core.Engine.Builtin (
 ) where
 
 import ChuSQL.Core.Engine.Syntax.AST (CompareOp (..), Expr (..))
-import ChuSQL.Core.Model (Value (..), compareValue)
+import ChuSQL.Core.Model (ColumnType (..), Value (..), compareValue, hasTypeCapability)
+import ChuSQL.Core.Runtime (TypeCapability (..), builtinTypes, validateValue)
 import Control.Monad (foldM)
 import Data.Char (toLower)
 
@@ -201,12 +202,12 @@ compareNode CmpLtE = LtE
 executeOperator :: Operator -> [Value] -> Either String Value
 executeOperator op vs = case (op, vs) of
     (OpNeg, [x]) -> evalNeg x
-    (OpGt, [x, y]) -> compareValues (== GT) x y
-    (OpLt, [x, y]) -> compareValues (< EQ) x y
-    (OpEq, [x, y]) -> compareValues (== EQ) x y
-    (OpGtE, [x, y]) -> compareValues (>= EQ) x y
-    (OpLtE, [x, y]) -> compareValues (<= EQ) x y
-    (OpNe, [x, y]) -> compareValues (/= EQ) x y
+    (OpGt, [x, y]) -> compareValues OrdCapability (== GT) x y
+    (OpLt, [x, y]) -> compareValues OrdCapability (< EQ) x y
+    (OpEq, [x, y]) -> compareValues EqCapability (== EQ) x y
+    (OpGtE, [x, y]) -> compareValues OrdCapability (>= EQ) x y
+    (OpLtE, [x, y]) -> compareValues OrdCapability (<= EQ) x y
+    (OpNe, [x, y]) -> compareValues EqCapability (/= EQ) x y
     (OpAnd, [x, y]) -> andValues x y
     (OpOr, [x, y]) -> orValues x y
     (_, [x, y]) | Just a <- arithOf op -> evalArith a x y
@@ -262,21 +263,26 @@ asDouble (VFloat d) = Just d
 asDouble _ = Nothing
 
 -- | 比较两个值：NULL 给 NULL，其余按全序比
-compareValues :: (Ordering -> Bool) -> Value -> Value -> Either String Value
-compareValues rel x y
+compareValues :: TypeCapability -> (Ordering -> Bool) -> Value -> Value -> Either String Value
+compareValues capability rel x y
     | x == VNull || y == VNull = Right VNull
-    | comparableValue x y = Right (VBool (rel (compareValue x y)))
+    | comparableValue capability x y = Right (VBool (rel (compareValue x y)))
     | otherwise = Left "type error: cannot compare these values"
 
 -- | 两个值是否落在可以用全序比较的同一族里
-comparableValue :: Value -> Value -> Bool
-comparableValue (VInt _) (VFloat _) = True
-comparableValue (VFloat _) (VInt _) = True
-comparableValue (VInt _) (VInt _) = True
-comparableValue (VFloat _) (VFloat _) = True
-comparableValue (VStr _) (VStr _) = True
-comparableValue (VBool _) (VBool _) = True
-comparableValue _ _ = False
+comparableValue :: TypeCapability -> Value -> Value -> Bool
+comparableValue _ (VInt _) (VFloat _) = True
+comparableValue _ (VFloat _) (VInt _) = True
+comparableValue _ (VInt _) (VInt _) = True
+comparableValue _ (VFloat _) (VFloat _) = True
+comparableValue _ (VStr _) (VStr _) = True
+comparableValue _ (VBool _) (VBool _) = True
+comparableValue capability (VRuntime left x) (VRuntime right y) =
+    left == right
+        && hasTypeCapability capability (CRuntime left)
+        && validateValue builtinTypes left x == Right ()
+        && validateValue builtinTypes right y == Right ()
+comparableValue _ _ _ = False
 
 -- | 逻辑与的三值真值表
 andValues :: Value -> Value -> Either String Value

chusql-core/engine/src/ChuSQL/Core/Engine/Domain.hs

@@ -0,0 +1,235 @@
+module ChuSQL.Core.Engine.Domain (
+    domainColumns,
+    domainDefinition,
+    canonicalDomain,
+    effectiveColumns,
+    domainCheckPlan,
+    runDomainChecks,
+    validateDomainDefaults,
+    prepareDomainAlter,
+) where
+
+import ChuSQL.Core.Engine.Algebra.Expr (evalExpr)
+import ChuSQL.Core.Engine.Runtime.Relation (orderRow)
+import ChuSQL.Core.Engine.Semantic (prepareDomainCheckExpression)
+import ChuSQL.Core.Engine.Syntax.AST
+import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
+import ChuSQL.Core.Model
+import Control.Applicative ((<|>))
+import Control.Monad (when)
+import Data.Char (isAlphaNum, isAscii, toLower)
+import Data.List (isPrefixOf, nub)
+import Data.Maybe (fromMaybe)
+
+-- 领域元数据、约束继承、默认值及结构变更的纯校验。
+
+-- | 将领域定义编码为目录列
+domainColumns :: DomainDefinition -> [(String, Column)]
+domainColumns (DomainDefinition base checks) =
+    ("base", base{columnCheck = Nothing})
+        : [("check_" ++ name, (plainColumn CBool){columnCheck = Just text}) | (name, text) <- checks]
+
+-- | 从新旧目录恢复领域定义
+domainDefinition :: Table -> Either String DomainDefinition
+domainDefinition table = do
+    base <- maybe (Left "invalid domain catalog: missing base") Right (lookup "base" (tableCols table))
+    checks <- mapM readCheck [(name, col) | (name, col) <- tableCols table, name /= "base"]
+    let legacy = maybe [] (\text -> [("domain_check_0", text)]) (columnCheck base)
+    Right (DomainDefinition base{columnCheck = Nothing} (legacy ++ checks))
+  where
+    -- \| 恢复一条具名检查条件
+    readCheck (name, col)
+        | "check_" `isPrefixOf` name, Just text <- columnCheck col = Right (drop 6 name, text)
+        | otherwise = Left "invalid domain constraint catalog"
+
+-- | 为匿名约束命名并验证完整定义
+canonicalDomain :: Database -> String -> DomainDefinition -> Either String DomainDefinition
+canonicalDomain db name definition = do
+    normalized <- normalize definition
+    let candidate = install name normalized db
+    validateOwn candidate name
+    Right normalized
+  where
+    -- \| 规范化约束名称并拒绝重复声明
+    normalize (DomainDefinition base checks) = do
+        when
+            (columnAutoIncrement base || columnUnique base || columnPrimaryKey base)
+            (Left "DOMAIN does not support row-set constraints")
+        let named = [map toLower key | (key, _) <- checks, not (null key)]
+        when (length named /= length (nub named)) (Left "duplicate domain constraint name")
+        mapM_ validName named
+        assigned <- assign named 1 checks
+        Right (DomainDefinition base assigned)
+    -- \| 验证约束标识符
+    validName key
+        | null key || length key > 48 || not (all (\c -> isAscii c && (isAlphaNum c || c == '_')) key) =
+            Left "invalid domain constraint name"
+        | otherwise = Right ()
+    -- \| 为未命名约束分配稳定名称
+    assign _ _ [] = Right []
+    assign used index ((key, text) : rest)
+        | null key =
+            let (chosen, next) = fresh used index
+             in ((chosen, text) :) <$> assign (chosen : used) next rest
+        | otherwise = ((map toLower key, text) :) <$> assign used index rest
+    -- \| 跳过已有的自动约束名称
+    fresh used index
+        | chosen `elem` used = fresh used (index + 1)
+        | otherwise = (chosen, index + 1)
+      where
+        chosen = "domain_check_" ++ show (index :: Int)
+
+-- | 在纯目录中安装候选领域定义
+install :: String -> DomainDefinition -> Database -> Database
+install name definition db = (key, table{tableCols = domainColumns definition}) : filter ((/= key) . fst) db
+  where
+    key = domainTableName name
+    table = fromMaybe (Table key [] [] Nothing Nothing Nothing) (lookup key db)
+
+-- | 沿目录解析领域链并拒绝循环
+chain :: Database -> ColumnType -> Either String [(String, DomainDefinition)]
+chain db = go []
+  where
+    -- \| 逐层读取当前定义而非缓存属性
+    go seen (CDomain name _)
+        | name `elem` seen = Left ("cyclic domain definition: " ++ name)
+        | otherwise = do
+            table <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
+            definition@(DomainDefinition base _) <- domainDefinition table
+            rest <- go (name : seen) (columnType base)
+            Right ((name, definition) : rest)
+    go _ _ = Right []
+
+-- | 合并列声明与继承的非空和默认值
+effectiveColumns :: Database -> [(String, Column)] -> Either String [(String, Column)]
+effectiveColumns db = mapM effective
+  where
+    -- \| 保留最近默认值并收紧可空属性
+    effective (name, column) = do
+        definitions <- chain db (columnType column)
+        let bases = [base | (_, DomainDefinition base _) <- definitions]
+        Right
+            ( name
+            , column
+                { columnNullable = columnNullable column && all columnNullable bases
+                , columnDefault = foldl (<|>) (columnDefault column) (map columnDefault bases)
+                }
+            )
+
+-- | 绑定领域 VALUE 到独立的单值布局
+domainCheckPlan :: Database -> [(String, Column)] -> Either String [(String, Int, Expr)]
+domainCheckPlan db columns = concat <$> mapM checks (zip [0 ..] columns)
+  where
+    -- \| 按基础领域到外层领域绑定条件
+    checks (slot, (_, column)) = do
+        definitions <- chain db (columnType column)
+        mapM
+            (bind slot column)
+            [ (name ++ "." ++ key, text)
+            | (name, DomainDefinition _ constraints) <- reverse definitions
+            , (key, text) <- constraints
+            ]
+    -- \| 拒绝聚合及子查询并固定类型槽位
+    bind slot column (name, text) = do
+        expression <- parseExpression text
+        bound <- prepareDomainCheckExpression (columnType column) expression
+        Right (name, slot, bound)
+
+-- | SQL CHECK 的 UNKNOWN 与 TRUE 都通过
+runDomainChecks :: [(String, Int, Expr)] -> Row -> Either String ()
+runDomainChecks plan row = mapM_ check plan
+  where
+    -- \| 在单值作用域执行一条领域约束
+    check (name, slot, expression) = case drop slot row of
+        (_, value) : _ -> do
+            result <- evalExpr expression [("value", value)]
+            case result of
+                VBool True -> Right ()
+                VNull -> Right ()
+                VBool False -> Left ("CHECK on DOMAIN " ++ name ++ " failed")
+                _ -> Left ("CHECK on DOMAIN " ++ name ++ " is not boolean")
+        [] -> Left "missing bound domain value"
+
+-- | 检查有效默认值是否满足领域约束
+validateDomainDefaults :: Database -> [(String, Column)] -> Either String ()
+validateDomainDefaults db columns = do
+    effective <- effectiveColumns db columns
+    mapM_ validate [entry | entry@(_, column) <- effective, CDomain{} <- [columnType column]]
+  where
+    -- \| 默认值不改变已有行但必须可赋值
+    validate entry@(name, column) = case columnDefault column of
+        Nothing -> Right ()
+        Just value -> do
+            coerced <- coerceValue (columnType column) value
+            checkNull name column coerced
+            plan <- domainCheckPlan db [entry]
+            runDomainChecks plan [(name, coerced)]
+
+-- | 拒绝领域或列要求非空时的 NULL
+checkNull :: String -> Column -> Value -> Either String ()
+checkNull name column value
+    | value == VNull && not (columnNullable column) = Left ("DOMAIN NOT NULL: " ++ name)
+    | otherwise = Right ()
+
+-- | 检查领域本身的定义及继承默认值
+validateOwn :: Database -> String -> Either String ()
+validateOwn db name = do
+    table <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
+    DomainDefinition base _ <- domainDefinition table
+    let columns = [("value", plainColumn (CDomain name (columnType base)))]
+    _ <- domainCheckPlan db columns
+    validateDomainDefaults db columns
+
+-- | 在完整快照上校验并生成领域替换定义
+prepareDomainAlter :: String -> DomainAlter -> Database -> Either String [(String, Column)]
+prepareDomainAlter rawName action db = do
+    table <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
+    definition <- domainDefinition table >>= change
+    normalized <- canonicalDomain db name definition
+    let candidate = install name normalized db
+    mapM_ (validateDependent candidate) [key | (key, _) <- candidate, isDomainTable key]
+    mapM_ (validateTable candidate) [(key, value) | (key, value) <- candidate, not (isDomainTable key)]
+    Right (domainColumns normalized)
+  where
+    name = map toLower rawName
+    -- \| 修改单个属性且保留其他约束
+    change (DomainDefinition base checks) = case action of
+        DomainDefault value -> Right (DomainDefinition base{columnDefault = value} checks)
+        DomainNullable nullable -> Right (DomainDefinition base{columnNullable = nullable} checks)
+        DomainAddCheck key text -> Right (DomainDefinition base (checks ++ [(fromMaybe "" key, text)]))
+        DomainDropCheck key
+            | map toLower key `elem` map fst checks -> Right (DomainDefinition base (filter ((/= map toLower key) . fst) checks))
+            | otherwise -> Left ("unknown domain constraint: " ++ key)
+    -- \| 判断传递引用是否包含目标领域
+    affected candidate ty = any ((== name) . fst) <$> chain candidate ty
+    -- \| 校验依赖领域的继承默认值
+    validateDependent candidate key = do
+        let domain = drop (length (domainTableName "")) key
+        applies <- affected candidate (CDomain domain CStr)
+        when applies (validateOwn candidate domain)
+    -- \| 只校验受领域变化影响的列与数据
+    validateTable candidate (_, table) = do
+        selected <-
+            mapM
+                ( \entry@(_, column) -> do
+                    applies <- affected candidate (columnType column)
+                    Right [entry | applies]
+                )
+                (tableCols table)
+        let columns = concat selected
+        effective <- effectiveColumns candidate columns
+        validateDomainDefaults candidate columns
+        plan <- domainCheckPlan candidate columns
+        mapM_ (validateRow effective plan) (tableRows table)
+    -- \| 按列布局检查非空与全部继承条件
+    validateRow columns plan row = do
+        selected <- orderRow (map fst columns) row
+        values <-
+            mapM
+                ( \((key, column), (_, value)) -> do
+                    coerced <- coerceValue (columnType column) value
+                    checkNull key column coerced
+                    Right (key, coerced)
+                )
+                (zip columns selected)
+        runDomainChecks plan values

chusql-core/engine/src/ChuSQL/Core/Engine/Error.hs

@@ -33,8 +33,12 @@ data ErrorRule = ErrorRule
 -- | 唯一的错误识别表，顺序即优先级
 errorRules :: [ErrorRule]
 errorRules =
-    [ ErrorRule "no database selected" NoDatabaseError "no_database"
+    [ ErrorRule "deadlock_detected:" StorageError "deadlock_detected"
+    , ErrorRule "lock_timeout:" StorageError "lock_timeout"
+    , ErrorRule "serialization_failure:" CatalogError "serialization_failure"
+    , ErrorRule "no database selected" NoDatabaseError "no_database"
     , ErrorRule "administrator required" PermissionError "forbidden"
+    , ErrorRule "serialization_failure: domain snapshot changed" CatalogError "serialization_failure"
     , ErrorRule "bound query object changed" CatalogError "serialization_failure"
     , ErrorRule "bound query schema changed" CatalogError "serialization_failure"
     , ErrorRule "unknown table" CatalogError "not_found"

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Binding.hs

@@ -1,23 +1,43 @@
-module ChuSQL.Core.Engine.Runtime.Binding
-    ( Expression (..), TypedExpression, expressionType, bindExpression, evaluateExpression
-    , Plan (..), TypedPlan, planSchema, bindPlan, executePlan
-    ) where
+module ChuSQL.Core.Engine.Runtime.Binding (
+    Expression (..),
+    TypedExpression,
+    expressionType,
+    bindExpression,
+    evaluateExpression,
+    Plan (..),
+    TypedPlan,
+    planSchema,
+    bindPlan,
+    executePlan,
+) where
 
-import ChuSQL.Core.Engine.Runtime.Types
 import ChuSQL.Core.Engine.Runtime.Functions
+import ChuSQL.Core.Engine.Runtime.Types
 import Control.Monad (filterM)
 import Data.List (nub, sort)
 
 -- 仅依据 schema 绑定表达式与查询，执行已解析的类型和函数身份。
 
 -- | 表达未绑定的类型化语言
-data Expression = Literal TypeExpr RuntimeValue | Reference String | Apply String [Expression]
-    | ListLiteral TypeExpr [Expression] | NothingLiteral TypeExpr | JustLiteral Expression
-    | TupleLiteral [Expression] deriving (Show, Eq)
+data Expression
+    = Literal TypeExpr RuntimeValue
+    | Reference String
+    | Apply String [Expression]
+    | ListLiteral TypeExpr [Expression]
+    | NothingLiteral TypeExpr
+    | JustLiteral Expression
+    | TupleLiteral [Expression]
+    deriving (Show, Eq)
 
 -- | 保存绑定后的表达式节点
-data ExpressionNode = Constant RuntimeValue | BoundReference Int String | BoundApply FunctionId [TypedExpression]
-    | BoundList [TypedExpression] | BoundNothing | BoundJust TypedExpression | BoundTuple [TypedExpression]
+data ExpressionNode
+    = Constant RuntimeValue
+    | BoundReference Int String
+    | BoundApply FunctionId [TypedExpression]
+    | BoundList [TypedExpression]
+    | BoundNothing
+    | BoundJust TypedExpression
+    | BoundTuple [TypedExpression]
     deriving (Show, Eq)
 
 -- | 保存表达式的确定类型
@@ -56,9 +76,9 @@ bindExpression types functions env expression = case expression of
         bound <- mapM bind arguments
         compound (tupleType (map (typeExpression . expressionType) bound)) (BoundTuple bound)
   where
-    -- | 绑定当前作用域的子表达式
+    -- \| 绑定当前作用域的子表达式
     bind = bindExpression types functions env
-    -- | 校验并构造复合表达式
+    -- \| 校验并构造复合表达式
     compound ty node = do
         tid <- descriptorId <$> resolveType types ty
         Right (TypedExpression tid node)
@@ -80,16 +100,24 @@ evaluateExpression types functions row (TypedExpression tid node) = do
     validateValue types tid value
     Right value
   where
-    -- | 执行当前行的子表达式
+    -- \| 执行当前行的子表达式
     evaluate = evaluateExpression types functions row
 
 -- | 表达未绑定的关系计划
-data Plan = TableScan String | SingleRow | Projection [(String, Expression)] Plan
-    | Selection Expression Plan deriving (Show, Eq)
+data Plan
+    = TableScan String
+    | SingleRow
+    | Projection [(String, Expression)] Plan
+    | Selection Expression Plan
+    deriving (Show, Eq)
 
 -- | 保存绑定后的关系节点
-data PlanNode = BoundScan String | BoundSingleRow | BoundProjection [(String, TypedExpression)] TypedPlan
-    | BoundSelection TypedExpression TypedPlan deriving (Show, Eq)
+data PlanNode
+    = BoundScan String
+    | BoundSingleRow
+    | BoundProjection [(String, TypedExpression)] TypedPlan
+    | BoundSelection TypedExpression TypedPlan
+    deriving (Show, Eq)
 
 -- | 保存输出 schema 和关系节点
 data TypedPlan = TypedPlan [(String, TypeId)] PlanNode deriving (Show, Eq)
@@ -122,13 +150,13 @@ bindPlan types functions catalog plan = case plan of
             then Right (TypedPlan (planSchema child) (BoundSelection predicate child))
             else Left "selection predicate must be Bool"
   where
-    -- | 绑定子计划
+    -- \| 绑定子计划
     bind = bindPlan types functions catalog
-    -- | 解析 schema 列的类型身份
+    -- \| 解析 schema 列的类型身份
     bindColumn (name, ty) = do
         tid <- descriptorId <$> resolveType types ty
         Right (name, tid)
-    -- | 绑定投影项
+    -- \| 绑定投影项
     bindItem env (name, value) = do
         bound <- bindExpression types functions env value
         Right (name, bound)
@@ -140,8 +168,12 @@ uniqueNames names
     | otherwise = Left "duplicate schema column"
 
 -- | 执行绑定计划并校验存储返回值
-executePlan :: TypeRegistry -> FunctionRegistry -> (String -> Either String [[(String, RuntimeValue)]])
-    -> TypedPlan -> Either String [[(String, RuntimeValue)]]
+executePlan ::
+    TypeRegistry ->
+    FunctionRegistry ->
+    (String -> Either String [[(String, RuntimeValue)]]) ->
+    TypedPlan ->
+    Either String [[(String, RuntimeValue)]]
 executePlan types functions scan (TypedPlan output node) = do
     rows <- case node of
         BoundScan name -> scan name
@@ -155,23 +187,23 @@ executePlan types functions scan (TypedPlan output node) = do
     mapM_ (validateRow output) rows
     Right [[(name, value) | (name, _) <- output, Just value <- [lookup name row]] | row <- rows]
   where
-    -- | 计算一行的投影项
+    -- \| 计算一行的投影项
     project items row = mapM (projectItem row) items
-    -- | 计算命名输出项
+    -- \| 计算命名输出项
     projectItem row (name, expression) = do
         value <- evaluateExpression types functions row expression
         Right (name, value)
-    -- | 计算选择条件
+    -- \| 计算选择条件
     keep condition row = do
         value <- evaluateExpression types functions row condition
         case value of
             RBool result -> Right result
             _ -> Left "bound predicate returned a non-Bool value"
-    -- | 校验存储行的完整 schema
+    -- \| 校验存储行的完整 schema
     validateRow columns row
         | sort (map fst row) /= sort (map fst columns) = Left "storage row schema mismatch"
         | otherwise = mapM_ (validateColumn row) columns
-    -- | 按列名校验返回值的类型
+    -- \| 按列名校验返回值的类型
     validateColumn row (name, tid) = case lookup name row of
         Just value -> validateValue types tid value
         Nothing -> Left ("missing bound column: " ++ name)

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Dependencies.hs

@@ -1,7 +1,7 @@
 module ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, typeDependencies, validateDependencies) where
 
 import ChuSQL.Core.Engine.Syntax.AST
-import ChuSQL.Core.Model (Database, ColumnType (..), columnType, tableCols, tableIdentity, tableSchemaVersion, domainTableName, lastTablePart)
+import ChuSQL.Core.Model (ColumnType (..), Database, columnType, domainTableName, lastTablePart, tableCols, tableIdentity, tableSchemaVersion)
 import Data.List (nub)
 
 -- 收集读写语句及嵌套表达式的表依赖，供执行期校验目录。
@@ -10,7 +10,7 @@ import Data.List (nub)
 validateDependencies :: Database -> Database -> Either String ()
 validateDependencies expected current = mapM_ validate expected
   where
-    -- | 数据和统计变化不使结构绑定失效
+    -- \| 数据和统计变化不使结构绑定失效
     validate (name, table) = case lookup name current of
         Just actual | tableIdentity actual /= tableIdentity table -> Left ("bound query object changed: " ++ name)
         Just actual | tableSchemaVersion actual /= tableSchemaVersion table -> Left ("bound query schema changed: " ++ name)
@@ -19,47 +19,67 @@ validateDependencies expected current = mapM_ validate expected
 
 -- | 收集读写目标、来源及子查询依赖
 queryTables :: Statement -> [String]
-queryTables statement = nub (case statement of
-    SelectDistinct child -> queryTables child
-    Select items source condition _ having ordering _ -> sourceTables source
-        ++ concatMap (expressionTables . snd) items ++ concatMap expressionTables condition
-        ++ concatMap expressionTables having
-        ++ concatMap (maybe [] expressionTables . orderKeyExpression . fst) ordering
-    Insert target _ rows -> target : concatMap (concatMap expressionTables) rows
-    Update target assignments condition -> target : concatMap (expressionTables . snd) assignments
-        ++ concatMap expressionTables condition
-    Delete target condition -> target : concatMap expressionTables condition
-    DropTable target -> [target]
-    CreateIndex target _ -> [target]
-    DropIndex target _ -> [target]
-    DropColumn target _ -> [target]
-    AddColumn target _ -> [target]
-    RenameColumn target _ _ -> [target]
-    AlterColumnType target _ _ -> [target]
-    AlterColumnDefault target _ _ -> [target]
-    AlterColumnNull target _ _ -> [target]
-    _ -> [])
+queryTables statement =
+    nub
+        ( case statement of
+            SelectDistinct child -> queryTables child
+            Select items source condition _ having ordering _ ->
+                sourceTables source
+                    ++ concatMap (expressionTables . snd) items
+                    ++ concatMap expressionTables condition
+                    ++ concatMap expressionTables having
+                    ++ concatMap (maybe [] expressionTables . orderKeyExpression . fst) ordering
+            Insert target _ rows -> target : concatMap (concatMap expressionTables) rows
+            Update target assignments condition ->
+                target
+                    : concatMap (expressionTables . snd) assignments
+                    ++ concatMap expressionTables condition
+            Delete target condition -> target : concatMap expressionTables condition
+            DropTable target -> [target]
+            CreateIndex target _ -> [target]
+            DropIndex target _ -> [target]
+            DropColumn target _ -> [target]
+            AddColumn target _ -> [target]
+            RenameColumn target _ _ -> [target]
+            AlterColumnType target _ _ -> [target]
+            AlterColumnDefault target _ _ -> [target]
+            AlterColumnNull target _ _ -> [target]
+            _ -> []
+        )
 
 -- | 收集来源列依赖的领域定义
 domainDependencies :: Database -> [String] -> [String]
-domainDependencies catalog sources = typeDependencies catalog
-    [columnType column | (name, table) <- catalog, name `elem` sources
-        , (_, column) <- tableCols table]
+domainDependencies catalog sources =
+    typeDependencies
+        catalog
+        [ columnType column
+        | (name, table) <- catalog
+        , name `elem` sources
+        , (_, column) <- tableCols table
+        ]
 
 -- | 收集声明类型依赖的领域目录
 typeDependencies :: Database -> [ColumnType] -> [String]
 typeDependencies catalog types = collect [] (concatMap typeDomains types)
   where
-    -- | 递归展开定义并防止重复访问
+    -- \| 递归展开定义并防止重复访问
     collect seen [] = seen
     collect seen (domain : remaining) =
-        let definitions = [(name, table) | (name, table) <- catalog
-                , lastTablePart name == domainTableName domain, name `notElem` seen]
+        let definitions =
+                [ (name, table)
+                | (name, table) <- catalog
+                , lastTablePart name == domainTableName domain
+                , name `notElem` seen
+                ]
             names = map fst definitions
-            nested = [child | (_, table) <- definitions, (_, column) <- tableCols table
-                , child <- typeDomains (columnType column)]
-        in collect (seen ++ names) (remaining ++ nested)
-    -- | 保留嵌套领域的每层依赖
+            nested =
+                [ child
+                | (_, table) <- definitions
+                , (_, column) <- tableCols table
+                , child <- typeDomains (columnType column)
+                ]
+         in collect (seen ++ names) (remaining ++ nested)
+    -- \| 保留嵌套领域的每层依赖
     typeDomains (CDomain name base) = name : typeDomains base
     typeDomains _ = []
 

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Functions.hs

@@ -1,10 +1,16 @@
-module ChuSQL.Core.Engine.Runtime.Functions
-    ( FunctionId (..), FunctionSignature (..), FunctionRegistry
-    , builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction
-    ) where
+module ChuSQL.Core.Engine.Runtime.Functions (
+    FunctionId (..),
+    FunctionSignature (..),
+    FunctionRegistry,
+    builtinFunctions,
+    resolveFunction,
+    resolveNullableFunction,
+    functionSignature,
+    invokeFunction,
+) where
 
-import Control.Monad (zipWithM_)
 import ChuSQL.Core.Engine.Runtime.Types
+import Control.Monad (zipWithM_)
 import Data.Char (toLower)
 
 -- 内建函数的固定身份、签名解析和类型化调用。
@@ -14,9 +20,12 @@ newtype FunctionId = FunctionId Int deriving (Show, Eq, Ord)
 
 -- | 描述已解析的函数签名
 data FunctionSignature = FunctionSignature
-    { signatureId :: FunctionId, signatureName :: String
-    , signatureArguments :: [TypeId], signatureResult :: TypeId
-    } deriving (Show, Eq)
+    { signatureId :: FunctionId
+    , signatureName :: String
+    , signatureArguments :: [TypeId]
+    , signatureResult :: TypeId
+    }
+    deriving (Show, Eq)
 
 -- | 保存函数签名和实现
 newtype FunctionRegistry = FunctionRegistry [(FunctionSignature, [RuntimeValue] -> Either String RuntimeValue)]
@@ -27,9 +36,12 @@ builtinFunctions types = do
     int <- descriptorId <$> resolveType types intType
     bool <- descriptorId <$> resolveType types boolType
     string <- descriptorId <$> resolveType types stringType
-    Right (FunctionRegistry
-        [(FunctionSignature (FunctionId 1) "length" [string] int, stringLength)
-        ,(FunctionSignature (FunctionId 2) "not" [bool] bool, booleanNot)])
+    Right
+        ( FunctionRegistry
+            [ (FunctionSignature (FunctionId 1) "length" [string] int, stringLength)
+            , (FunctionSignature (FunctionId 2) "not" [bool] bool, booleanNot)
+            ]
+        )
 
 -- | 按名称和完整参数类型解析函数
 resolveFunction :: FunctionRegistry -> String -> [TypeId] -> Either String FunctionSignature
@@ -38,14 +50,17 @@ resolveFunction registry name arguments = resolveNullableFunction registry name
 -- | 按可空 SQL 参数解析确定签名
 resolveNullableFunction :: FunctionRegistry -> String -> [Maybe TypeId] -> Either String FunctionSignature
 resolveNullableFunction (FunctionRegistry functions) name arguments =
-    case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
-              , length arguments == length (signatureArguments sig)
-              , and (zipWith matches arguments (signatureArguments sig))] of
+    case [ sig
+         | (sig, _) <- functions
+         , map toLower (signatureName sig) == map toLower name
+         , length arguments == length (signatureArguments sig)
+         , and (zipWith matches arguments (signatureArguments sig))
+         ] of
         [sig] -> Right sig
         [] -> Left ("no matching function signature: " ++ name)
         _ -> Left ("ambiguous function signature: " ++ name)
   where
-    -- | 匹配具体参数或未定型 NULL
+    -- \| 匹配具体参数或未定型 NULL
     matches Nothing _ = True
     matches (Just supplied) expected = supplied == expected
 
@@ -62,7 +77,9 @@ invokeFunction types (FunctionRegistry functions) fid values =
         [(sig, implementation)]
             | length values == length (signatureArguments sig) -> do
                 zipWithM_
-                  (validateValue types) (signatureArguments sig) values
+                    (validateValue types)
+                    (signatureArguments sig)
+                    values
                 result <- implementation values
                 validateValue types (signatureResult sig) result
                 Right result

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Query.hs

@@ -1,25 +1,33 @@
-module ChuSQL.Core.Engine.Runtime.Query
-    ( BoundQuery, QueryType (..), queryTypes, bindQuery, executeQueryM
-    ) where
+module ChuSQL.Core.Engine.Runtime.Query (
+    BoundQuery,
+    QueryType (..),
+    queryTypes,
+    bindQuery,
+    executeQueryM,
+) where
 
 import ChuSQL.Core.Engine.Algebra.Eval (evalRelOpM)
 import ChuSQL.Core.Engine.Algebra.Op (RelOp)
 import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
 import ChuSQL.Core.Engine.Algebra.Planner (translate)
-import ChuSQL.Core.Engine.Semantic (prepare, querySchema)
-import ChuSQL.Core.Engine.Syntax.AST (Statement)
-import ChuSQL.Core.Engine.Storage (MonadStorage (schema, withSchemaGuard))
+import ChuSQL.Core.Engine.Runtime.Dependencies (domainDependencies, queryTables, validateDependencies)
+import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
 import ChuSQL.Core.Engine.Runtime.SQL (sqlType)
 import ChuSQL.Core.Engine.Runtime.Types (TypeId)
-import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
-import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, validateDependencies)
+import ChuSQL.Core.Engine.Semantic (prepare, querySchema)
+import ChuSQL.Core.Engine.Storage (MonadStorage (schema, withSchemaGuard))
+import ChuSQL.Core.Engine.Syntax.AST (Statement)
 import ChuSQL.Core.Model
 
 -- SQL 查询绑定边界：保存解析后的类型、函数身份及输出 schema。
 
 -- | 保存运行时或兼容列类型
-data QueryType = RuntimeType TypeId | CompatibilityType ColumnType
-    | DomainType String QueryType | NullType deriving (Show, Eq)
+data QueryType
+    = RuntimeType TypeId
+    | CompatibilityType ColumnType
+    | DomainType String QueryType
+    | NullType
+    deriving (Show, Eq)
 
 -- | 保存仅由 schema 绑定的执行计划
 data BoundQuery = BoundQuery Database [String] [(String, Column)] [(String, QueryType)] RelOp
@@ -31,7 +39,7 @@ queryTypes (BoundQuery _ _ _ types _) = types
 -- | 绑定 SQL 查询并优化确定的计划
 bindQuery :: Database -> Statement -> Either String BoundQuery
 bindQuery catalog statement = do
-    let schemaOnly = [(name, table {tableRows = []}) | (name, table) <- catalog]
+    let schemaOnly = [(name, table{tableRows = []}) | (name, table) <- catalog]
     resolved <- prepare schemaOnly statement
     columns <- querySchema schemaOnly resolved
     plan <- translate resolved
@@ -41,11 +49,11 @@ bindQuery catalog statement = do
         dependencies = sources ++ domainDependencies schemaOnly sources
     Right (BoundQuery schemaOnly dependencies columns types bound)
   where
-    -- | 解析输出列的运行时身份
+    -- \| 解析输出列的运行时身份
     typeOf (name, column) = do
         ty <- bindingType (columnType column)
         Right (name, ty)
-    -- | 保留阶段外类型的兼容表示
+    -- \| 保留阶段外类型的兼容表示
     bindingType CNull = Right NullType
     bindingType (CDomain name base) = DomainType name <$> bindingType base
     bindingType CDate = Right (CompatibilityType CDate)
@@ -54,22 +62,24 @@ bindQuery catalog statement = do
     bindingType ty = RuntimeType <$> sqlType ty
 
 -- | 执行绑定查询并校验输出类型
-executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row])
+executeQueryM :: (MonadStorage m) => BoundQuery -> m (Either String [Row])
 executeQueryM (BoundQuery catalog dependencies columns _ plan) = do
     current <- schema
     case current >>= validateDependencies guardedTables of
         Left err -> pure (Left err)
         Right () -> do
-            result <- withSchemaGuard guardedTables
-                (evalRelOpM catalog plan)
+            result <-
+                withSchemaGuard
+                    guardedTables
+                    (evalRelOpM catalog plan)
             pure (result >>= mapM validateRow)
   where
     guardedTables = [(name, table) | (name, table) <- catalog, name `elem` dependencies]
-    -- | 校验完整输出行而不重新解析函数
+    -- \| 校验完整输出行而不重新解析函数
     validateRow row
         | map fst row /= map fst columns = Left "bound query output schema mismatch"
         | otherwise = mapM validateColumn (zip columns row)
-    -- | 校验输出列的物理值
+    -- \| 校验输出列的物理值
     validateColumn ((name, column), (_, value))
         | columnType column == CNull, value == VNull = Right (name, value)
         | valueFits (columnType column) value = Right (name, value)

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Relation.hs

@@ -20,14 +20,14 @@ bindWriteColumns db statement = case statement of
         Delete table <$> mapM (bindSlots columns []) condition
     _ -> Right statement
   where
-    -- | 保留写入目标并绑定右侧表达式
+    -- \| 保留写入目标并绑定右侧表达式
     bindItem columns (name, expression) = (,) name <$> bindSlots columns [] expression
 
 -- | 按绑定布局排列一行并拒绝缺列
 orderRow :: [String] -> Row -> Either String Row
 orderRow columns row = mapM column columns
   where
-    -- | 保留列名并取得物理值
+    -- \| 保留列名并取得物理值
     column name = case lookup name row of
         Just value -> Right (name, value)
         Nothing -> Left ("missing bound column: " ++ name)
@@ -84,8 +84,10 @@ bindSlots columns outer expression = case expression of
     ColumnSlot slot name -> ColumnSlot <$> rebindSlot columns slot name "unknown local column: " <*> pure name
     OuterColumnSlot width slot name
         | width < 0 -> Left ("bound column position mismatch: " ++ name)
-        | otherwise -> OuterColumnSlot (length columns)
-            <$> rebindSlot outer slot name "unknown column: " <*> pure name
+        | otherwise ->
+            OuterColumnSlot (length columns)
+                <$> rebindSlot outer slot name "unknown column: "
+                <*> pure name
     FunctionCall name arguments -> FunctionCall name <$> mapM bind arguments
     BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM bind arguments
     Construct ty arguments -> Construct ty <$> mapM bind arguments
@@ -121,7 +123,7 @@ bindSlots columns outer expression = case expression of
     bind = bindSlots columns outer
     -- \| 查找布局中首次出现的列
     slots names name = [slot | (slot, key) <- zip [0 ..] names, key == name]
-    -- | 保留有效位置，仅允许唯一列重定位
+    -- \| 保留有效位置，仅允许唯一列重定位
     rebindSlot names slot name missing
         | slot < 0 = Left ("bound column position mismatch: " ++ name)
         | take 1 (drop slot names) == [name] = Right slot
@@ -133,7 +135,7 @@ bindSlots columns outer expression = case expression of
     outerReference name = case slots outer name of
         slot : _ -> Right (OuterColumnSlot (length columns) slot name)
         [] -> Left ("unknown column: " ++ name)
-    -- | 将子查询自由变量绑定到父输入布局
+    -- \| 将子查询自由变量绑定到父输入布局
     bindSubquery query = do
         references <- case query of
             Subquery _ names -> mapM reference names
@@ -141,12 +143,12 @@ bindSlots columns outer expression = case expression of
                 | map fst references == names -> mapM rebind references
                 | otherwise -> Left "bound subquery references mismatch"
         Right (BoundSubquery (subqueryStatement query) (subqueryRefs query) references)
-    -- | 补回限定名之前先绑定真实物理列
+    -- \| 补回限定名之前先绑定真实物理列
     reference name = do
         let physical = if name `elem` (columns ++ outer) then name else reverse (takeWhile (/= '.') (reverse name))
         boundReference <- bind (Col physical)
         Right (name, boundReference)
-    -- | 重绑定时保留局部或外层身份
+    -- \| 重绑定时保留局部或外层身份
     rebind (name, boundReference) = (,) name <$> bind boundReference
     -- \| 绑定两个操作数
     binary constructor a b = constructor <$> bind a <*> bind b

chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/SQL.hs

@@ -1,9 +1,9 @@
 module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where
 
-import Control.Monad (zipWithM_)
 import ChuSQL.Core.Engine.Runtime.Functions
 import ChuSQL.Core.Engine.Runtime.Types
 import ChuSQL.Core.Model (ColumnType (..), Value (..))
+import Control.Monad (zipWithM_)
 
 -- SQL 现有标量表示与已解析运行时函数之间的类型边界。
 
@@ -54,7 +54,9 @@ invokeSQLFunction fid expected values = do
                 then Left "function argument count mismatch"
                 else do
                     zipWithM_
-                      validateArgument (signatureArguments sig) values
+                        validateArgument
+                        (signatureArguments sig)
+                        values
                     if VNull `elem` values
                         then Right VNull
                         else do

chusql-core/engine/src/ChuSQL/Core/Engine/Semantic.hs

@@ -1,15 +1,16 @@
 {-# LANGUAGE TupleSections #-}
-module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, prepareCheckExpression, querySchema) where
 
-import Control.Monad (void)
+module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, prepareCheckExpression, prepareDomainCheckExpression, querySchema) where
+
 import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate, hasSubquery)
 import ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature)
-import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType)
 import ChuSQL.Core.Engine.Runtime.Relation (bindSlots)
+import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType)
 import ChuSQL.Core.Engine.Runtime.Types
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
 import ChuSQL.Core.Model
+import Control.Monad (void)
 import Data.Char (isAlphaNum, isAscii, toLower)
 import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub)
 
@@ -46,7 +47,7 @@ data Scope = Scope
 scopeAt :: String -> Scope -> String -> Either String (String, Column)
 scopeAt place scope c = search (scopeFrames scope)
   where
-    -- | 在最近的可见列层停止查找
+    -- \| 在最近的可见列层停止查找
     search [] = Left (missingColumn place c (concat (scopeFrames scope)))
     search (columns : rest) = case columnAt place columns c of
         Right entry -> Right entry
@@ -116,7 +117,12 @@ checkGrouping env keys items having
     | null keys && null having && not (any (hasAggregate . snd) items) = Right ()
     | otherwise = do
         checkColumns "GROUP BY" env keys
-        mapM_ (checkRuntimeColumn "GROUP BY" env) keys
+        mapM_
+            ( \column -> do
+                (_, definition) <- scopeAt "GROUP BY" env column
+                void (requireHashing "GROUP BY" (InferType (columnType definition)))
+            )
+            keys
         mapM_ okCol (nub (concatMap (bareColumns . snd) items ++ concatMap bareColumns having))
   where
     -- \| 这一列能不能出现在分组查询里
@@ -172,12 +178,12 @@ inferExpr db place env (Neg a) = do
         InferType x
             | numericType x -> Right t
             | otherwise -> Left (place ++ ": operator needs TInt on both sides, got TInt and " ++ typeLabel x)
-inferExpr db place env (Gt a b) = comparison db place env a b
-inferExpr db place env (Lt a b) = comparison db place env a b
-inferExpr db place env (Eq a b) = comparison db place env a b
-inferExpr db place env (GtE a b) = comparison db place env a b
-inferExpr db place env (LtE a b) = comparison db place env a b
-inferExpr db place env (NotEq a b) = comparison db place env a b
+inferExpr db place env (Gt a b) = comparison OrdCapability db place env a b
+inferExpr db place env (Lt a b) = comparison OrdCapability db place env a b
+inferExpr db place env (Eq a b) = comparison EqCapability db place env a b
+inferExpr db place env (GtE a b) = comparison OrdCapability db place env a b
+inferExpr db place env (LtE a b) = comparison OrdCapability db place env a b
+inferExpr db place env (NotEq a b) = comparison EqCapability db place env a b
 inferExpr db place env (And a b) = boolean db place env a b
 inferExpr db place env (Or a b) = boolean db place env a b
 inferExpr db place env (IsNull a) = inferExpr db place env a >> Right (InferType CBool)
@@ -215,12 +221,15 @@ inferExpr db place env (InList a es _) = do
     mapM_ (itemType place ta) ts
     Right (InferType CBool)
 inferExpr _ _ _ (ExistsSub _ _) = Right (InferType CBool)
-inferExpr db place env (QuantCmp _ a sq q) = do
+inferExpr db place env (QuantCmp operator a sq q) = do
     ta <- inferExpr db place env a
     cols <- inferSubqueryOutput db env sq
     case cols of
         [(_, t)]
-            | compatible ta t -> Right (InferType CBool)
+            | compatible ta t -> do
+                let capability = if operator `elem` [CmpEq, CmpNe] then EqCapability else OrdCapability
+                mapM_ (requireCapability capability place) [ta, t]
+                Right (InferType CBool)
             | otherwise -> Left (place ++ ": " ++ quantLabel q ++ " subquery column has type " ++ renderType t ++ ", expected " ++ renderType ta)
         _ -> Left (place ++ ": " ++ quantLabel q ++ " subquery must return exactly one column")
 
@@ -241,7 +250,7 @@ inferSubqueryOutput _ _ BoundSubquery{} = Left "execution subquery cannot be use
 inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
     SelectDistinct q -> do
         columns <- inferSubqueryOutput db outerScope sq{subqueryStatement = q}
-        mapM_ (requireOrdering "DISTINCT" . snd) columns
+        mapM_ (requireHashing "DISTINCT" . snd) columns
         _ <- distinctOrdering q
         Right columns
     q@Select{selectItems = items} -> do
@@ -295,12 +304,14 @@ numericOperand place want other t = case t of
     _ -> Left (place ++ ": operator needs " ++ renderType want ++ " on both sides, got " ++ renderType other ++ " and " ++ renderType t)
 
 -- | 比较两边的类型检查
-comparison :: Database -> String -> Scope -> Expr -> Expr -> Either String InferredType
-comparison db place env a b = do
+comparison :: TypeCapability -> Database -> String -> Scope -> Expr -> Expr -> Either String InferredType
+comparison capability db place env a b = do
     ta <- inferExpr db place env a
     tb <- inferExpr db place env b
     if compatible ta tb
-        then Right (InferType CBool)
+        then do
+            mapM_ (requireCapability capability place) [ta, tb]
+            Right (InferType CBool)
         else Left (place ++ ": both sides of = must have the same type, got " ++ renderType ta ++ " and " ++ renderType tb)
 
 -- | 两类能不能比，类型族规则来自 Model
@@ -362,7 +373,8 @@ prepare db q = do
     let visible = filter (not . isDomainTable . fst) db
     resolved <- resolveStatement visible typed
     case resolved of
-        CreateDomain name base -> do
+        CreateDomain name (DomainDefinition column _) -> do
+            let base = columnType column
             checkDomainName name
             checkTypeParameters base
             case base of
@@ -373,6 +385,9 @@ prepare db q = do
             if any ((== domainTableName name) . fst) db
                 then Left ("domain already exists: " ++ name)
                 else Right ()
+        AlterDomain name _ -> do
+            _ <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
+            Right ()
         DropDomain name -> do
             _ <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
             if any (any (usesDomain name . columnType . snd) . tableCols . snd) db
@@ -418,7 +433,9 @@ ddlTargets statement = case statement of
 -- | 从 schema 解析列上的命名类型
 resolveDomainTypes :: Database -> Statement -> Either String Statement
 resolveDomainTypes db statement = case statement of
-    CreateDomain name base -> CreateDomain name <$> resolveDomainType base
+    CreateDomain name (DomainDefinition column checks) -> do
+        ty <- resolveDomainType (columnType column)
+        Right (CreateDomain name (DomainDefinition column{columnType = ty} checks))
     CreateTable name cols -> CreateTable name <$> mapM resolveColumnType cols
     AddColumn name col -> AddColumn name <$> resolveColumnType col
     AlterColumnType name col ty -> AlterColumnType name col <$> resolveDomainType ty
@@ -491,9 +508,11 @@ checkResolvedWith db outer q = case q of
             else Right ()
     CreateIndex tbl col -> do
         t <- lookupTable db tbl
-        if col `elem` tableCols' t
-            then checkRuntimeColumn "CREATE INDEX" (Scope (tableCols t) []) col
-            else Left ("CREATE INDEX: unknown column: " ++ col)
+        case lookup col (tableCols t) of
+            Nothing -> Left ("CREATE INDEX: unknown column: " ++ col)
+            Just column
+                | typeClassOf (columnType column) == RuntimeClass -> Left "CREATE INDEX: runtime index key encoding is not registered"
+                | otherwise -> Right ()
     DropIndex tbl col -> do
         t <- lookupTable db tbl
         if col `elem` tableCols' t
@@ -579,10 +598,12 @@ checkResolvedWith db outer q = case q of
     UseDatabase name -> checkDatabaseName name
     ShowDatabases -> Right ()
     CreateDomain{} -> Right ()
+    AlterDomain{} -> Right ()
     DropDomain{} -> Right ()
     ShowDomains -> Right ()
     -- \| 事务控制由会话层执行，语义层不做列检查
     BeginTransaction -> Right ()
+    BeginSerializableTransaction -> Right ()
     CommitTransaction -> Right ()
     RollbackTransaction -> Right ()
     -- \| 保存点名字只是会话层的记号，不做列检查
@@ -660,7 +681,7 @@ checkChecks columns = mapM_ checkOne
         Just text -> case parseExpression text of
             Left err -> Left ("CHECK: " ++ firstLine err)
             Right e -> void (prepareCheckExpression columns e)
-    -- | 只保留解析错误的第一行
+    -- \| 只保留解析错误的第一行
     firstLine = takeWhile (/= '\n')
 
 -- | 账号名上限
@@ -825,6 +846,21 @@ prepareCheckExpression columns expression = do
     checkBool [] "CHECK" (Scope columns []) resolved
     bindSlots (map fst columns) [] resolved
 
+-- | 在单值作用域规范化领域 VALUE 的大小写
+prepareDomainCheckExpression :: ColumnType -> Expr -> Either String Expr
+prepareDomainCheckExpression ty expression = do
+    checkNoAggregate "CHECK" expression
+    if hasSubquery expression then Left "CHECK: subqueries are not allowed here" else Right ()
+    let names = nub ("value" : colsInExpr expression)
+        columns = [(name, plainColumn ty) | name <- names, map toLower name == "value"]
+    resolved <- resolveExpr [] columns [] valueName expression
+    prepareCheckExpression [("value", plainColumn ty)] resolved
+  where
+    -- \| 领域条件只允许引用 VALUE
+    valueName name
+        | map toLower name == "value" = Right "value"
+        | otherwise = Left ("unknown column in DOMAIN CHECK: " ++ name)
+
 -- | 将推导类型转换为可空参数类型
 inferredArgument :: InferredType -> Maybe ColumnType
 inferredArgument InferNull = Nothing
@@ -856,8 +892,14 @@ statementColumns stmt = case stmt of
     SelectDistinct q -> statementColumns q
     Select items fromC mWhere groupBy having orderBy _ -> do
         ordering <- mapM (orderExpression items . fst) orderBy
-        Right (concatMap (colsInExpr . snd) items ++ fromColumns fromC
-            ++ concatMap colsInExpr mWhere ++ groupBy ++ concatMap colsInExpr having ++ concatMap colsInExpr ordering)
+        Right
+            ( concatMap (colsInExpr . snd) items
+                ++ fromColumns fromC
+                ++ concatMap colsInExpr mWhere
+                ++ groupBy
+                ++ concatMap colsInExpr having
+                ++ concatMap colsInExpr ordering
+            )
     _ -> Right []
   where
     -- \| 取 FROM 里出现的列
@@ -909,11 +951,12 @@ nameIn env place c = fst <$> columnAt place env c
 scopedColumnAt :: String -> [(String, Column)] -> EnclosingScopes -> String -> Either String (String, Column)
 scopedColumnAt place inner outer c
     | length (filter (== '.') c) == 1
-    , columns : _ <- filter ownsSource (inner : outer) = columnAt place columns c
+    , columns : _ <- filter ownsSource (inner : outer) =
+        columnAt place columns c
     | otherwise = scopeAt place (Scope inner outer) c
   where
     qualifier = takeWhile (/= '.') c ++ "."
-    -- | 判断当前层是否声明该来源限定名
+    -- \| 判断当前层是否声明该来源限定名
     ownsSource = any (isPrefixOf qualifier . fst)
 
 -- | 单表保留原表头，连接使用唯一前缀
@@ -927,18 +970,21 @@ checkOrder db env items column = do
     expression <- orderExpression items column
     void (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
 
--- | 校验列已有排序能力
-checkRuntimeColumn :: String -> Scope -> String -> Either String ()
-checkRuntimeColumn place env column = do
-    (_, definition) <- scopeAt place env column
-    void (requireOrdering place (InferType (columnType definition)))
-
--- | 拒绝尚未注册能力的复合类型
-requireOrdering :: String -> InferredType -> Either String InferredType
-requireOrdering place inferred@(InferType ty)
-    | typeClassOf ty == RuntimeClass = Left (place ++ ": runtime type capability is not registered")
+-- | 统一检查已注册能力并保留 NULL 传播
+requireCapability :: TypeCapability -> String -> InferredType -> Either String InferredType
+requireCapability capability place inferred@(InferType ty)
+    | not (hasTypeCapability capability ty) = Left (place ++ ": type capability is not registered: " ++ show capability)
     | otherwise = Right inferred
-requireOrdering _ inferred = Right inferred
+requireCapability _ _ inferred = Right inferred
+
+-- | 只允许已提供排序能力的类型
+requireOrdering :: String -> InferredType -> Either String InferredType
+requireOrdering = requireCapability OrdCapability
+
+-- | 分组与去重同时要求相等和哈希能力
+requireHashing :: String -> InferredType -> Either String InferredType
+requireHashing place inferred =
+    requireCapability EqCapability place inferred >> requireCapability HashCapability place inferred
 
 -- | 解析投影、条件、排序与连接引用
 resolveQuery :: Database -> EnclosingScopes -> Statement -> [(String, Expr)] -> Either String Statement
@@ -957,11 +1003,13 @@ resolveQuery db outer q items = do
         qualifiedReference c =
             qualifiedReferenceIn db (selectFrom q) c
                 || ( any
-                       (any
-                          (\ (key, _)
-                             -> length (filter (== '.') key) == 1
-                                  && ("." ++ key) `isSuffixOf` c))
-                       outer
+                        ( any
+                            ( \(key, _) ->
+                                length (filter (== '.') key) == 1
+                                    && ("." ++ key) `isSuffixOf` c
+                            )
+                        )
+                        outer
                         && (not (any (elem '.' . fst) db) || any (\(table, _) -> (table ++ ".") `isPrefixOf` c) db)
                    )
         -- \| 换算一个投影项：带别名时保留别名做输出列名
@@ -981,13 +1029,13 @@ resolveQuery db outer q items = do
     condition <- mapM (resolveExpr db env outer (name "WHERE")) (selectWhere q)
     grouping <- mapM (name "GROUP BY") (selectGroupBy q)
     having <- mapM (resolveExpr db env outer (name "HAVING")) (selectHaving q)
-    -- | 整项名称可用输出别名，复合表达式只查来源
+    -- \| 整项名称可用输出别名，复合表达式只查来源
     let orderKey key@(OrderColumn column)
             | column `elem` map fst projected = key <$ orderExpression projected key
             | otherwise = OrderColumn <$> name "ORDER BY" column
         orderKey key@(OrderPosition _) = key <$ orderPosition (length projected) key
         orderKey (OrderExpression expression) = OrderExpression <$> resolveExpr db env outer (name "ORDER BY") expression
-    ordering <- mapM (\(key, direction) -> (, direction) <$> orderKey key) (selectOrderBy q)
+    ordering <- mapM (\(key, direction) -> (,direction) <$> orderKey key) (selectOrderBy q)
     pure (Select projected source condition grouping having ordering (selectLimit q))
 
 -- | 收集没有别名遮蔽的来源表名

chusql-core/engine/src/ChuSQL/Core/Engine/Storage.hs

@@ -118,6 +118,10 @@ class (Monad m) => MonadStorage m where
     -- \| ALTER 用：整表换列定义与全部行
     replaceSchema :: String -> [(String, Column)] -> [Row] -> m (Either String ())
 
+    -- | 校验完整快照后原子修改领域定义
+    alterDomain :: String -> (Database -> Either String [(String, Column)]) -> m (Either String ())
+    alterDomain _ _ = pure (Left "atomic domain alteration is unavailable in this storage")
+
     -- \| 取全库快照（表名 + 列 + 全部行）
     snapshot :: m (Either String Database)
 

chusql-core/engine/src/ChuSQL/Core/Engine/Storage/IPC.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ChuSQL.Core.Engine.Storage.IPC (
@@ -29,10 +29,10 @@ module ChuSQL.Core.Engine.Storage.IPC (
     doDescribeTable,
     doDropTable,
     doListCatalog,
+    databaseSnapshot,
+    snapshotDatabase,
 ) where
 
-import Data.Foldable (for_)
-import Control.Monad (when)
 import ChuSQL.Core.Engine.Parallel (parallelShardLimit, poolRun, workerPool)
 import ChuSQL.Core.Engine.Storage
 import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest)
@@ -41,16 +41,43 @@ import ChuSQL.Core.Protocol (Account (..), Request (..), Response (..), SchemaCo
 import Control.Concurrent (getNumCapabilities)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, putMVar, readMVar, takeMVar, withMVar)
 import Control.Exception (bracket, mask_)
+import Control.Monad (when)
 import Data.Aeson (eitherDecodeStrict, encode)
 import Data.Aeson qualified as A
 import Data.Aeson.KeyMap qualified as KM
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BL
+import Data.Foldable (for_)
 import Data.Maybe (fromMaybe)
 import System.IO.Unsafe (unsafePerformIO)
 
 -- IPC 存储实现：把 MonadStorage 的操作变成发给存储库的 JSON 请求。
 
+-- 复用相同提交点的不可变快照版本。
+databaseSnapshot :: Maybe (String, Database) -> Env -> IO (Either String (String, Database))
+databaseSnapshot previous env = do
+    response <- ask env "database_snapshot" (ReqDatabaseSnapshot (fst <$> previous)) Just
+    pure $ case response of
+        Left err -> Left err
+        Right (RespSnapshotUnchanged checkpoint) -> case previous of
+            Just cached | fst cached == checkpoint -> Right cached
+            _ -> Left "snapshot version does not match cached database"
+        Right (RespDomainSnapshot infos rows checkpoint) -> do
+            db <- snapshotDatabase infos rows
+            Right (checkpoint, db)
+        Right (RespError err) -> Left err
+        _ -> Left "unexpected database snapshot response"
+
+-- 从同一版本的结构和行集构建引擎数据库。
+snapshotDatabase :: [TableInfo] -> [(String, [Row])] -> Either String Database
+snapshotDatabase infos rows = mapM load infos
+  where
+    -- 布局、对象身份与数据必须来自同一版本。
+    load info = do
+        values <- maybe (Left "incomplete database snapshot") Right (lookup (tiTable info) rows)
+        let name = tiTable info
+        Right (name, Table name (schemaToColumns (tiColumns info)) values (Just (metaOf info)) (tiIdentity info) (tiSchemaVersion info))
+
 -- | 一条会话的存储环境：当前库名随会话走，不共享
 data Env = Env
     { envDatabase :: Maybe String
@@ -146,15 +173,16 @@ closeConnection = modifyMVar_ linkRef $ \current -> withMVar (snd linkUsers) $ \
 -- | 发一条请求并解码应答；链路没装就报错，不崩
 sendRequest :: Request -> IO Response
 sendRequest req = withStorageLink $ \case
-                                      Nothing -> pure (RespError "storage not configured")
-                                      Just link
-                                        -> do raw <- slRequest link (BL.toStrict (encode req))
-                                              case raw of
-                                                Left e -> pure (RespError ("storage error: " ++ e))
-                                                Right bytes
-                                                  -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
-                                                       Left e -> pure (RespError ("decode error: " ++ e))
-                                                       Right resp -> pure resp
+    Nothing -> pure (RespError "storage not configured")
+    Just link ->
+        do
+            raw <- slRequest link (BL.toStrict (encode req))
+            case raw of
+                Left e -> pure (RespError ("storage error: " ++ e))
+                Right bytes ->
+                    case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
+                        Left e -> pure (RespError ("decode error: " ++ e))
+                        Right resp -> pure resp
 
 -- | 原样转发一条载荷给存储库
 sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString)
@@ -244,22 +272,22 @@ okOnly _ = Nothing
 -- | 发 Scan
 doScan :: Env -> String -> IO (Either String [Row])
 doScan env t = ask env "scan" (ReqScan t) $ \case
-                                              RespRows rows -> Just rows
-                                              _ -> Nothing
+    RespRows rows -> Just rows
+    _ -> Nothing
 
 -- | 发带投影的 Scan
 doScanColumns :: Env -> String -> [String] -> IO (Either String [Row])
 doScanColumns env t cols = ask env "scan" (ReqScanColumns t cols) $ \case
-                                                                      RespRows rows
-                                                                        -> Just
-                                                                             [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
-                                                                      _ -> Nothing
+    RespRows rows ->
+        Just
+            [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
+    _ -> Nothing
 
 -- | 发分片 Scan：只取第 shard 片
 doScanShard :: Env -> String -> Maybe [String] -> Int -> Int -> IO (Either String [Row])
 doScanShard env t cols shard shards = ask env "scan_shard" (ReqScanShard t cols shard shards) $ \case
-                                                                                                  RespRows rows -> Just rows
-                                                                                                  _ -> Nothing
+    RespRows rows -> Just rows
+    _ -> Nothing
 
 -- | 发 Insert（索引由存储层维护）
 doInsert :: Env -> String -> Row -> IO (Either String ())
@@ -276,21 +304,21 @@ doDeleteKeys env t ks = ask env "delete_keys" (ReqDeleteKeys t ks) okOnly
 -- | 发 ListTables
 doListTables :: Env -> IO (Either String [String])
 doListTables env = ask env "list_tables" ReqListTables $ \case
-                                                           RespTables ts -> Just ts
-                                                           _ -> Nothing
+    RespTables ts -> Just ts
+    _ -> Nothing
 
 -- | 一次拿全库 schema
 doListCatalog :: Env -> IO (Either String [TableInfo])
 doListCatalog env = ask env "list_catalog" ReqListCatalog $ \case
-                                                              RespCatalog xs -> Just xs
-                                                              _ -> Nothing
+    RespCatalog xs -> Just xs
+    _ -> Nothing
 
 -- | 按某一列的索引取一行（键可以是整数或字符串）
 doLookupByColumn :: Env -> String -> String -> Value -> IO (Either String IndexResult)
 doLookupByColumn env t c k = ask env "lookup_by_index" (ReqLookupByColumn t c k) $ \case
-                                                                                     RespRows rows -> Just (IndexRows rows)
-                                                                                     RespNoIndex -> Just NoIndex
-                                                                                     _ -> Nothing
+    RespRows rows -> Just (IndexRows rows)
+    RespNoIndex -> Just NoIndex
+    _ -> Nothing
 
 -- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
 doScanRange ::
@@ -301,15 +329,15 @@ doScanRange ::
     Maybe (Value, Bool) ->
     IO (Either String (Maybe [Row]))
 doScanRange env t c lo hi = ask env "range_by_index" (ReqRangeByIndex t c lo hi) $ \case
-                                                                                     RespRows rows -> Just (Just rows)
-                                                                                     RespNoIndex -> Just Nothing
-                                                                                     _ -> Nothing
+    RespRows rows -> Just (Just rows)
+    RespNoIndex -> Just Nothing
+    _ -> Nothing
 
 -- | 发 DescribeTable
 doDescribeTable :: Env -> String -> IO (Either String TableInfo)
 doDescribeTable env t = ask env "describe_table" (ReqDescribeTable t) $ \case
-                                                                          RespSchema info -> Just info
-                                                                          _ -> Nothing
+    RespSchema info -> Just info
+    _ -> Nothing
 
 -- | 发 DropTable
 doDropTable :: Env -> String -> IO (Either String ())
@@ -353,7 +381,7 @@ instance MonadStorage IPCStorage where
     withSchemaGuard dependencies action = IPCStorage $ \env ->
         runIPCStorageIn action env{envSchemaGuard = Just dependencies}
 
-    -- | 写前握手，旧存储不能先写入后才报错
+    -- \| 写前握手，旧存储不能先写入后才报错
     withWriteSchemaGuard dependencies action = IPCStorage $ \env -> case dependencies of
         [] -> pure (Left "bound write requires a target schema guard")
         (target, _) : _ -> do
@@ -374,8 +402,8 @@ instance MonadStorage IPCStorage where
 
     -- \| 列出现有库
     listDatabases = IPCStorage $ \env -> ask env "list_databases" (ReqDatabase "list_databases" "") $ \case
-                                                                                                        RespTables names -> Just names
-                                                                                                        _ -> Nothing
+        RespTables names -> Just names
+        _ -> Nothing
 
     -- \| 发 Scan
     scan t = IPCStorage (`doScan` t)
@@ -430,30 +458,31 @@ instance MonadStorage IPCStorage where
     -- \| 删一列
     dropColumn t c = IPCStorage $ \env -> ask env "drop_column" (ReqDropColumn t c) okOnly
 
-    -- \| 列表 + 逐表扫描拼库
-    snapshot = IPCStorage $ \env -> do
-        result <- doListCatalog env
-        case result of
+    -- \| 校验一致快照并复查提交点后发布领域
+    alterDomain name validate = IPCStorage $ \env -> do
+        snapshotResult <- ask env "domain_snapshot" ReqDomainSnapshot $ \case
+            RespDomainSnapshot infos rows checkpoint -> Just (infos, rows, checkpoint)
+            _ -> Nothing
+        case snapshotResult of
             Left err -> pure (Left err)
-            Right xs -> fmap sequence (mapM (loadEntry env) xs)
+            Right (infos, rows, checkpoint) -> case mapM (loadDomainEntry rows) infos >>= validate of
+                Left err -> pure (Left err)
+                Right cols -> ask env "alter_domain" (ReqAlterDomain name (map toWire cols) checkpoint) okOnly
       where
-        -- \| 读取表数据并保留扫描错误
-        loadEntry env info = do
-            rows <- doScan env (tiTable info)
-            pure $
-                fmap
-                    ( \rs ->
-                        ( tiTable info
-                        , Table (tiTable info) (schemaToColumns (tiColumns info)) rs (Just (metaOf info)) (tiIdentity info) (tiSchemaVersion info)
-                        )
-                    )
-                    rows
+        -- \| 保留快照身份并拒绝缺失的表数据
+        loadDomainEntry rows info = do
+            values <- maybe (Left "incomplete domain snapshot") Right (lookup (tiTable info) rows)
+            let key = tiTable info
+            Right (key, Table key (schemaToColumns (tiColumns info)) values (Just (metaOf info)) (tiIdentity info) (tiSchemaVersion info))
+
+    -- 在存储读门内获取同一版本的完整快照。
+    snapshot = IPCStorage $ \env -> fmap (fmap snd) (databaseSnapshot Nothing env)
 
     -- \| 只问数据字典要结构，设了当前库只留它的表
     schema = IPCStorage $ \env -> do
         result <- ask env "all_catalogs" ReqAllCatalog $ \case
-                                                           RespCatalog infos -> Just infos
-                                                           _ -> Nothing
+            RespCatalog infos -> Just infos
+            _ -> Nothing
         pure (fmap (concatMap (visibleTables (envDatabase env))) result)
 
 -- | 线上表信息转引擎侧统计

chusql-core/engine/src/ChuSQL/Core/Engine/Storage/Memory.hs

@@ -30,7 +30,7 @@ instance MonadStorage MemoryStorage where
     -- \| 纯状态视图在求值期间不受外部修改
     withSchemaGuard _ action = action
 
-    -- | 纯状态写入不受外部结构变更影响
+    -- \| 纯状态写入不受外部结构变更影响
     withWriteSchemaGuard _ action = action
 
     -- \| 全表扫描
@@ -81,6 +81,11 @@ instance MonadStorage MemoryStorage where
                                 db
                             )
 
+    -- \| 在同一状态转换内校验并发布领域
+    alterDomain name validate = MemoryStorage $ \db -> case validate db of
+        Left err -> Right (Left err, db)
+        Right cols -> runMemoryStorage (replaceSchema name cols []) db
+
     -- \| 原样返回当前库
     snapshot = MemoryStorage $ \db -> Right (Right db, db)
 

chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/AST.hs

@@ -1,15 +1,26 @@
-module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), OrderKey (..), makeSelect, distinctOrdering, orderPosition, orderExpression, orderKeyExpression) where
+module ChuSQL.Core.Engine.Syntax.AST (Statement (..), DomainDefinition (..), DomainAlter (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), OrderKey (..), makeSelect, distinctOrdering, orderPosition, orderExpression, orderKeyExpression) where
 
-import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
-import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue)
 import ChuSQL.Core.Engine.Runtime.Functions (FunctionId)
+import ChuSQL.Core.Engine.Runtime.Types (RuntimeValue, TypeExpr, TypeId)
+import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
 
 -- 语法树：语句、数据来源、条件表达式、排序方向。
 
+-- | 领域的基础列属性及具名检查条件
+data DomainDefinition = DomainDefinition Column [(String, String)] deriving (Show, Eq)
+
+-- | 领域约束及默认值的结构变更
+data DomainAlter
+    = DomainDefault (Maybe Value)
+    | DomainNullable Bool
+    | DomainAddCheck (Maybe String) String
+    | DomainDropCheck String
+    deriving (Show, Eq)
+
 data Statement
     = Select
-        -- | 输出名称与投影表达式，普通列用 Col
         { selectItems :: [(String, Expr)]
+        -- ^ 输出名称与投影表达式，普通列用 Col
         , selectFrom :: FromClause
         , selectWhere :: Maybe Expr
         , selectGroupBy :: [String]
@@ -22,7 +33,8 @@ data Statement
     | Delete String (Maybe Expr)
     | Update String [(String, Expr)] (Maybe Expr)
     | CreateTable String [(String, Column)]
-    | CreateDomain String ColumnType
+    | CreateDomain String DomainDefinition
+    | AlterDomain String DomainAlter
     | DropDomain String
     | ShowDomains
     | DropTable String
@@ -40,35 +52,37 @@ data Statement
     | ShowGrants
     | ShowRoles
     | DropUser String
-    -- | 新角色：权限的载体，用户靠成员资格继承它的权限
-    | CreateRole String
-    -- | 删角色：连同它的授权与成员一起删
-    | DropRole String
-    -- | GRANT 权限 ON 表 TO 角色，末位表示带 WITH GRANT OPTION
-    | GrantPrivileges [String] String String Bool
-    -- | REVOKE 权限 ON 表 FROM 角色
-    | RevokePrivileges [String] String String
+    | -- | 新角色：权限的载体，用户靠成员资格继承它的权限
+      CreateRole String
+    | -- | 删角色：连同它的授权与成员一起删
+      DropRole String
+    | -- | GRANT 权限 ON 表 TO 角色，末位表示带 WITH GRANT OPTION
+      GrantPrivileges [String] String String Bool
+    | -- | REVOKE 权限 ON 表 FROM 角色
+      RevokePrivileges [String] String String
     | RevokeGrantOption [String] String String
-    -- | GRANT 角色 TO 用户：给用户加角色
-    | GrantRole String [String]
-    -- | REVOKE <角色> FROM <用户>[, ...]
-    | RevokeRole String [String]
+    | -- | GRANT 角色 TO 用户：给用户加角色
+      GrantRole String [String]
+    | -- | REVOKE <角色> FROM <用户>[, ...]
+      RevokeRole String [String]
     | CreateDatabase String
     | DropDatabase String
     | UseDatabase String
     | ShowDatabases
-    -- | 开事务：BEGIN / START TRANSACTION
-    | BeginTransaction
-    -- | 提交事务
-    | CommitTransaction
-    -- | 回滚事务
-    | RollbackTransaction
-    -- | 建保存点：SAVEPOINT 名字
-    | Savepoint String
-    -- | 回滚到保存点：ROLLBACK TO [SAVEPOINT] 名字
-    | RollbackToSavepoint String
-    -- | 释放保存点：RELEASE [SAVEPOINT] 名字
-    | ReleaseSavepoint String
+    | -- | 开事务：BEGIN / START TRANSACTION
+      BeginTransaction
+    | -- | 串行化快照事务
+      BeginSerializableTransaction
+    | -- | 提交事务
+      CommitTransaction
+    | -- | 回滚事务
+      RollbackTransaction
+    | -- | 建保存点：SAVEPOINT 名字
+      Savepoint String
+    | -- | 回滚到保存点：ROLLBACK TO [SAVEPOINT] 名字
+      RollbackToSavepoint String
+    | -- | 释放保存点：RELEASE [SAVEPOINT] 名字
+      ReleaseSavepoint String
     deriving (Show, Eq)
 
 -- | 连接类型：内连接与左外连接
@@ -86,15 +100,16 @@ data FromClause
     deriving (Show, Eq)
 
 -- | 子查询：语句，加上它对外层列的引用（自由变量，语义检查时填）
-data Subquery = Subquery
-    { subqueryStatement :: Statement
-    , subqueryRefs :: [String]
-    }
+data Subquery
+    = Subquery
+        { subqueryStatement :: Statement
+        , subqueryRefs :: [String]
+        }
     | BoundSubquery
-    { subqueryStatement :: Statement
-    , subqueryRefs :: [String]
-    , subquerySlots :: [(String, Expr)]
-    }
+        { subqueryStatement :: Statement
+        , subqueryRefs :: [String]
+        , subquerySlots :: [(String, Expr)]
+        }
     deriving (Show, Eq)
 
 -- | 量词：ANY 至少一行成立，ALL 每一行都成立
@@ -219,9 +234,9 @@ resolveDistinctOrdering :: Statement -> Either String [(OrderKey, SortDir)]
 resolveDistinctOrdering q = mapM resolve (selectOrderBy q)
   where
     items = case q of
-        Select { selectItems = projected } -> projected
+        Select{selectItems = projected} -> projected
         _ -> []
-    -- | 排序键必须出现在去重结果中
+    -- \| 排序键必须出现在去重结果中
     resolve (key, direction) = do
         position <- orderPosition (length items) key
         case position of
@@ -230,7 +245,7 @@ resolveDistinctOrdering q = mapM resolve (selectOrderBy q)
                 [slot] -> Right (OrderPosition slot, direction)
                 [] -> Left "DISTINCT: ORDER BY column must appear in the select list"
                 _ -> Left "DISTINCT: ambiguous ORDER BY column"
-    -- | 名称或完整表达式必须对应去重输出项
+    -- \| 名称或完整表达式必须对应去重输出项
     matches (OrderColumn column) label expression = label == column || expression == Col column
     matches (OrderExpression key) _ expression = key == expression
     matches (OrderPosition _) _ _ = False

chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/Parser.hs

@@ -1,16 +1,16 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE TupleSections #-}
 
 module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
 
-import Data.Functor (($>))
-import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
 import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode)
-import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Runtime.Types
+import ChuSQL.Core.Engine.Syntax.AST
+import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
 import Control.Monad (void)
 import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
 import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
+import Data.Functor (($>))
 import Data.List (intercalate, isInfixOf)
 import Data.Maybe (fromMaybe)
 import Data.Void (Void)
@@ -115,8 +115,9 @@ operatorTable =
     [ [Prefix (Neg <$ symbol "-")]
     , [InfixL (Mul <$ symbol "*"), InfixL (Div <$ symbol "/")]
     , [InfixL (Add <$ symbol "+"), InfixL (Sub <$ symbol "-")]
-    , [ InfixN comparisonOp ]
-    , [ Postfix inPredicate
+    , [InfixN comparisonOp]
+    ,
+        [ Postfix inPredicate
         , Postfix (try quantifiedCmp)
         , Postfix (IsNotNull <$ try (keyword "is" *> keyword "not" *> keyword "null"))
         , Postfix (IsNull <$ (keyword "is" *> keyword "null"))
@@ -210,22 +211,29 @@ subquerySelect = Subquery <$> queryStatement <*> pure []
 -- | 读取带具体类型参数的构造器
 constructorCall :: Parser Expr
 constructorCall = do
-    cid <- (TypeConstructorId 5 <$ keyword "list") <|> (TypeConstructorId 6 <$ keyword "maybe")
-        <|> (TypeConstructorId 7 <$ keyword "tuple")
+    cid <-
+        (TypeConstructorId 5 <$ keyword "list")
+            <|> (TypeConstructorId 6 <$ keyword "maybe")
+            <|> (TypeConstructorId 7 <$ keyword "tuple")
     arguments <- between (symbol "<") (symbol ">") (sepBy runtimeTypeP (symbol ","))
     values <- between (symbol "(") (symbol ")") (sepBy expr (symbol ","))
     pure (Construct (TypeApply cid arguments) values)
 
 -- | 解析运行时逻辑类型语法
 runtimeTypeP :: Parser TypeExpr
-runtimeTypeP = choice
-    [ intType <$ keyword "int", doubleType <$ keyword "double", boolType <$ keyword "bool"
-    , stringType <$ keyword "string", stringType <$ keyword "str", stringType <$ keyword "text"
-    , listType <$> between (symbol "[") (symbol "]") runtimeTypeP
-    , listType <$> (keyword "list" *> runtimeTypeP)
-    , maybeType <$> (keyword "maybe" *> runtimeTypeP)
-    , tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
-    ]
+runtimeTypeP =
+    choice
+        [ intType <$ keyword "int"
+        , doubleType <$ keyword "double"
+        , boolType <$ keyword "bool"
+        , stringType <$ keyword "string"
+        , stringType <$ keyword "str"
+        , stringType <$ keyword "text"
+        , listType <$> between (symbol "[") (symbol "]") runtimeTypeP
+        , listType <$> (keyword "list" *> runtimeTypeP)
+        , maybeType <$> (keyword "maybe" *> runtimeTypeP)
+        , tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
+        ]
 
 -- | 读取待绑定的标量函数调用
 scalarFunctionCall :: Parser Expr
@@ -238,11 +246,11 @@ scalarFunctionCall = do
 aggregateCall :: Parser Expr
 aggregateCall = choice (countAll : map named builtinNames)
   where
-    -- | COUNT(*)，没有参数
+    -- \| COUNT(*)，没有参数
     countAll = CountAll <$ try (keyword (builtinName BCountAll) *> between (symbol "(") (symbol ")") (symbol "*"))
-    -- | 表里每一个带参数的内置函数
+    -- \| 表里每一个带参数的内置函数
     named (name, builtin) = builtinNode builtin <$> aggArg name
-    -- | 读聚合函数的参数
+    -- \| 读聚合函数的参数
     aggArg name = try (keyword name *> between (symbol "(") (symbol ")") expr)
 
 -- | 只认字面量，给 DEFAULT 用
@@ -252,14 +260,11 @@ literalValue =
         [ VNull <$ keyword "null"
         , VBool True <$ keyword "TRUE"
         , VBool False <$ keyword "FALSE"
-        , try (negateLit <$> floatLit)
+        , try (symbol "-" *> (VFloat . negate <$> try floatLit <|> VInt . negate <$> integer))
+        , try (VFloat <$> floatLit)
         , VInt <$> integer
-        , VFloat <$> try floatLit
         , VStr <$> stringLit
         ]
-  where
-    -- | 负浮点字面量
-    negateLit d = VFloat (negate d)
 
 -- | 一个排序键：输出序号、列名或表达式
 orderItem :: Parser (OrderKey, SortDir)
@@ -365,8 +370,10 @@ tableRef = do
 -- | 连接类型：内连接 / 左外连接
 joinKind :: Parser JoinKind
 joinKind =
-    try ((keyword "left" *> optional (keyword "outer") *> keyword "join")
-           $> LeftJoin)
+    try
+        ( (keyword "left" *> optional (keyword "outer") *> keyword "join")
+            $> LeftJoin
+        )
         <|> try ((keyword "inner" *> keyword "join") $> InnerJoin)
         <|> (keyword "join" $> InnerJoin)
 
@@ -430,9 +437,10 @@ createTableStatement = do
 
 -- | 读 DROP TABLE
 dropTableStatement :: Parser Statement
-dropTableStatement = do keyword "drop"
-                        keyword "table"
-                        DropTable <$> tableName
+dropTableStatement = do
+    keyword "drop"
+    keyword "table"
+    DropTable <$> tableName
 
 -- | 读 CREATE INDEX（列名即索引名）
 createIndexStatement :: Parser Statement
@@ -491,10 +499,11 @@ alterTableStatement = do
 
 -- | 读 CREATE USER，口令是明文
 createUserStatement :: Parser Statement
-createUserStatement = do keyword "create"
-                         keyword "user"
-                         name <- userName
-                         CreateUser name <$> identifiedBy
+createUserStatement = do
+    keyword "create"
+    keyword "user"
+    name <- userName
+    CreateUser name <$> identifiedBy
 
 -- | 读 IDENTIFIED BY '口令'
 identifiedBy :: Parser String
@@ -513,15 +522,19 @@ alterUserStatement = do
 
 -- | 读身份属性开关
 identityAttribute :: Parser (String, Bool)
-identityAttribute = choice
-    [ ("allow_sudo_auth", True) <$ keyword "allow_sudo_auth"
-    , ("allow_sudo_auth", False) <$ keyword "noallow_sudo_auth"
-    , ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
-    , ("system_catalog_manager", False) <$ keyword "nosystem_catalog_manager"
-    , ("login", True) <$ keyword "login", ("login", False) <$ keyword "nologin"
-    , ("superuser", True) <$ keyword "superuser", ("superuser", False) <$ keyword "nosuperuser"
-    , ("enabled", True) <$ keyword "enabled", ("enabled", False) <$ keyword "disabled"
-    ]
+identityAttribute =
+    choice
+        [ ("allow_sudo_auth", True) <$ keyword "allow_sudo_auth"
+        , ("allow_sudo_auth", False) <$ keyword "noallow_sudo_auth"
+        , ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
+        , ("system_catalog_manager", False) <$ keyword "nosystem_catalog_manager"
+        , ("login", True) <$ keyword "login"
+        , ("login", False) <$ keyword "nologin"
+        , ("superuser", True) <$ keyword "superuser"
+        , ("superuser", False) <$ keyword "nosuperuser"
+        , ("enabled", True) <$ keyword "enabled"
+        , ("enabled", False) <$ keyword "disabled"
+        ]
 
 -- | 读 ALTER ROLE 属性或口令
 alterRoleStatement :: Parser Statement
@@ -533,9 +546,10 @@ alterRoleStatement = do
 
 -- | 读 DROP USER
 dropUserStatement :: Parser Statement
-dropUserStatement = do keyword "drop"
-                       keyword "user"
-                       DropUser <$> userName
+dropUserStatement = do
+    keyword "drop"
+    keyword "user"
+    DropUser <$> userName
 
 -- | 读 CREATE ROLE
 createRoleStatement :: Parser Statement
@@ -566,9 +580,11 @@ privilegeName =
 
 -- | ON 后面的授权对象：* 或一张表
 grantObject :: Parser String
-grantObject = try (("database:" ++) <$> (keyword "database" *> identifier))
-    <|> try ((++ ".*") <$> (identifier <* symbol "." <* symbol "*"))
-    <|> ("*" <$ symbol "*") <|> (optional (keyword "table") *> tableName)
+grantObject =
+    try (("database:" ++) <$> (keyword "database" *> identifier))
+        <|> try ((++ ".*") <$> (identifier <* symbol "." <* symbol "*"))
+        <|> ("*" <$ symbol "*")
+        <|> (optional (keyword "table") *> tableName)
 
 -- | 可选的 WITH GRANT OPTION
 grantOption :: Parser Bool
@@ -603,6 +619,64 @@ revokeStatement = do
         , if optionOnly then fail "GRANT OPTION FOR requires object privileges" else RevokeRole <$> userName <*> (keyword "from" *> sepBy1 userName (symbol ","))
         ]
 
+-- | 读取领域及其独立约束
+createDomainStatement :: Parser Statement
+createDomainStatement = do
+    name <- keyword "create" *> keyword "domain" *> identifier
+    ty <- keyword "as" *> columnTypeP
+    modifiers <- many domainConstraint
+    pure (CreateDomain name (foldl (flip ($)) (DomainDefinition (plainColumn ty) []) modifiers))
+
+-- | 读取领域属性或 CHECK 条件
+domainConstraint :: Parser (DomainDefinition -> DomainDefinition)
+domainConstraint =
+    choice
+        [ try (keyword "not" *> keyword "null") $> domainNull False
+        , keyword "null" $> domainNull True
+        , keyword "default" *> (domainDefault . Just <$> literalValue)
+        , do
+            name <- optional (keyword "constraint" *> identifier)
+            text <- keyword "check" *> checkText
+            pure (domainCheck (fromMaybe "" name) text)
+        ]
+
+-- | 设置领域非空声明
+domainNull :: Bool -> DomainDefinition -> DomainDefinition
+domainNull nullable (DomainDefinition column checks) = DomainDefinition column{columnNullable = nullable} checks
+
+-- | 设置领域默认值
+domainDefault :: Maybe Value -> DomainDefinition -> DomainDefinition
+domainDefault value (DomainDefinition column checks) = DomainDefinition column{columnDefault = value} checks
+
+-- | 增加领域检查条件
+domainCheck :: String -> String -> DomainDefinition -> DomainDefinition
+domainCheck name text (DomainDefinition column checks) = DomainDefinition column (checks ++ [(name, text)])
+
+-- | 读取领域约束与默认值变更
+alterDomainStatement :: Parser Statement
+alterDomainStatement = do
+    name <- keyword "alter" *> keyword "domain" *> identifier
+    action <-
+        choice
+            [ keyword "set"
+                *> choice
+                    [ DomainDefault . Just <$> (keyword "default" *> literalValue)
+                    , DomainNullable False <$ (keyword "not" *> keyword "null")
+                    ]
+            , keyword "drop"
+                *> choice
+                    [ DomainDefault Nothing <$ keyword "default"
+                    , DomainNullable True <$ (keyword "not" *> keyword "null")
+                    , DomainDropCheck <$> (keyword "constraint" *> identifier)
+                    ]
+            , keyword "add"
+                *> ( DomainAddCheck
+                        <$> optional (keyword "constraint" *> identifier)
+                        <*> (keyword "check" *> checkText)
+                   )
+            ]
+    pure (AlterDomain name action)
+
 -- | 建表时的一列：类型后面跟若干约束
 columnDef :: Parser (String, Column)
 columnDef = do
@@ -615,18 +689,24 @@ columnDef = do
 columnConstraint :: Parser (Column -> Column)
 columnConstraint =
     choice
-        [ try ((keyword "not" *> keyword "null")
-                 $> (\ c -> c {columnNullable = False}))
-        , keyword "null" $> (\ c -> c {columnNullable = True})
+        [ try
+            ( (keyword "not" *> keyword "null")
+                $> (\c -> c{columnNullable = False})
+            )
+        , keyword "null" $> (\c -> c{columnNullable = True})
         , keyword "auto_increment"
-            $>
-              (\ c -> c {columnAutoIncrement = True, columnNullable = False})
-        , try ((keyword "primary" *> keyword "key")
-                 $>
-                   (\ c
-                      -> c {columnPrimaryKey = True, columnUnique = True,
-                            columnNullable = False}))
-        , keyword "unique" $> (\ c -> c {columnUnique = True})
+            $> (\c -> c{columnAutoIncrement = True, columnNullable = False})
+        , try
+            ( (keyword "primary" *> keyword "key")
+                $> ( \c ->
+                        c
+                            { columnPrimaryKey = True
+                            , columnUnique = True
+                            , columnNullable = False
+                            }
+                   )
+            )
+        , keyword "unique" $> (\c -> c{columnUnique = True})
         , keyword "default" *> ((\v c -> c{columnDefault = Just v}) <$> literalValue)
         , keyword "check" *> ((\s c -> c{columnCheck = Just s}) <$> checkText)
         ]
@@ -669,13 +749,14 @@ columnTypeP =
 -- | 解析复合列的稳定类型身份
 runtimeColumnType :: Parser ColumnType
 runtimeColumnType = do
-    expression <- choice
-        [ listType <$> between (symbol "[") (symbol "]") runtimeTypeP
-        , listType <$> (keyword "list" *> runtimeTypeP)
-        , maybeType <$> (keyword "maybe" *> runtimeTypeP)
-        , tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
-        , stringType <$ keyword "string"
-        ]
+    expression <-
+        choice
+            [ listType <$> between (symbol "[") (symbol "]") runtimeTypeP
+            , listType <$> (keyword "list" *> runtimeTypeP)
+            , maybeType <$> (keyword "maybe" *> runtimeTypeP)
+            , tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
+            , stringType <$ keyword "string"
+            ]
     case resolveType builtinTypes expression of
         Left err -> fail err
         Right descriptor -> pure (CRuntime (descriptorId descriptor))
@@ -734,7 +815,7 @@ queryStatement = withStatement <|> selectStatement
 expandWith :: [(String, [String], Statement)] -> Statement -> Either String Statement
 expandWith defs main = go [] defs
   where
-    -- | 前面的 CTE 已进环境，接着展开本体
+    -- \| 前面的 CTE 已进环境，接着展开本体
     go env [] = expandStatement env main
     go env ((name, cols, body) : rest) = do
         body' <- expandStatement env body
@@ -749,14 +830,15 @@ cteKey = map toLower
 renameColumns :: String -> [String] -> Statement -> Either String Statement
 renameColumns _ [] q = Right q
 renameColumns name cols (SelectDistinct q) = SelectDistinct <$> renameColumns name cols q
-renameColumns name cols q@Select { selectItems = items } = do
+renameColumns name cols q@Select{selectItems = items} = do
     checkCteArity name cols (map snd items)
-    ordering <- if all (\(label, expression) -> expression == Col label) items
-        then Right (selectOrderBy q)
-        else mapM renameOrder (selectOrderBy q)
-    Right q { selectItems = zip cols (map snd items), selectOrderBy = ordering }
+    ordering <-
+        if all (\(columnName, expression) -> expression == Col columnName) items
+            then Right (selectOrderBy q)
+            else mapM renameOrder (selectOrderBy q)
+    Right q{selectItems = zip cols (map snd items), selectOrderBy = ordering}
   where
-    -- | 列清单同步改写内层排序输出别名
+    -- \| 列清单同步改写内层排序输出别名
     renameOrder (OrderColumn column, direction) = case [new | ((old, _), new) <- zip items cols, old == column] of
         [] -> Right (OrderColumn column, direction)
         [new] -> Right (OrderColumn new, direction)
@@ -774,16 +856,16 @@ checkCteArity name cols out
 expandStatement :: [(String, Statement)] -> Statement -> Either String Statement
 expandStatement env stmt = case stmt of
     SelectDistinct q -> SelectDistinct <$> expandStatement env q
-    q@Select { selectFrom = fromC, selectItems = items, selectWhere = mWhere } -> do
+    q@Select{selectFrom = fromC, selectItems = items, selectWhere = mWhere} -> do
         fromC' <- expandClause env fromC
         items' <- traverse (\(name, e) -> fmap (name,) (expandExpr env e)) items
         w <- traverse (expandExpr env) mWhere
         having <- traverse (expandExpr env) (selectHaving q)
         ordering <- mapM expandOrder (selectOrderBy q)
-        Right q { selectFrom = fromC', selectItems = items', selectWhere = w, selectHaving = having, selectOrderBy = ordering }
+        Right q{selectFrom = fromC', selectItems = items', selectWhere = w, selectHaving = having, selectOrderBy = ordering}
     _ -> Right stmt
   where
-    -- | 展开排序表达式中的 CTE 子查询
+    -- \| 展开排序表达式中的 CTE 子查询
     expandOrder (OrderExpression expression, direction) = (,) . OrderExpression <$> expandExpr env expression <*> pure direction
     expandOrder ordering = Right ordering
 
@@ -832,10 +914,10 @@ expandExpr env e = case e of
     QuantCmp op x sq q -> (\x' sq' -> QuantCmp op x' sq' q) <$> go x <*> goSub sq
     _ -> Right e
   where
-    -- | 继续看子表达式
+    -- \| 继续看子表达式
     go = expandExpr env
-    -- | 继续看子查询里的语句
-    goSub sq = (\stmt -> sq { subqueryStatement = stmt }) <$> expandStatement env (subqueryStatement sq)
+    -- \| 继续看子查询里的语句
+    goSub sq = (\stmt -> sq{subqueryStatement = stmt}) <$> expandStatement env (subqueryStatement sq)
 
 -- | 读 INSERT，可一次插多行
 insertStatement :: Parser Statement
@@ -878,15 +960,18 @@ updateStatement = do
 -- | 事务控制语句
 transactionStatement :: Parser Statement
 transactionStatement =
-    try (BeginTransaction <$ (keyword "start" *> keyword "transaction"))
-        <|> (BeginTransaction <$ (keyword "begin" *> optional (keyword "transaction")))
+    (beginMode =<< (try (keyword "start" *> keyword "transaction") <|> (keyword "begin" *> void (optional (keyword "transaction")))))
         <|> (CommitTransaction <$ (keyword "commit" *> optional (keyword "transaction")))
         <|> try (RollbackToSavepoint <$> rollbackToName)
         <|> (RollbackTransaction <$ (keyword "rollback" *> optional (keyword "transaction")))
         <|> (Savepoint <$> (keyword "savepoint" *> identifier))
         <|> (ReleaseSavepoint <$> (keyword "release" *> optional (keyword "savepoint") *> identifier))
   where
-    -- | ROLLBACK TO [SAVEPOINT] 名字
+    -- 解析可选的串行化隔离级别。
+    beginMode _ = do
+        mode <- optional (keyword "isolation" *> keyword "level" *> keyword "serializable")
+        pure (maybe BeginTransaction (const BeginSerializableTransaction) mode)
+    -- \| ROLLBACK TO [SAVEPOINT] 名字
     rollbackToName =
         keyword "rollback" *> keyword "to" *> optional (keyword "savepoint") *> identifier
 
@@ -897,7 +982,7 @@ parseStatement input =
         Left err -> Left (safeParseError input err)
         Right q -> Right q
   where
-    -- | 按关键字分派到各语句解析器
+    -- \| 按关键字分派到各语句解析器
     statementP =
         withStatement
             <|> transactionStatement
@@ -907,7 +992,8 @@ parseStatement input =
             <|> (UseDatabase <$> (keyword "use" *> identifier))
             <|> try (ShowDatabases <$ (keyword "show" *> keyword "databases"))
             <|> try (ShowDomains <$ (keyword "show" *> keyword "domains"))
-            <|> try (CreateDomain <$> (keyword "create" *> keyword "domain" *> identifier) <*> (keyword "as" *> columnTypeP))
+            <|> try createDomainStatement
+            <|> try alterDomainStatement
             <|> try (DropDomain <$> (keyword "drop" *> keyword "domain" *> identifier))
             <|> insertStatement
             <|> deleteStatement

chusql-core/engine/test/NormalizationSpec.hs

@@ -19,49 +19,87 @@ spec = do
                 `shouldBe` True
             attributeClosure [] ["a"] `shouldBe` ["a"]
         it "accepts BCNF with a declared key" $ do
-            fmap (map verdict . findings) (analyzeNormalization schema
-                (Declaration [["a"]] [] True (Just True)))
+            fmap
+                (map verdict . findings)
+                ( analyzeNormalization
+                    schema
+                    (Declaration [["a"]] [] True (Just True))
+                )
                 `shouldBe` Right (replicate 4 Satisfied)
         it "detects partial dependencies of composite keys" $ do
-            fmap (map verdict . findings) (analyzeNormalization schema
-                (Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True)))
+            fmap
+                (map verdict . findings)
+                ( analyzeNormalization
+                    schema
+                    (Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True))
+                )
                 `shouldBe` Right [Satisfied, Violated, Violated, Violated]
         it "detects transitive dependencies and a preserving split" $ do
-            let analysis = analyzeNormalization schema
-                    (Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True))
+            let analysis =
+                    analyzeNormalization
+                        schema
+                        (Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True))
             fmap (map verdict . findings) analysis
                 `shouldBe` Right [Satisfied, Satisfied, Violated, Violated]
             fmap suggestions analysis
                 `shouldBe` Right [Decomposition [["b", "c"], ["a", "b"]] Satisfied Satisfied]
         it "distinguishes 3NF from BCNF and detects dependency loss" $ do
-            let analysis = analyzeNormalization schema
-                    (Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True))
+            let analysis =
+                    analyzeNormalization
+                        schema
+                        (Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True))
             fmap (map verdict . findings) analysis
                 `shouldBe` Right [Satisfied, Satisfied, Satisfied, Violated]
             fmap suggestions analysis
                 `shouldBe` Right [Decomposition [["b", "c"], ["a", "c"]] Satisfied Violated]
         it "does not certify incomplete dependencies" $ do
-            fmap (map verdict . findings) (analyzeNormalization schema
-                (Declaration [["a"]] [] False (Just True)))
+            fmap
+                (map verdict . findings)
+                ( analyzeNormalization
+                    schema
+                    (Declaration [["a"]] [] False (Just True))
+                )
                 `shouldBe` Right [Satisfied, Insufficient, Insufficient, Insufficient]
         it "requires an atomicity declaration" $ do
-            fmap (map verdict . findings) (analyzeNormalization schema
-                (Declaration [] [] True Nothing)) `shouldBe` Right (replicate 4 Insufficient)
+            fmap
+                (map verdict . findings)
+                ( analyzeNormalization
+                    schema
+                    (Declaration [] [] True Nothing)
+                )
+                `shouldBe` Right (replicate 4 Insufficient)
         it "propagates a declared 1NF violation" $ do
-            fmap (map verdict . findings) (analyzeNormalization schema
-                (Declaration [] [] True (Just False))) `shouldBe` Right (replicate 4 Violated)
+            fmap
+                (map verdict . findings)
+                ( analyzeNormalization
+                    schema
+                    (Declaration [] [] True (Just False))
+                )
+                `shouldBe` Right (replicate 4 Violated)
         it "rejects unknown attributes" $ do
             analyzeNormalization schema (Declaration [] [Dependency ["z"] ["a"]] True (Just True))
                 `shouldBe` Left "normalization: unknown or duplicate dependency attributes"
         it "rejects nonminimal declared candidate keys" $ do
-            analyzeNormalization schema (Declaration [["a", "b"]]
-                [Dependency ["a"] ["b", "c"]] True (Just True))
+            analyzeNormalization
+                schema
+                ( Declaration
+                    [["a", "b"]]
+                    [Dependency ["a"] ["b", "c"]]
+                    True
+                    (Just True)
+                )
                 `shouldBe` Left "normalization: declared candidate key is not minimal"
         it "includes the empty candidate key for constant relations" $ do
-            fmap candidateKeys (analyzeNormalization schema
-                (Declaration [] [Dependency [] ["a", "b", "c"]] True (Just True))) `shouldBe` Right [[]]
+            fmap
+                candidateKeys
+                ( analyzeNormalization
+                    schema
+                    (Declaration [] [Dependency [] ["a", "b", "c"]] True (Just True))
+                )
+                `shouldBe` Right [[]]
         it "rejects excessive exhaustive searches" $ do
-            analyzeNormalization [(show n, TInt) | n <- [1 :: Int .. 13]]
+            analyzeNormalization
+                [(show n, TInt) | n <- [1 :: Int .. 13]]
                 (Declaration [] [] True (Just True))
                 `shouldBe` Left "normalization: exhaustive analysis supports at most 12 columns"
   where