Added support for double default values and sql type casts

IHP/IDE/SchemaDesigner/Compiler.hs

@@ -87,6 +87,8 @@ compileExpression (LessThanExpression a b) = compileExpression a <> " < " <> com
 compileExpression (LessThanOrEqualToExpression a b) = compileExpression a <> " <= " <> compileExpression b
 compileExpression (GreaterThanExpression a b) = compileExpression a <> " > " <> compileExpression b
 compileExpression (GreaterThanOrEqualToExpression a b) = compileExpression a <> " >= " <> compileExpression b
+compileExpression (DoubleExpression double) = tshow double
+compileExpression (TypeCastExpression value type_) = compileExpression value <> "::" <> compilePostgresType type_
 
 compareStatement (CreateEnumType {}) _ = LT
 compareStatement (StatementCreateTable CreateTable {}) (AddConstraint {}) = LT
@@ -372,4 +374,4 @@ compileIdentifier identifier = if identifierNeedsQuoting then tshow identifier e
             , "VARCHAR"
             ]
 
-indent text = "    " <> text
+indent text = "    " <> text

IHP/IDE/SchemaDesigner/Parser.hs

@@ -9,6 +9,7 @@ module IHP.IDE.SchemaDesigner.Parser
 , parseDDL
 , expression
 , sqlType
+, removeTypeCasts
 ) where
 
 import IHP.Prelude
@@ -349,7 +350,7 @@ sqlType = choice $ map optionalArray
                     theType <- try (takeWhile1P (Just "Custom type") (\c -> isAlphaNum c || c == '_'))
                     pure (PCustomType theType)
 
-term = parens expression <|> try callExpr <|> varExpr <|> (textExpr <* optional space)
+term = parens expression <|> try callExpr <|> try doubleExpr <|> varExpr <|> (textExpr <* optional space)
     where
         parens f = between (char '(' >> space) (char ')' >> space) f
 
@@ -364,6 +365,7 @@ table = [
 
             , binary "IS" IsExpression
             , prefix "NOT" NotExpression
+            , typeCast
             ],
             [ binary "AND" AndExpression, binary "OR" OrExpression ]
         ]
@@ -372,6 +374,13 @@ table = [
         prefix  name f = Prefix  (f <$ symbol name)
         postfix name f = Postfix (f <$ symbol name)
 
+        -- Cannot be implemented as a infix operator as that requires two expression operands,
+        -- but the second is the type-cast type which is not an expression
+        typeCast = Postfix do
+            symbol "::"
+            castType <- sqlType
+            pure $ \expr -> TypeCastExpression expr castType
+
 -- | 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
@@ -384,6 +393,9 @@ expression = do
 varExpr :: Parser Expression
 varExpr = VarExpression <$> identifier
 
+doubleExpr :: Parser Expression
+doubleExpr = DoubleExpression <$> Lexer.float
+
 callExpr :: Parser Expression
 callExpr = do
     func <- identifier
@@ -443,3 +455,9 @@ createTrigger = do
     lexeme "TRIGGER"
     raw <- cs <$> someTill (anySingle) (char ';')
     pure UnknownStatement { raw = "CREATE TRIGGER " <> raw }
+
+
+-- | Turns sql like '1::double precision' into just '1'
+removeTypeCasts :: Expression -> Expression
+removeTypeCasts (TypeCastExpression value _) = value
+removeTypeCasts otherwise = otherwise

IHP/IDE/SchemaDesigner/Types.hs

@@ -96,6 +96,10 @@ data Expression =
     | GreaterThanExpression Expression Expression
     -- | a >= b
     | GreaterThanOrEqualToExpression Expression Expression
+    -- | Double literal value, e.g. 0.1337
+    | DoubleExpression Double
+    -- | value::type
+    | TypeCastExpression Expression PostgresType
     deriving (Eq, Show)
 
 data PostgresType

IHP/SchemaCompiler.hs

@@ -557,17 +557,23 @@ toDefaultValueExpr Column { columnType, notNull, defaultValue = Just theDefaultV
 
                 isNullExpr (VarExpression varName) = toUpper varName == "NULL"
                 isNullExpr _ = False
+
+                -- We remove type casts here, as we need the actual value literal for setting our default value
+                theNormalizedDefaultValue = theDefaultValue |> SchemaDesigner.removeTypeCasts
             in
                 if isNullExpr theDefaultValue
                     then "Nothing"
                     else
                         case columnType of
-                            PText -> case theDefaultValue of
+                            PText -> case theNormalizedDefaultValue of
                                 TextExpression value -> wrapNull notNull (tshow value)
                                 otherwise            -> error ("toDefaultValueExpr: TEXT column needs to have a TextExpression as default value. Got: " <> show otherwise)
-                            PBoolean -> case theDefaultValue of
+                            PBoolean -> case theNormalizedDefaultValue of
                                 VarExpression value -> wrapNull notNull (tshow (toLower value == "true"))
                                 otherwise           -> error ("toDefaultValueExpr: BOOL column needs to have a VarExpression as default value. Got: " <> show otherwise)
+                            PDouble -> case theNormalizedDefaultValue of
+                                DoubleExpression value -> wrapNull notNull (tshow value)
+                                otherwise           -> error ("toDefaultValueExpr: DOUBLE column needs to have a DoubleExpression as default value. Got: " <> show otherwise)
                             _ -> "def"
 toDefaultValueExpr _ = "def"
 

Test/IDE/SchemaDesigner/CompilerSpec.hs

@@ -454,3 +454,8 @@ tests = do
             let sql = cs [plain|CREATE TRIGGER t AFTER INSERT ON x FOR EACH ROW EXECUTE PROCEDURE y();\n|]
             let statement = UnknownStatement { raw = "CREATE TRIGGER t AFTER INSERT ON x FOR EACH ROW EXECUTE PROCEDURE y()"  }
             compileSql [statement] `shouldBe` sql
+
+        it "should compile a decimal default value with a type-cast" do
+            let sql = "CREATE TABLE a (\n    electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::DOUBLE PRECISION NOT NULL\n);\n"
+            let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [] }
+            compileSql [statement] `shouldBe` sql

Test/IDE/SchemaDesigner/ParserSpec.hs

@@ -458,6 +458,13 @@ tests = do
                     ]
             parseSqlStatements sql `shouldBe` statements
 
