From b672bb7537a4a076891397d93fb6197ed32a8dca Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sun, 27 Dec 2020 13:37:24 +0100 Subject: [PATCH] Added support for CHECK constraints. Fixes #629 --- IHP/IDE/SchemaDesigner/Compiler.hs | 2 ++ IHP/IDE/SchemaDesigner/Parser.hs | 22 ++++++++++++++++++++-- IHP/IDE/SchemaDesigner/Types.hs | 3 +++ Test/IDE/SchemaDesigner/CompilerSpec.hs | 10 ++++++++++ Test/IDE/SchemaDesigner/ParserSpec.hs | 9 +++++++++ 5 files changed, 44 insertions(+), 2 deletions(-) diff --git a/IHP/IDE/SchemaDesigner/Compiler.hs b/IHP/IDE/SchemaDesigner/Compiler.hs index 6462268c1..8656378d3 100644 --- a/IHP/IDE/SchemaDesigner/Compiler.hs +++ b/IHP/IDE/SchemaDesigner/Compiler.hs @@ -40,6 +40,7 @@ compilePrimaryKeyConstraint PrimaryKeyConstraint { primaryKeyColumnNames } = compileConstraint :: Constraint -> Text compileConstraint ForeignKeyConstraint { columnName, referenceTable, referenceColumn, onDelete } = "FOREIGN KEY (" <> compileIdentifier columnName <> ") REFERENCES " <> compileIdentifier referenceTable <> (if isJust referenceColumn then " (" <> fromJust referenceColumn <> ")" else "") <> " " <> compileOnDelete onDelete compileConstraint UniqueConstraint { columnNames } = "UNIQUE(" <> intercalate ", " columnNames <> ")" +compileConstraint CheckConstraint { checkExpression } = "CHECK (" <> compileExpression checkExpression <> ")" compileOnDelete :: Maybe OnDelete -> Text compileOnDelete Nothing = "" @@ -74,6 +75,7 @@ compileExpression :: Expression -> Text compileExpression (TextExpression value) = "'" <> value <> "'" compileExpression (VarExpression name) = name compileExpression (CallExpression func args) = func <> "(" <> intercalate ", " (map compileExpression args) <> ")" +compileExpression (NotEqExpression a b) = compileExpression a <> " <> " <> compileExpression b compareStatement (CreateEnumType {}) _ = LT compareStatement (StatementCreateTable CreateTable {}) (AddConstraint {}) = LT diff --git a/IHP/IDE/SchemaDesigner/Parser.hs b/IHP/IDE/SchemaDesigner/Parser.hs index 6e4c687fe..f7ce86d9b 100644 --- a/IHP/IDE/SchemaDesigner/Parser.hs +++ b/IHP/IDE/SchemaDesigner/Parser.hs @@ -22,6 +22,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lexer import Data.Char import IHP.IDE.SchemaDesigner.Compiler (compileSql) +import Control.Monad.Combinators.Expr schemaFilePath = "Application/Schema.sql" @@ -132,7 +133,7 @@ parseTableConstraint = do lexeme "CONSTRAINT" identifier (Left <$> parsePrimaryKeyConstraint) <|> - (Right <$> (parseForeignKeyConstraint <|> parseUniqueConstraint)) + (Right <$> (parseForeignKeyConstraint <|> parseUniqueConstraint <|> parseCheckConstraint)) parsePrimaryKeyConstraint = do lexeme "PRIMARY" @@ -158,6 +159,10 @@ parseUniqueConstraint = do columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space)) pure UniqueConstraint { columnNames } +parseCheckConstraint = do + lexeme "CHECK" + checkExpression <- between (char '(' >> space) (char ')' >> space) expression + pure CheckConstraint { checkExpression } parseOnDelete = choice [ (lexeme "NO" >> lexeme "ACTION") >> pure NoAction @@ -328,9 +333,22 @@ sqlType = choice $ map optionalArray theType <- try (takeWhile1P (Just "Custom type") (\c -> isAlphaNum c || c == '_')) pure (PCustomType theType) +term = parens expression <|> try callExpr <|> varExpr <|> textExpr + where + parens f = between (char '(' >> space) (char ')' >> space) f + +table = [ [ binary "<>" NotEqExpression ] ] + where + binary name f = InfixL (f <$ symbol name) + prefix name f = Prefix (f <$ symbol name) + postfix name f = Postfix (f <$ symbol name) + +-- | Parses a SQL expression +-- +-- This parser makes use of makeExprParser as described in https://hackage.haskell.org/package/parser-combinators-1.2.0/docs/Control-Monad-Combinators-Expr.html expression :: Parser Expression expression = do - e <- try callExpr <|> varExpr <|> textExpr + e <- makeExprParser term table "expression" space pure e diff --git a/IHP/IDE/SchemaDesigner/Types.hs b/IHP/IDE/SchemaDesigner/Types.hs index f9f6fd441..aeeed9c52 100644 --- a/IHP/IDE/SchemaDesigner/Types.hs +++ b/IHP/IDE/SchemaDesigner/Types.hs @@ -61,6 +61,7 @@ data Constraint } | UniqueConstraint { columnNames :: [Text] } + | CheckConstraint { checkExpression :: Expression } deriving (Eq, Show) data Expression = @@ -70,6 +71,8 @@ data Expression = | VarExpression Text -- | Simple call, like @COALESCE(name, 'unknown name')@ | CallExpression Text [Expression] + -- | Not equal operator, a <> b + | NotEqExpression Expression Expression deriving (Eq, Show) data PostgresType diff --git a/Test/IDE/SchemaDesigner/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index 80dc582b3..e0d387c83 100644 --- a/Test/IDE/SchemaDesigner/CompilerSpec.hs +++ b/Test/IDE/SchemaDesigner/CompilerSpec.hs @@ -180,6 +180,16 @@ tests = do } } compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ;\n" + + it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do + let statement = AddConstraint + { tableName = "posts" + , constraintName = "check_title_length" + , constraint = CheckConstraint + { checkExpression = NotEqExpression (VarExpression "title") (TextExpression "") + } + } + compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');\n" it "should compile a CREATE TABLE with text default value in columns" do diff --git a/Test/IDE/SchemaDesigner/ParserSpec.hs b/Test/IDE/SchemaDesigner/ParserSpec.hs index bea9c6293..c46d5b5f2 100644 --- a/Test/IDE/SchemaDesigner/ParserSpec.hs +++ b/Test/IDE/SchemaDesigner/ParserSpec.hs @@ -176,6 +176,15 @@ tests = do } } + it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do + parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');" `shouldBe` AddConstraint + { tableName = "posts" + , constraintName = "check_title_length" + , constraint = CheckConstraint + { checkExpression = NotEqExpression (VarExpression "title") (TextExpression "") + } + } + it "should parse CREATE TYPE .. AS ENUM" do parseSql "CREATE TYPE colors AS ENUM ('yellow', 'red', 'green');" `shouldBe` CreateEnumType { name = "colors", values = ["yellow", "red", "green"] }