SQLObject added

sequelize.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.0.
+-- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 492410794b7d56b74a2a0cc2cb2d4ea37d2c1711251fc612e511aab5adfc35e6
+-- hash: 4f5036bc14bc846828e0e27dec4a5fcfc5a0c8d4b152212b5f5ea2a5cc045e66
 
 name:           sequelize
 version:        1.1.0.0
@@ -21,6 +21,7 @@ library
   exposed-modules:
       Sequelize
       Sequelize.Encode
+      Sequelize.SQLObject
   other-modules:
       Paths_sequelize
   hs-source-dirs:

src/Sequelize.hs

@@ -71,6 +71,7 @@ import qualified GHC.Generics as G
 import GHC.Types (Type)
 import GHC.TypeLits (Symbol)
 import Named ((:!), (:?), arg, argF)
+import Sequelize.SQLObject
 
 ----------------------------------------------------------------------------
 -- Column
@@ -97,13 +98,13 @@ isClausesToWhere :: WHERE be table -> Where be table
 isClausesToWhere = fmap (\(IS c v) -> Is c (Eq v))
 
 data IS be table where
-  IS :: (ToJSON value, Ord value, EqValue be value, Show value) => Column table value -> value -> IS be table
+  IS :: (ToJSON value, Ord value, EqValue be value, Show value, ToSQLObject value) => Column table value -> value -> IS be table
 
 data Clause be (table :: (Type -> Type) -> Type) where
   And :: [Clause be table] -> Clause be table
   Or :: [Clause be table] -> Clause be table
   Is ::
-    (ToJSON value, Ord value, Show value) =>
+    (ToJSON value, Ord value, Show value, ToSQLObject value) =>
     Column table value ->
     Term be value ->
     Clause be table
@@ -223,7 +224,7 @@ orderByQ (Desc column) item =
 
 data Set be table
   = forall value.
-    (B.BeamSqlBackendCanSerialize be value, ToJSON value) =>
+    (B.BeamSqlBackendCanSerialize be value, ToJSON value, ToSQLObject value) =>
     Set (Column table value) value
   | forall value.
     SetDefault (Column table value)
@@ -287,7 +288,8 @@ instance
   ( c ~ 'G.MetaSel ('Just name) _u _s _d,
     HasTableField name table (Maybe value),
     B.BeamSqlBackendCanSerialize be (Maybe value),
-    ToJSON value
+    ToJSON value,
+    ToSQLObject (Maybe value)
   ) =>
   GModelToSets be table (G.S1 c (G.Rec0 (Maybe value)))
   where
@@ -303,7 +305,8 @@ instance
   ( c ~ 'G.MetaSel ('Just name) _u _s _d,
     HasTableField name table value,
     B.BeamSqlBackendCanSerialize be value,
-    ToJSON value
+    ToJSON value,
+    ToSQLObject value
   ) =>
   GModelToSets be table (G.S1 c (G.Rec0 value))
   where

src/Sequelize/SQLObject.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Sequelize.SQLObject where
+
+import qualified Data.Aeson as A
+import Data.Coerce (coerce)
+import qualified Data.Vector as V
+import Database.Beam.Backend
+import qualified Database.Beam.Backend.SQL.AST as B
+import Data.Text
+import Data.Aeson
+import qualified Data.Text as T
+
+data SQLObject a = SQLObjectValue Text | SQLObjectList [SQLObject a]
+
+instance ToJSON (SQLObject a) where
+  toJSON (SQLObjectValue a) = A.String a
+  toJSON (SQLObjectList as) = A.Array (V.fromList $ toJSON <$> as)
+
+class ToSQLObject a where
+  convertToSQLObject :: a -> SQLObject a
+
+instance HasSqlValueSyntax B.Value A.Value where
+  sqlValueSyntax = autoSqlValueSyntax
+
+instance HasSqlValueSyntax B.Value a => ToSQLObject a where
+  convertToSQLObject = SQLObjectValue . valueToText . sqlValueSyntax @B.Value
+
+-- FIXME remove overlapping if possible
+instance {-# OVERLAPPING #-} ToSQLObject a => ToSQLObject [a] where
+  convertToSQLObject v = do
+    let sqlObjectsList = convertToSQLObject <$> v
+    SQLObjectList $ coerce @(SQLObject a) @(SQLObject [a]) <$> sqlObjectsList
+
+instance {-# OVERLAPPING #-} ToSQLObject a => ToSQLObject (Maybe a) where
+  convertToSQLObject mbA = case mbA of
+    Just a -> coerce @(SQLObject a) @(SQLObject (Maybe a)) $ convertToSQLObject a
+    Nothing -> coerce @(SQLObject SqlNull) @(SQLObject (Maybe a)) $ convertToSQLObject SqlNull
+
+valueToText :: B.Value -> Text
+valueToText (B.Value v) = T.pack $ show v