mirror of https://github.com/voidlizard/hbs2
wip-no-table
This commit is contained in:
parent
9dd3dc2a11
commit
32804444c6
|
@ -1,5 +1,5 @@
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# Language UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# LANGUAGE DefaultSignatures #-}
|
{-# LANGUAGE DefaultSignatures #-}
|
||||||
module DBPipe.SQLite.Generic where
|
module DBPipe.SQLite.Generic where
|
||||||
|
|
||||||
|
@ -10,7 +10,6 @@ import Data.String (IsString(..))
|
||||||
import Text.InterpolatedString.Perl6 (qc)
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
|
|
||||||
-- FIXME: move-to-DBPipe
|
|
||||||
newtype SQLName = SQLName Text
|
newtype SQLName = SQLName Text
|
||||||
deriving stock (Eq,Ord,Show)
|
deriving stock (Eq,Ord,Show)
|
||||||
deriving newtype (IsString,Monoid,Semigroup)
|
deriving newtype (IsString,Monoid,Semigroup)
|
||||||
|
@ -25,56 +24,52 @@ class ToSQL a where
|
||||||
instance ToSQL SQLName where
|
instance ToSQL SQLName where
|
||||||
toSQL (SQLName a) = SQLPart a
|
toSQL (SQLName a) = SQLPart a
|
||||||
|
|
||||||
|
class GHasColumnNames f where
|
||||||
class HasTableName a where
|
|
||||||
tableName :: SQLName
|
|
||||||
|
|
||||||
class HasTableName t => GHasColumnNames t f where
|
|
||||||
gColumnNames :: f p -> [SQLName]
|
gColumnNames :: f p -> [SQLName]
|
||||||
|
|
||||||
class HasTableName t => HasColumnNames t a where
|
class HasColumnNames a where
|
||||||
columnNames :: a -> [SQLName]
|
columnNames :: a -> [SQLName]
|
||||||
default columnNames :: (Generic a, HasTableName t, GHasColumnNames t (Rep a)) => a -> [SQLName]
|
default columnNames :: (Generic a, GHasColumnNames (Rep a)) => a -> [SQLName]
|
||||||
columnNames = gColumnNames @t . from
|
columnNames = gColumnNames . from
|
||||||
|
|
||||||
class HasTableName t => HasColumnName t a where
|
class HasColumnName a where
|
||||||
columnName :: SQLName
|
columnName :: SQLName
|
||||||
|
|
||||||
instance HasTableName t => HasColumnNames t [SQLName] where
|
instance HasColumnNames [SQLName] where
|
||||||
columnNames = id
|
columnNames = id
|
||||||
|
|
||||||
instance HasTableName t => HasColumnNames t SQLName where
|
instance HasColumnNames SQLName where
|
||||||
columnNames n = [n]
|
columnNames n = [n]
|
||||||
|
|
||||||
instance (HasTableName t, Generic a, GHasColumnNames t (Rep a)) => HasColumnNames t a
|
instance (Generic a, GHasColumnNames (Rep a)) => HasColumnNames a
|
||||||
|
|
||||||
instance HasTableName t => GHasColumnNames t U1 where
|
instance GHasColumnNames U1 where
|
||||||
gColumnNames U1 = []
|
gColumnNames U1 = []
|
||||||
|
|
||||||
instance (GHasColumnNames t a, GHasColumnNames t b) => GHasColumnNames t (a :*: b) where
|
instance (GHasColumnNames a, GHasColumnNames b) => GHasColumnNames (a :*: b) where
|
||||||
gColumnNames (a :*: b) = gColumnNames @t a <> gColumnNames @t b
|
gColumnNames (a :*: b) = gColumnNames a <> gColumnNames b
|
||||||
|
|
||||||
instance (GHasColumnNames t a, GHasColumnNames t b) => GHasColumnNames t (a :+: b) where
|
instance (GHasColumnNames a, GHasColumnNames b) => GHasColumnNames (a :+: b) where
|
||||||
gColumnNames _ = [] -- Не применяется для нашего случая, так как у нас нет вариантов.
|
gColumnNames _ = [] -- Не используется для нашего случая.
|
||||||
|
|
||||||
instance (HasTableName t, HasColumnName t c) => GHasColumnNames t (K1 i c) where
|
instance HasColumnName c => GHasColumnNames (K1 i c) where
|
||||||
gColumnNames (K1 c) = [columnName @t @c]
|
gColumnNames (K1 c) = [columnName @c]
|
||||||
|
|
||||||
instance GHasColumnNames t a => GHasColumnNames t (M1 i t a) where
|
instance GHasColumnNames a => GHasColumnNames (M1 i t a) where
|
||||||
gColumnNames (M1 a) = gColumnNames @t a
|
gColumnNames (M1 a) = gColumnNames a
|
||||||
|
|
||||||
columnListPart :: forall t a . (HasTableName t, HasColumnNames t a) => a -> SQLPart
|
columnListPart :: forall a . HasColumnNames a => a -> SQLPart
|
||||||
columnListPart w = SQLPart $ Text.intercalate "," [ coerce @_ @Text x | x <- columnNames @t w ]
|
columnListPart w = SQLPart $ Text.intercalate "," [ coerce @_ @Text x | x <- columnNames w ]
|
||||||
|
|
||||||
bindListPart :: forall t a . (HasTableName t, HasColumnNames t a) => a -> SQLPart
|
bindListPart :: forall a . HasColumnNames a => a -> SQLPart
|
||||||
bindListPart w = SQLPart $ Text.intercalate "," [ "?" | _ <- columnNames @t w ]
|
bindListPart w = SQLPart $ Text.intercalate "," [ "?" | _ <- columnNames w ]
|
||||||
|
|
||||||
class (HasTableName t, HasColumnNames t b) => Insert t b where
|
class HasColumnNames b => Insert b where
|
||||||
insert :: b -> SQLPart
|
insert :: b -> SQLPart
|
||||||
|
|
||||||
instance (HasTableName t, HasColumnNames t b) => Insert t b where
|
instance HasColumnNames b => Insert b where
|
||||||
insert values = [qc|insert into {tableName @t} values({n}) ({v})|]
|
insert values = [qc|insert into jopakita values({v}) ({n})|]
|
||||||
where
|
where
|
||||||
n = bindListPart @t values
|
n = bindListPart values
|
||||||
v = columnListPart @t values
|
v = columnListPart values
|
||||||
|
|
||||||
|
|
|
@ -96,24 +96,23 @@ isTxProcessed hash = do
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
instance HasTableName t => HasColumnName t GitLwwRef where
|
instance HasColumnName GitLwwRef where
|
||||||
columnName = "lwwref"
|
columnName = "lwwref"
|
||||||
|
|
||||||
instance HasTableName t => HasColumnName t GitLwwSeq where
|
instance HasColumnName GitLwwSeq where
|
||||||
columnName = "lwwseq"
|
columnName = "lwwseq"
|
||||||
|
|
||||||
instance HasTableName t => HasColumnName t GitRefLog where
|
instance HasColumnName GitRefLog where
|
||||||
columnName = "reflog"
|
columnName = "reflog"
|
||||||
|
|
||||||
|
|
||||||
instance HasTableName GitRepoFacts where
|
-- instance HasTableName GitRepoFacts where
|
||||||
tableName = "gitrepofact"
|
-- tableName = "gitrepofact"
|
||||||
|
|
||||||
|
|
||||||
insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m ()
|
insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m ()
|
||||||
insertRepoFacts GitRepoFacts{..} = do
|
insertRepoFacts GitRepoFacts{..} = do
|
||||||
let sql = insert @GitRepoFacts
|
let sql = insert ( gitLwwRef
|
||||||
( gitLwwRef
|
|
||||||
, gitLwwSeq
|
, gitLwwSeq
|
||||||
, gitRefLog
|
, gitRefLog
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue