52c66ee · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

work generics and binary through

52c66eeEitan Chatav9 years ago

squeel-postgresql/exe/Example.hs+38−22

compare with dev

unifiedsplit

@@ -1,18 +1,19 @@

1{-# LANGUAGE

2 DataKinds

3+ , DeriveGeneric

4+ , FlexibleInstances

5+ , MultiParamTypeClasses

3 , OverloadedLabels

6 , OverloadedLabels

4 , OverloadedStrings

7 , OverloadedStrings

5 , TypeApplications

8 , TypeApplications

6 , TypeOperators

9 , TypeOperators

10+ , TypeSynonymInstances

7#-}

11#-}

9−module Main (main) where

13+module Main (main,col1,col2) where

11import Control.Category ((>>>))

15import Control.Category ((>>>))

12import Control.Monad.Base

16import Control.Monad.Base

13−import Control.Monad.Except

14−import Control.Monad.Trans.Maybe

15−import Data.Foldable (for_)

16import Data.Function ((&))

17import Data.Function ((&))

17import Data.Int

18import Data.Int

18import Data.Monoid

19import Data.Monoid

@@ -20,6 +21,7 @@ import Generics.SOP hiding (from)

20import Squeel.PostgreSQL

21import Squeel.PostgreSQL

22import qualified Data.ByteString.Char8 as Char8

23import qualified Data.ByteString.Char8 as Char8

24+import qualified GHC.Generics as GHC

24main :: IO ()

26main :: IO ()

25main = do

27main = do

@@ -40,26 +42,35 @@ main = do

40 :* Nil ) []

42 :* Nil ) []

41 Char8.putStrLn "querying"

43 Char8.putStrLn "querying"

42 connection2 <- runPQ (connection1 :: Connection Tables) $ do

44 connection2 <- runPQ (connection1 :: Connection Tables) $ do

43− for_ [I i :* I (i+1) :* Nil | i <- [1::Int32,3..9]] $ pqExecParams

45+ let

46+ statement :: Manipulation Tables

47+ '[ 'Required ('NotNull 'PGInt4)

48+ , 'Required ('NotNull 'PGInt4)

49+ , 'Required ('NotNull 'PGInt4)

50+ , 'Required ('NotNull 'PGInt4)

51+ ] '[]

52+ statement =

