@@ -0,0 +1,138 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , FlexibleInstances
4+ , FunctionalDependencies
5+ , KindSignatures
6+ , MultiParamTypeClasses
7+ , PolyKinds
8+ , ScopedTypeVariables
9+ , TypeApplications
10+ , TypeFamilies
11+ , TypeOperators
12+#-}
13+
14+module Squeel.PostgreSQL.Value2 where
15+
16+import Control.Arrow (left)
17+import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
18+import Data.ByteString (ByteString)
19+import Data.Int (Int16,Int32,Int64)
20+import Data.Proxy
21+import Data.Vinyl
22+import Data.Vinyl.Functor
23+import PostgreSQL.Binary.Decoder (Decoder)
24+import PostgreSQL.Binary.Encoder (Encoder)
25+import Data.Proxy (Proxy)
26+import Data.Scientific (Scientific)
27+import Data.Text (Text)
28+import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
29+import Data.UUID (UUID)
30+
31+import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
32+import qualified Data.Text as Text (pack)
33+import qualified Data.Text.Lazy as Lazy (Text)
34+import qualified PostgreSQL.Binary.Decoder as Decoder
35+import qualified PostgreSQL.Binary.Encoder as Encoder
36+
37+import Squeel.PostgreSQL.Type2
38+
39+decodeValue :: FromValue pg x => Proxy pg -> ByteString -> Either Text x
40+decodeValue = Decoder.run . fromValue
41+
42+class FromValue (pg :: PGType) x where
43+ fromValue :: Proxy pg -> Decoder x
44+instance FromValue 'PGInt2 Int16 where
45+ fromValue _ = Decoder.int
46+instance FromValue 'PGInt4 Int32 where
47+ fromValue _ = Decoder.int
48+instance FromValue 'PGInt8 Int64 where
49+ fromValue _ = Decoder.int
50+instance FromValue 'PGFloat4 Float where
51+ fromValue _ = Decoder.float4
52+instance FromValue 'PGFloat8 Double where
53+ fromValue _ = Decoder.float8
54+instance FromValue 'PGBool Bool where
55+ fromValue _ = Decoder.bool
56+instance FromValue 'PGBytea ByteString where
57+ fromValue _ = Decoder.bytea_strict
58+instance FromValue 'PGBytea Lazy.ByteString where
59+ fromValue _ = Decoder.bytea_lazy
60+instance FromValue 'PGText Text where
61+ fromValue _ = Decoder.text_strict
62+instance FromValue 'PGText Lazy.Text where
63+ fromValue _ = Decoder.text_lazy
64+instance FromValue ('PGChar 1) Char where
65+ fromValue _ = Decoder.char
66+instance FromValue 'PGNumeric Scientific where
67+ fromValue _ = Decoder.numeric
68+instance FromValue 'PGUuid UUID where
69+ fromValue _ = Decoder.uuid
70+instance FromJSON x => FromValue 'PGJson x where
71+ fromValue _ = Decoder.json_bytes (left Text.pack . eitherDecodeStrict)
72+instance FromJSON x => FromValue 'PGJsonb x where
73+ fromValue _ = Decoder.jsonb_bytes (left Text.pack . eitherDecodeStrict)
74+instance FromValue 'PGDate Day where
75+ fromValue _ = Decoder.date
76+instance FromValue 'PGTime TimeOfDay where
77+ fromValue _ = Decoder.time_int
78+instance FromValue 'PGTimeTZ (TimeOfDay, TimeZone) where
79+ fromValue _ = Decoder.timetz_int
80+instance FromValue 'PGTimestamp LocalTime where
81+ fromValue _ = Decoder.timestamp_int
82+instance FromValue 'PGTimestampTZ UTCTime where
83+ fromValue _ = Decoder.timestamptz_int
84+instance FromValue 'PGInterval DiffTime where
85+ fromValue _ = Decoder.interval_int
86+
87+class ToValue x (pg :: PGType) where
88+ toValue :: Proxy pg -> Encoder x
89+instance ToValue Int16 'PGInt2 where
90+ toValue _ = Encoder.int2_int16
91+instance ToValue Int32 'PGInt4 where
92+ toValue _ = Encoder.int4_int32
93+instance ToValue Int64 'PGInt8 where
94+ toValue _ = Encoder.int8_int64
95+instance ToValue Float 'PGFloat4 where
96+ toValue _ = Encoder.float4
97+instance ToValue Double 'PGFloat8 where
98+ toValue _ = Encoder.float8
99+instance ToValue Bool 'PGBool where
100+ toValue _ = Encoder.bool
101+instance ToValue ByteString 'PGBytea where
102+ toValue _ = Encoder.bytea_strict
103+instance ToValue Lazy.ByteString 'PGBytea where
104+ toValue _ = Encoder.bytea_lazy
105+instance ToValue Text 'PGText where
106+ toValue _ = Encoder.text_strict
107+instance ToValue Lazy.Text 'PGText where
108+ toValue _ = Encoder.text_lazy
109+instance ToValue Char ('PGChar 1) where
110+ toValue _ = Encoder.char
111+instance ToValue Scientific 'PGNumeric where
112+ toValue _ = Encoder.numeric
113+instance ToValue UUID 'PGUuid where
114+ toValue _ = Encoder.uuid
115+instance ToJSON x => ToValue x 'PGJson where
116+ toValue _ = Encoder.json_bytes . Lazy.toStrict . encode
117+instance ToJSON x => ToValue x 'PGJsonb where
118+ toValue _ = Encoder.jsonb_bytes . Lazy.toStrict . encode
119+instance ToValue Day 'PGDate where
120+ toValue _ = Encoder.date
121+instance ToValue TimeOfDay 'PGTime where
122+ toValue _ = Encoder.time_int
123+instance ToValue (TimeOfDay, TimeZone) 'PGTimeTZ where
124+ toValue _ = Encoder.timetz_int
125+instance ToValue LocalTime 'PGTimestamp where
126+ toValue _ = Encoder.timestamp_int
127+instance ToValue UTCTime 'PGTimestampTZ where
128+ toValue _ = Encoder.timestamptz_int
129+instance ToValue DiffTime 'PGInterval where
130+ toValue _ = Encoder.interval_int
131+
132+class ToValues xs pgs where
133+ toValues :: Proxy pgs -> Rec Identity xs -> [ByteString]
134+instance ToValues '[] '[] where toValues _ _ = []
135+instance (ToValue x pg, ToValues xs pgs)
136+ => ToValues (x ': xs) (pg ': pgs) where
137+ toValues (_ :: Proxy (pg ': pgs)) (Identity x :& xs) =
138+ Encoder.run (toValue (Proxy @pg)) x : toValues (Proxy @pgs) xs