diff --git a/sequelize.cabal b/sequelize.cabal index 3a02ff6..f31e07d 100644 --- a/sequelize.cabal +++ b/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: diff --git a/src/Sequelize.hs b/src/Sequelize.hs index 35b6924..cfa112e 100644 --- a/src/Sequelize.hs +++ b/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 diff --git a/src/Sequelize/SQLObject.hs b/src/Sequelize/SQLObject.hs new file mode 100644 index 0000000..1ca159b --- /dev/null +++ b/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