+        it "should parse a decimal default value with a type-cast" do
+            let sql = "CREATE TABLE a(electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::double precision NOT NULL);"
+            let statements =
+                    [ StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [] }
+                    ]
+            parseSqlStatements sql `shouldBe` statements
+
 
 col :: Column
 col = Column

Test/SchemaCompilerSpec.hs

@@ -149,7 +149,60 @@ tests = do
                         updateRecord model = do
                             List.head <$> sqlQuery "UPDATE users SET id = ?, ids = ? :: UUID[] WHERE id = ? RETURNING *" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, get #id model))
                     |]
+            it "should deal with double default values" do
+                let statement = StatementCreateTable CreateTable
+                        { name = "users"
+                        , columns =
+                            [ Column "id" PUUID Nothing False True, Column "ids" (PArray PUUID) Nothing False False
+                            , Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False}
+                            ]
+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]
+                        , constraints = []
+                        }
+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip
+
+                putStrLn compileOutput
+
+                compileOutput `shouldBe` [text|
+                    data User'  = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show)
+                    instance InputValue User where inputValue = IHP.ModelSupport.recordToInputValue
+                    type User = User' 
+
+                    instance FromRow User where
+                        fromRow = do
+                            id <- field
+                            ids <- field
+                            electricityUnitPrice <- field
+                            let theRecord = User id ids electricityUnitPrice def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
+                            pure theRecord
+
+                    type instance GetTableName (User' ) = "users"
+                    type instance GetModelByTableName "users" = User
+                    type instance GetModelName (User' ) = "User"
 
+                    type instance PrimaryKey "users" = UUID
+
+                    instance QueryBuilder.FilterPrimaryKey "users" where
+                        filterWhereId id builder =
+                            builder |> QueryBuilder.filterWhere (#id, id)
+                        {-# INLINE filterWhereId #-}
+
+                    instance CanCreate User where
+                        create :: (?modelContext :: ModelContext) => User -> IO User
+                        create model = do
+                            List.head <$> sqlQuery "INSERT INTO users (id, ids, electricity_unit_price) VALUES (?, ? :: UUID[], ?) RETURNING *" ((get #id model, get #ids model, fieldWithDefault #electricityUnitPrice model))
+                        createMany [] = pure []
+                        createMany models = do
+                            sqlQuery (Query $ "INSERT INTO users (id, ids, electricity_unit_price) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?, ? :: UUID[], ?)") models)) <> " RETURNING *") (List.concat $ List.map (\model -> [toField (get #id model), toField (get #ids model), toField (fieldWithDefault #electricityUnitPrice model)]) models)
+
+                    instance CanUpdate User where
+                        updateRecord model = do
+                            List.head <$> sqlQuery "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING *" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, get #id model))
+
+                    instance Record User where
+                        {-# INLINE newRecord #-}
+                        newRecord = User def def 0.17  def
+                |]
 
 getInstanceDecl :: Text -> Text -> Text
 getInstanceDecl instanceName full =