44− ( insertInto #table1

53+ insertInto #table1

54+ (Values

45− (Values (param1 `As` #col1 :* param2 `As` #col2 :* Nil) [])

55+ (param1 `As` #col1 :* param2 `As` #col2 :* Nil)

56+ [param3 `As` #col1 :* param4 `As` #col2 :* Nil] )

46− Conflict ReturningNil )

57+ Conflict ReturningNil

58+ _ <- pqExecParams statement (1::Int32,2::Int32,3::Int32,4::Int32)

47 Just result <- pqExecNil . query $

59 Just result <- pqExecNil . query $

48 selectStar (from (Table (#table1 `As` #table1)))

60 selectStar (from (Table (#table1 `As` #table1)))

49− runMaybeT . runExceptT . flip runValue result $ do

50− value00 <- getValue (RowNumber 0) (columnNumber @0)

61+ value00 <- getValue (RowNumber 0) (columnNumber @0) result

51− value01 <- getValue (RowNumber 0) (columnNumber @1)

62+ value01 <- getValue (RowNumber 0) (columnNumber @1) result

52− value10 <- getValue (RowNumber 1) (columnNumber @0)

63+ value10 <- getValue (RowNumber 1) (columnNumber @0) result

53− value11 <- getValue (RowNumber 1) (columnNumber @1)

64+ value11 <- getValue (RowNumber 1) (columnNumber @1) result

54− row0 <- getRow (RowNumber 0)

65+ row0 <- getRow (RowNumber 0) result

55− row1 <- getRow (RowNumber 1)

66+ row1 <- getRow (RowNumber 1) result

56− liftBase $ do

67+ liftBase $ do

57− print (value00 :: Int32)

68+ print (value00 :: Int32)

58− print (value01 :: Int32)

69+ print (value01 :: Int32)

59− print (value10 :: Int32)

70+ print (value10 :: Int32)

60− print (value11 :: Int32)

71+ print (value11 :: Int32)

61− print (row0 :: NP I '[Int32,Int32])

72+ print (row0 :: ColumnsRecord)

62− print (row1 :: NP I '[Int32,Int32])

73+ print (row1 :: ColumnsRecord)

63 Char8.putStrLn "tearing down database"

74 Char8.putStrLn "tearing down database"

64 connection3 <- runPQ (connection2 :: Connection Tables) $ pqExec $

75 connection3 <- runPQ (connection2 :: Connection Tables) $ pqExec $

65 dropTable #table1 >>> dropTable #students

76 dropTable #table1 >>> dropTable #students

@@ -69,5 +80,10 @@ type Columns =

69 '[ "col1" ::: 'Required ('NotNull 'PGInt4)

80 '[ "col1" ::: 'Required ('NotNull 'PGInt4)

70 , "col2" ::: 'Required ('NotNull 'PGInt4)

81 , "col2" ::: 'Required ('NotNull 'PGInt4)

71 ]

82 ]

83+data ColumnsRecord = ColumnsRecord { col1 :: Int32, col2 :: Int32 }

84+ deriving (Show, GHC.Generic)

85+instance Generic ColumnsRecord

86+instance FromRow Columns ColumnsRecord

87+

72type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]

88type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]

73type Tables = '["students" ::: StudentsColumns, "table1" ::: Columns]

89type Tables = '["students" ::: StudentsColumns, "table1" ::: Columns]

squeel-postgresql/src/Squeel/PostgreSQL.hs+2−2

@@ -1,11 +1,11 @@

1module Squeel.PostgreSQL

2− ( module Squeel.PostgreSQL.Binary

2+ ( module Squeel.PostgreSQL.Binary2

3 , module Squeel.PostgreSQL.PQ

4 , module Squeel.PostgreSQL.Schema

5 , module Squeel.PostgreSQL.Statement

6 ) where

8−import Squeel.PostgreSQL.Binary

8+import Squeel.PostgreSQL.Binary2

9import Squeel.PostgreSQL.PQ

10import Squeel.PostgreSQL.Schema

11import Squeel.PostgreSQL.Statement

squeel-postgresql/src/Squeel/PostgreSQL/Binary2.hs+25−2

@@ -74,7 +74,7 @@ instance ToParam x pg => ToColumnParam (Maybe x) ('Required ('Null pg)) where

74instance ToParam x pg => ToColumnParam (Maybe x) ('Optional (nullity pg)) where

75 toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)

77−class ToParams x (tys :: [ColumnType]) where

77+class SListI tys => ToParams x (tys :: [ColumnType]) where

78 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys

79 default toParams

80 :: (IsProductType x xs, AllZip ToColumnParam xs tys)

@@ -82,6 +82,26 @@ class ToParams x (tys :: [ColumnType]) where

82 toParams

83 = htrans (Proxy @ToColumnParam) (toColumnParam . unI)

84 . unZ . unSOP . from

85+instance ToParams () '[]

86+instance ToColumnParam x ty => ToParams x '[ty] where

87+ toParams x = toColumnParam x :* Nil

88+instance (ToColumnParam x1 ty1, ToColumnParam x2 ty2)

89+ => ToParams (x1,x2) '[ty1,ty2]

90+instance (ToColumnParam x1 ty1, ToColumnParam x2 ty2, ToColumnParam x3 ty3)

91+ => ToParams (x1,x2,x3) '[ty1,ty2,ty3]

92+instance

93+ ( ToColumnParam x1 ty1

94+ , ToColumnParam x2 ty2

95+ , ToColumnParam x3 ty3

96+ , ToColumnParam x4 ty4

97+ ) => ToParams (x1,x2,x3,x4) '[ty1,ty2,ty3,ty4]

98+instance

99+ ( ToColumnParam x1 ty1

100+ , ToColumnParam x2 ty2

101+ , ToColumnParam x3 ty3

102+ , ToColumnParam x4 ty4

103+ , ToColumnParam x5 ty5

104+ ) => ToParams (x1,x2,x3,x4,x5) '[ty1,ty2,ty3,ty4,ty5]

105

86class FromValue (pg :: PGType) y where

106class FromValue (pg :: PGType) y where

87 fromValue :: proxy pg -> Decoding.Value y

107 fromValue :: proxy pg -> Decoding.Value y

@@ -139,7 +159,7 @@ instance FromValue pg y

139 where

159 where

140 err str = error $ "fromColumnValue: " ++ Strict.unpack str

160 err str = error $ "fromColumnValue: " ++ Strict.unpack str

141

161

142−class FromRow (columns :: [(Symbol,ColumnType)]) y where

162+class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where

143 fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y

163 fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y

144 default fromRow

164 default fromRow

145 :: (IsProductType y ys, AllZip FromColumnValue columns ys)

165 :: (IsProductType y ys, AllZip FromColumnValue columns ys)

@@ -147,3 +167,6 @@ class FromRow (columns :: [(Symbol,ColumnType)]) y where

147 fromRow

167 fromRow

148 = to . SOP . Z

168 = to . SOP . Z

149 . htrans (Proxy @FromColumnValue) (I . fromColumnValue)

169 . htrans (Proxy @FromColumnValue) (I . fromColumnValue)

170+instance FromRow '[] ()

171+instance FromColumnValue ty y => FromRow '[ty] y where

172+ fromRow (y :* Nil) = fromColumnValue y

squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+27−53

@@ -22,20 +22,16 @@ module Squeel.PostgreSQL.PQ where

22import Control.Exception.Lifted

23import Control.Monad.Base

24import Control.Monad.Except

25−import Control.Monad.Trans.Maybe

26import Control.Monad.Trans.Control

25import Control.Monad.Trans.Control

27import Data.ByteString (ByteString)

26import Data.ByteString (ByteString)

28import Data.Function ((&))

27import Data.Function ((&))

29−import Data.Maybe

30−import Data.Proxy (Proxy)

31−import Data.Text (Text)

32import Generics.SOP

28import Generics.SOP

33import GHC.Exts hiding (fromList)

29import GHC.Exts hiding (fromList)

34import GHC.TypeLits

30import GHC.TypeLits

36import qualified Database.PostgreSQL.LibPQ as LibPQ

32import qualified Database.PostgreSQL.LibPQ as LibPQ

38−import Squeel.PostgreSQL.Binary

34+import Squeel.PostgreSQL.Binary2

39import Squeel.PostgreSQL.Statement

35import Squeel.PostgreSQL.Statement

40import Squeel.PostgreSQL.Schema

36import Squeel.PostgreSQL.Schema

@@ -104,28 +100,24 @@ pqThenExec = pqThen . pqExec

104class Monad m => MonadPQ schema m | m -> schema where

100class Monad m => MonadPQ schema m | m -> schema where

105

101

106 pqExecParams

102 pqExecParams

107− :: (ToOids ps, AllZip HasEncoding ps xs)

103+ :: ToParams x params

108− => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))

104+ => Manipulation schema params ys -> x -> m (Maybe (Result ys))

109 default pqExecParams

105 default pqExecParams

110 :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)

106 :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)

111− => (ToOids ps, AllZip HasEncoding ps xs)

107+ => ToParams x params

112− => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))

108+ => Manipulation schema params ys -> x -> m (Maybe (Result ys))

113 pqExecParams manipulation params = lift $ pqExecParams manipulation params

109 pqExecParams manipulation params = lift $ pqExecParams manipulation params

114

110

115 pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))

111 pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))

