Skip to content

Commit

Permalink
Added support for CHECK constraints. Fixes #629
Browse files Browse the repository at this point in the history
  • Loading branch information
mpscholten committed Dec 27, 2020
1 parent 7211ae1 commit b672bb7
Show file tree
Hide file tree
Showing 5 changed files with 44 additions and 2 deletions.
2 changes: 2 additions & 0 deletions IHP/IDE/SchemaDesigner/Compiler.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 = ""
Expand Down Expand Up @@ -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
Expand Down
22 changes: 20 additions & 2 deletions IHP/IDE/SchemaDesigner/Parser.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"

Expand Down Expand Up @@ -132,7 +133,7 @@ parseTableConstraint = do
lexeme "CONSTRAINT"
identifier
(Left <$> parsePrimaryKeyConstraint) <|>
(Right <$> (parseForeignKeyConstraint <|> parseUniqueConstraint))
(Right <$> (parseForeignKeyConstraint <|> parseUniqueConstraint <|> parseCheckConstraint))

parsePrimaryKeyConstraint = do
lexeme "PRIMARY"
Expand All @@ -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
Expand Down Expand Up @@ -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

Expand Down
3 changes: 3 additions & 0 deletions IHP/IDE/SchemaDesigner/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,6 +61,7 @@ data Constraint
}
| UniqueConstraint
{ columnNames :: [Text] }
| CheckConstraint { checkExpression :: Expression }
deriving (Eq, Show)

data Expression =
Expand All @@ -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
Expand Down
10 changes: 10 additions & 0 deletions Test/IDE/SchemaDesigner/CompilerSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
9 changes: 9 additions & 0 deletions Test/IDE/SchemaDesigner/ParserSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"] }

Expand Down

0 comments on commit b672bb7

Please sign in to comment.