Merge pull request #632 from digitallyinduced/check-expr

Added support for CHECK constraints. Fixes #629

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

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
 

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

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

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"] }
 

ihp.cabal

@@ -85,6 +85,7 @@ common shared-properties
             , cryptohash
             , base16-bytestring
             , deepseq
+            , parser-combinators
     default-extensions:
         OverloadedStrings
         , NoImplicitPrelude

ihp.nix

@@ -51,6 +51,7 @@
 , resource-pool
 , wreq
 , deepseq
+, parser-combinators
 }:
 mkDerivation {
   pname = "ihp";
@@ -108,6 +109,7 @@ mkDerivation {
     wreq
     deepseq
     uri-encode
+    parser-combinators
   ];
   license = stdenv.lib.licenses.mit;
   postInstall = ''