git.iko.soy/squeal
on dev help sign in
enforce same fields
bed538dEitan Chatav
squeel-postgresql/exe/Example.hs+13−12
compare with dev
unifiedsplit
@@ -23,6 +23,19 @@ import Squeel.PostgreSQL
23import qualified Data.ByteString.Char8 as Char8
23import qualified Data.ByteString.Char8 as Char8
24import qualified GHC.Generics as GHC
24import qualified GHC.Generics as GHC
25
25
26+type Schema =
27+ '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]
28+ , "table1" :::
29+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
30+ , "col2" ::: 'Required ('NotNull 'PGint4)
31+ ]
32+ ]
33+
34+data Table1Row = Table1Row { col1 :: Int32, col2 :: Int32 }
35+ deriving (Show, GHC.Generic)
36+instance Generic Table1Row
37+instance HasDatatypeInfo Table1Row
38+
26main :: IO ()
39main :: IO ()
27main = do
40main = do
28 Char8.putStrLn "squeel"
41 Char8.putStrLn "squeel"
@@ -72,15 +85,3 @@ main = do
72 connection3 <- runPQ (connection2 :: Connection Schema) $ pqExec $
85 connection3 <- runPQ (connection2 :: Connection Schema) $ pqExec $
73 dropTable #table1 >>> dropTable #students
86 dropTable #table1 >>> dropTable #students
74 finish (connection3 :: Connection '[])
87 finish (connection3 :: Connection '[])
75−
76−data Table1Row = Table1Row { col1 :: Int32, col2 :: Int32 }
77− deriving (Show, GHC.Generic)
78−instance Generic Table1Row
79−
80−type Schema =
81− '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]
82− , "table1" :::
83− '[ "col1" ::: 'Required ('NotNull 'PGint4)
84− , "col2" ::: 'Required ('NotNull 'PGint4)
85− ]
86− ]
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+29−4
@@ -1,6 +1,10 @@
1{-# LANGUAGE
1{-# LANGUAGE
2 DataKinds
2 DataKinds
3 , DefaultSignatures
3 , DefaultSignatures
4+ , DeriveFoldable
5+ , DeriveFunctor
6+ , DeriveGeneric
7+ , DeriveTraversable
4 , FlexibleContexts
8 , FlexibleContexts
5 , FlexibleInstances
9 , FlexibleInstances
6 , GADTs
10 , GADTs
@@ -9,6 +13,7 @@
9 , MultiParamTypeClasses
13 , MultiParamTypeClasses
10 , ScopedTypeVariables
14 , ScopedTypeVariables
11 , TypeApplications
15 , TypeApplications
16+ , TypeFamilies
12 , TypeOperators
17 , TypeOperators
13 , UndecidableInstances
18 , UndecidableInstances
14#-}
19#-}
@@ -29,6 +34,8 @@ import qualified Data.ByteString.Lazy as Lazy
29import qualified Data.ByteString as Strict hiding (unpack)
34import qualified Data.ByteString as Strict hiding (unpack)
30import qualified Data.Text.Lazy as Lazy
35import qualified Data.Text.Lazy as Lazy
31import qualified Data.Text as Strict
36import qualified Data.Text as Strict
37+import qualified Generics.SOP.Type.Metadata as Type
38+import qualified GHC.Generics as GHC
32import qualified PostgreSQL.Binary.Decoding as Decoding
39import qualified PostgreSQL.Binary.Decoding as Decoding
33import qualified PostgreSQL.Binary.Encoding as Encoding
40import qualified PostgreSQL.Binary.Encoding as Encoding
34
41
@@ -77,8 +84,6 @@ instance ToParam x pg => ToColumnParam (Maybe x) ('Optional (nullity pg)) where
77
84
78class SListI tys => ToParams x (tys :: [ColumnType]) where
85class SListI tys => ToParams x (tys :: [ColumnType]) where
79 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
86 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
80−instance ToColumnParam x ty => ToParams x '[ty] where
81− toParams x = toColumnParam x :* Nil
82instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
87instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
83 => ToParams x tys where
88 => ToParams x tys where
84 toParams
89 toParams
@@ -143,11 +148,31 @@ instance FromValue pg y
143
148
144class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where
149class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where
145 fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y
150 fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y
146−instance FromColumnValue ty y => FromRow '[ty] y where
147− fromRow (y :* Nil) = fromColumnValue y
148instance
151instance
149 ( SListI columns, IsProductType y ys
152 ( SListI columns, IsProductType y ys
150 , AllZip FromColumnValue columns ys
153 , AllZip FromColumnValue columns ys
154+ , HasDatatypeInfo y
155+ , SameFields (DatatypeInfoOf y) columns
151 ) => FromRow columns y where
156 ) => FromRow columns y where
152 fromRow
157 fromRow
153 = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
158 = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
159+
160+class SameField
161+ (fieldInfo :: Type.FieldInfo) (columnty :: (Symbol,ColumnType)) where
162+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
163+
164+type family SameFields
165+ (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ColumnType)]) where
166+ SameFields
167+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
168+ columns
169+ = AllZip SameField fields columns
170+ SameFields
171+ ('Type.Newtype _module _datatype ('Type.Record _constructor '[field]))
172+ '[column]
173+ = SameField field column
174+
175+newtype Only x = Only { only :: x }
176+ deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
177+instance Generic (Only x)
178+instance HasDatatypeInfo (Only x)