116− pqExecNil statement = pqExecParams statement Nil

112+ pqExecNil statement = pqExecParams statement ()

117

113

118instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

114instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

119

115

120− pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) params =

116+ pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

121 PQ $ \ (Connection conn) -> do

117 PQ $ \ (Connection conn) -> do

122 let

118 let

123− paramValues = encodings (Proxy :: Proxy ps) params

119+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

124− oids = toOids (proxy# :: Proxy# ps)

120+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

125− params' =

126− [ Just (oid, param', LibPQ.Binary)

127− | (oid, param') <- zip oids paramValues

128− ]

129 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

121 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

130 return (Result <$> result, Connection conn)

122 return (Result <$> result, Connection conn)

131

123

@@ -190,43 +182,25 @@ instance {-# OVERLAPPABLE #-}

190 (KnownNat n, HasColumnNumber (n-1) columns column)

182 (KnownNat n, HasColumnNumber (n-1) columns column)

191 => HasColumnNumber n (column' : columns) column

183 => HasColumnNumber n (column' : columns) column

192

184

193−newtype Value pgs m x = Value { runValue :: Result pgs -> m x }

194− deriving (Functor)

195−instance Applicative m => Applicative (Value pgs m) where

196− pure x = Value $ \ _result -> pure x

197− mf <*> mx = Value $ \ result -> runValue mf result <*> runValue mx result

198−instance Monad m => Monad (Value pgs m) where

199− return = pure

200− mx >>= f = Value $ \ result -> do

201− x <- runValue mx result

202− runValue (f x) result

203−instance MonadTrans (Value pgs) where

204− lift m = Value $ \ _result -> m

205−instance MonadBase b m => MonadBase b (Value pgs m) where

206− liftBase = lift . liftBase

207−

208getValue

185getValue

209− :: (HasDecoding pg x, MonadBase IO io)

186+ :: (FromColumnValue colty y, MonadBase IO io)

210 => RowNumber

187 => RowNumber

211− -> ColumnNumber n pgs pg

188+ -> ColumnNumber n columns colty

212− -> Value pgs (ExceptT Text (MaybeT io)) x

189+ -> Result columns

190+ -> io y

191+getValue

192+ (RowNumber r)

213−getValue (RowNumber r) (UnsafeColumnNumber c :: ColumnNumber n pgs pg) =

193+ (UnsafeColumnNumber c :: ColumnNumber n columns colty)

214− Value $ \ (Result result) -> do

194+ (Result result)

195+ = fromColumnValue @colty . K <$>

215− maybeBytestring <- liftBase $ LibPQ.getvalue result r c

196+ liftBase (LibPQ.getvalue result r c)

216− case maybeBytestring of

217− Nothing -> mzero

218− Just bytestring -> case decodeValue (Proxy :: Proxy pg) bytestring of

219− Left err -> throwError err

220− Right val -> return val

221

197

222getRow

198getRow

223− :: (AllZip HasDecoding pgs xs, MonadBase IO io)

199+ :: (FromRow columns y, MonadBase IO io)

224− => RowNumber -> Value pgs (ExceptT Text (MaybeT io)) (NP I xs)

200+ => RowNumber -> Result columns -> io y

225−getRow (RowNumber r) = Value $ \ (Result result :: Result pgs) -> do

201+getRow (RowNumber r) (Result result :: Result columns) = do

202+ let len = fromIntegral (lengthSList (Proxy @columns))

226− maybeBytestrings <- traverse (liftBase . LibPQ.getvalue result r)

203+ row' <- traverse (liftBase . LibPQ.getvalue result r) [0 .. len - 1]

227− [0 .. fromIntegral (lengthSList (Proxy :: Proxy pgs)) - 1]

228− case fromList (catMaybes maybeBytestrings) of

204+ case fromList row' of

229− Nothing -> mzero

205+ Nothing -> error "getRow: found unexpected length"

230− Just bytestrings -> case decodings (Proxy :: Proxy pgs) bytestrings of

231− Left err -> throwError err

232− Right row -> return row

206+ Just row -> return $ fromRow @columns row