0b34a14 · rel8 · git.iko.soy

git.iko.soy/rel8

Clean up Serializable and introduce litTable

Also teach Sql to be smart enough to know that if you have a `DBType a`, then you can always make an `Sql DBType a` from that. This, along with the `lit`/`Serializable` fixes, lets us remove a lot of nonsense constraints from the test suite.

commit0b34a1425ef7ba254a5afd180bb3ffc18b1b45a3 authorShane O'Brien <shane.obrien@circuithub.com> dateThu 25 Mar 2021, 04:57 (6 years ago) parentc220b00

18 files changed+192−262

compare with master

unifiedsplit

src/Rel8/Aggregate.hs+2−2 src/Rel8/Expr.hs+1−10 src/Rel8/Opaque.hs+3−8 src/Rel8/Schema/Insert.hs+2−2 src/Rel8/Schema/Name.hs+2−2 src/Rel8/Schema/Nullability.hs+6−6 src/Rel8/Table.hs+4−4 src/Rel8/Table/Recontextualize.hs+2−13 src/Rel8/Table/Serialize.hs+84−188 src/Rel8/Type.hs+11−1 src/Rel8/Type/Eq.hs+6−1 src/Rel8/Type/Monoid.hs+9−1 src/Rel8/Type/Num.hs+17 src/Rel8/Type/Ord.hs+14−1 src/Rel8/Type/Semigroup.hs+6−1 src/Rel8/Type/String.hs+8 src/Rel8/Type/Sum.hs+9 tests/Main.hs+6−22

src/Rel8/Aggregate.hs+2−2

@@ -36,7 +36,7 @@ import qualified Opaleye.Internal.PackMap as Opaleye

3636-- rel8

3737import Rel8.Expr ( Expr, Col(..) )

3838import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

39−import Rel8.Opaque ( Opaque, Opaque1 )

39+import Rel8.Opaque ( Opaque )

4040import Rel8.Schema.Context ( Interpretation(..) )

4141import Rel8.Schema.Context.Label ( Labelable(..) )

4242import Rel8.Schema.Context.Nullify

@@ -146,7 +146,7 @@ instance Nullifiable Aggregate where

146146type Aggregates :: Type -> Type -> Constraint

147147class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

148148instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

149−instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregate Opaque) (Opaque1 Expr Opaque)

149+instance {-# OVERLAPPING #-} Aggregates (Opaque Aggregate Opaque) (Opaque Expr Opaque)

150150

151151

152152foldInputs :: Monoid b

src/Rel8/Expr.hs+1−10

@@ -1,6 +1,5 @@

11{-# language DataKinds #-}

22{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language GADTs #-}

65{-# language MultiParamTypeClasses #-}

@@ -16,13 +15,12 @@

1615module Rel8.Expr

1716 ( Expr(..)

1817 , Col( DB, unDB )

19− , Encodes

2018 )

2119where

2220

2321-- base

2422import Data.Functor.Identity ( Identity )

25−import Data.Kind ( Constraint, Type )

23+import Data.Kind ( Type )

2624import Data.String ( IsString, fromString )

2725import Prelude hiding ( null )

2826

@@ -38,7 +36,6 @@ import Rel8.Expr.Opaleye

3836 , zipPrimExprsWith

3937 )

4038import Rel8.Expr.Serialize ( litExpr )

41−import Rel8.Opaque ( Opaque, Opaque1 )

4239import Rel8.Schema.Context ( Interpretation, Col )

4340import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

4441import Rel8.Schema.Context.Nullify

@@ -143,9 +140,3 @@ instance Nullifiable Expr where

143140 {-# INLINABLE decodeTag #-}

144141 {-# INLINABLE nullifier #-}

145142 {-# INLINABLE unnullifier #-}

146−

147−

148−type Encodes :: Type -> Type -> Constraint

149−class Recontextualize Identity Expr a exprs => Encodes a exprs

150−instance Recontextualize Identity Expr a exprs => Encodes a exprs

151−instance {-# OVERLAPPING #-} Encodes (Opaque1 Identity Opaque) (Opaque1 Expr Opaque)

src/Rel8/Opaque.hs+3−8

@@ -1,20 +1,15 @@

11{-# language PolyKinds #-}

22{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilies #-}

45module Rel8.Opaque

56 ( Opaque

6− , Opaque1

77 )

88where

1010-- base

11−import Data.Kind ( Type )

1211import Prelude ()

1312

1413

15−type Opaque :: Type

16−data Opaque

17−

18−

19−type Opaque1 :: k -> Type -> Type

20−data Opaque1 a x

14+type Opaque :: k

15+data family Opaque :: k

src/Rel8/Schema/Insert.hs+2−2

@@ -31,7 +31,7 @@ import Prelude

3131import Rel8.Aggregate ( Aggregate )

3232import Rel8.Expr ( Expr )

3333import Rel8.Kind.Necessity ( Necessity(Optional, Required) )

34−import Rel8.Opaque ( Opaque, Opaque1 )

34+import Rel8.Opaque ( Opaque )

3535import Rel8.Schema.Context ( Interpretation(..) )

3636import Rel8.Schema.Context.Label ( Labelable(..) )

3737import Rel8.Schema.Context.Nullify

@@ -157,4 +157,4 @@ instance Nullifiable Insert where

157157type Inserts :: Type -> Type -> Constraint

158158class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts

159159instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts

160−instance {-# OVERLAPPING #-} Inserts (Opaque1 Expr Opaque) (Opaque1 Insert Opaque)

160+instance {-# OVERLAPPING #-} Inserts (Opaque Expr Opaque) (Opaque Insert Opaque)

src/Rel8/Schema/Name.hs+2−2

@@ -29,7 +29,7 @@ import Prelude

2929-- rel8

3030import Rel8.Expr ( Expr )

3131import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )

32−import Rel8.Opaque ( Opaque, Opaque1 )

32+import Rel8.Opaque ( Opaque )

3333import Rel8.Schema.Context ( Interpretation, Col )

3434import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

3535import Rel8.Schema.Context.Nullify

@@ -109,4 +109,4 @@ nameFromLabel = case labelsSing @labels of

109109type Selects :: Type -> Type -> Constraint

110110class Recontextualize Name Expr names exprs => Selects names exprs

111111instance Recontextualize Name Expr names exprs => Selects names exprs

112−instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 Expr Opaque)

112+instance {-# OVERLAPPING #-} Selects (Opaque Name Opaque) (Opaque Expr Opaque)

src/Rel8/Schema/Nullability.hs+6−6

@@ -56,8 +56,8 @@ type Nullify a = Maybe (Unnullify a)

5656

5757

5858type NotNull :: Type -> Constraint

59−class IsMaybe a ~ 'False => NotNull a

60−instance IsMaybe a ~ 'False => NotNull a

59+class (HasNullability a, IsMaybe a ~ 'False) => NotNull a

60+instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a

6161instance {-# OVERLAPPING #-} NotNull Opaque

6262

6363

@@ -76,18 +76,18 @@ data Nullability a where

7676type HasNullability' :: Bool -> Type -> Constraint

7777class

7878 ( IsMaybe a ~ isMaybe

79− , NotNull (Unnullify a)

79+ , IsMaybe (Unnullify a) ~ 'False

8080 , Nullify' isMaybe (Unnullify a) ~ a

8181 ) => HasNullability' isMaybe a

8282 where

8383 nullabilization' :: Nullability a

8484

8585

86−instance NotNull a => HasNullability' 'False a where

86+instance IsMaybe a ~ 'False => HasNullability' 'False a where

8787 nullabilization' = NonNullable

8888

8989

90−instance NotNull a => HasNullability' 'True (Maybe a) where

90+instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where

9191 nullabilization' = Nullable

9292

9393

@@ -115,4 +115,4 @@ class

115115 )

116116 => Sql constraint a

117117instance (constraint (Unnullify a), HasNullability a) => Sql constraint a

118−instance {-# OVERLAPPING #-} (constraint Opaque, Sql constraint Opaque) => Sql constraint Opaque

118+instance {-# OVERLAPPING #-} (c Opaque, Sql c Opaque) => Sql c Opaque

src/Rel8/Table.hs+4−4

@@ -21,7 +21,7 @@ import Prelude

2121

2222-- rel8

2323import {-# SOURCE #-} Rel8.Expr ( Expr )

24−import Rel8.Opaque ( Opaque, Opaque1 )

24+import Rel8.Opaque ( Opaque )

2525import Rel8.Schema.Context ( Col(..) )

2626import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

2727import Rel8.Schema.HTable ( HTable )

@@ -207,9 +207,9 @@ instance Table Expr Opaque where

207207 toColumns = error "opaque"

208208

209209

210−instance Table context (Opaque1 context a) where

211− type Columns (Opaque1 context a) = HType Opaque

212− type Context (Opaque1 context a) = context

210+instance Table context (Opaque context a) where

211+ type Columns (Opaque context a) = HType Opaque

212+ type Context (Opaque context a) = context

213213

214214 fromColumns = error "opaque"

215215 toColumns = error "opaque"

src/Rel8/Table/Recontextualize.hs+2−13

@@ -17,7 +17,7 @@ import Data.Kind ( Constraint, Type )

1717import Prelude ()

1818

1919-- rel8

20−import Rel8.Opaque ( Opaque1 )

20+import Rel8.Opaque ( Opaque )

2121import Rel8.Schema.Context ( Col )

2222import Rel8.Schema.Context.Label ( Labelable )

2323import Rel8.Schema.HTable ( HTable )

@@ -85,7 +85,7 @@ instance Sql DBType a => Recontextualize Name Insertion (Name a) (Insertion a)

8585-}

8686

8787

88−instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)

88+instance Recontextualize from to (Opaque from a) (Opaque to a)

8989

9090

9191instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))

@@ -131,14 +131,3 @@ instance

131131 , Recontextualize from to a5 b5

132132 , Labelable from, Labelable to

133133 ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)

134−

135−

136−{-

137−

138−-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting

139−-- with the table @b@.

140−type Inserts :: Type -> Type -> Constraint

141−class Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts

142−instance Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts

143−instance {-# OVERLAPPING #-} Inserts (Opaque1 Expr Opaque) (Opaque1 Insertion Opaque)

144−-}

src/Rel8/Table/Serialize.hs+84−188

@@ -14,6 +14,7 @@

1414

1515module Rel8.Table.Serialize

1616 ( Serializable, lit, parse

17+ , Encodes, litTable

1718 )

1819where

1920

@@ -28,9 +29,8 @@ import Prelude

2829import qualified Hasql.Decoders as Hasql

2930

3031-- rel8

31−import Rel8.Expr ( Expr, Encodes, Col(..) )

32+import Rel8.Expr ( Expr, Col(..) )

3233import Rel8.Expr.Serialize ( slitExpr, sparseValue )

33−import Rel8.Opaque ( Opaque )

3434import Rel8.Schema.Context ( Col(..) )

3535import Rel8.Schema.Context.Identity

3636 ( fromHEitherTable, toHEitherTable

@@ -54,6 +54,7 @@ import Rel8.Table.Either ( EitherTable )

5454import Rel8.Table.List ( ListTable )

5555import Rel8.Table.Maybe ( MaybeTable )

5656import Rel8.Table.NonEmpty ( NonEmptyTable )

57+import Rel8.Table.Recontextualize ( Recontextualize )

5758import Rel8.Table.These ( TheseTable )

5859import Rel8.Type ( DBType )

5960

@@ -64,160 +65,44 @@ import Data.Functor.Apply ( WrappedApplicative(..) )

6465import Data.These ( These )

6566

6667

67−type IsPlainColumn :: Type -> Bool

68−type family IsPlainColumn a where

69− IsPlainColumn (Either _ _) = 'False

70− IsPlainColumn [_] = 'False

71− IsPlainColumn (Maybe _) = 'False

72− IsPlainColumn (NonEmpty _) = 'False

73− IsPlainColumn (These _ _) = 'False

74− IsPlainColumn (_, _) = 'False

75− IsPlainColumn (_, _, _) = 'False

76− IsPlainColumn (_, _, _, _) = 'False

77− IsPlainColumn (_, _, _, _, _) = 'False

78− IsPlainColumn (_ Identity) = 'False

79− IsPlainColumn (_ (Col Identity _)) = 'False

80− IsPlainColumn (Identity _) = 'False

81− IsPlainColumn _ = 'True

82−

83−

84−type IsTabular :: Type -> Bool

85−type family IsTabular a where

86− IsTabular (Either _ _) = 'True

87− IsTabular [a] = IsListTabular a

88− IsTabular (Maybe a) = IsMaybeTabular a

89− IsTabular (NonEmpty a) = IsListTabular a

90− IsTabular (These _ _) = 'True

91− IsTabular (_, _) = 'True

92− IsTabular (_, _, _) = 'True

93− IsTabular (_, _, _, _) = 'True

94− IsTabular (_, _, _, _, _) = 'True

95− IsTabular (_ Identity) = 'True

96− IsTabular (_ (Col Identity)) = 'True

97− IsTabular (Col Identity _) = 'True

98− IsTabular _ = 'False

99−

100−

101−type IsTabular' :: Bool -> Type -> Bool

102−type family IsTabular' isTabular exprs where

103− IsTabular' _ (Expr _) = 'False

104− IsTabular' 'False _ = 'False

105− IsTabular' _ _ = 'True

106−

107−

108−type IsMaybeTabular :: Type -> Bool

109−type family IsMaybeTabular a where

110− IsMaybeTabular (Maybe _) = 'True

111− IsMaybeTabular a = IsTabular a

112−

113−

114−type IsListTabular :: Type -> Bool

115−type family IsListTabular a where

116− IsListTabular (Maybe a) = IsMaybeTabular a

117− IsListTabular a = IsTabular a

118−

119−

120−type ToExprs :: Type -> Type -> Constraint

121−class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs

122−instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs

123−

124−

12568fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a

126−fromIdentity' = fromIdentity @(IsPlainColumn a) @_ @_ @exprs

69+fromIdentity' = fromIdentity @_ @exprs

12770

12871

12972toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)

130−toIdentity' = toIdentity @(IsPlainColumn a) @_ @_ @exprs

73+toIdentity' = toIdentity @_ @exprs

13174

13275

133−type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint

134−class (Table Expr exprs, isTabular ~ IsTabular a) =>

135− ExprsFor isPlainColumn isTabular a exprs where

76+type ToExprs :: Type -> Type -> Constraint

77+class Table Expr exprs => ToExprs a exprs where

13678 fromIdentity :: Columns exprs (Col Identity) -> a

13779 toIdentity :: a -> Columns exprs (Col Identity)

13880

13981

140−instance

141− ( DBType a

142− , NotNull a

143− , IsTabular a ~ 'False

144− , x ~ Expr a

145− )

146− => ExprsFor 'True 'False a x

147− where

82+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where

14883 fromIdentity (HType (Result a)) = a

14984 toIdentity = HType . Result

15085

15186

152−instance

153− ( Sql DBType a

154− , IsListTabular a ~ 'False

155− , x ~ [a]

156− ) => ExprsFor 'False 'False [a] (Expr x)

157− where

87+instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where

15888 fromIdentity (HType (Result a)) = a

15989 toIdentity = HType . Result

16090

16191

162−instance

163− ( Sql DBType a

164− , isTabular ~ 'False

165− , NotNull a

166− , IsMaybeTabular a ~ 'False

167− , x ~ Maybe a

168− ) => ExprsFor 'False 'False (Maybe a) (Expr x)

92+instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)

16993 where

17094 fromIdentity (HType (Result a)) = a

17195 toIdentity = HType . Result

17296

17397

174−instance

175− ( Sql DBType a

176− , IsListTabular a ~ 'False

177− , x ~ NonEmpty a

178− ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)

98+instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)

17999 where

180100 fromIdentity (HType (Result a)) = a

181101 toIdentity = HType . Result

182102

183103

184−instance

185− ( ToExprs a exprs

186− , IsListTabular a ~ 'False

187− ) => ExprsFor 'False 'False [a] (ListTable exprs)

188− where

189− fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable

190− toIdentity = toHListTable . fmap (toIdentity' @exprs)

191−

192−

193−instance

194− ( ToExprs a exprs

195− , IsMaybeTabular a ~ 'False

196− ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)

197− where

198− fromIdentity =

199− fmap (fromIdentity' @exprs . hunlabel unlabeler) .

200− fromHMaybeTable

201− toIdentity =

202− toHMaybeTable .

203− fmap (hlabel labeler . toIdentity' @exprs)

204−

205−

206−instance

207− ( ToExprs a exprs

208− , IsListTabular a ~ 'False

209− ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)

210− where

211− fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable

212− toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)

213−

214−

215−instance

216− ( ToExprs a exprs1

217− , ToExprs b exprs2

218− , isTabular ~ 'True

219− , x ~ EitherTable exprs1 exprs2

220− ) => ExprsFor 'False isTabular (Either a b) x

104+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>

105+ ToExprs (Either a b) x

221106 where

222107 fromIdentity =

223108 bimap

@@ -231,22 +116,12 @@ instance

231116 (hlabel labeler . toIdentity' @exprs2)

232117

233118

234−instance

235− ( ToExprs a exprs

236− , IsListTabular a ~ 'True

237− , x ~ ListTable exprs

238− ) => ExprsFor 'False 'True [a] x

239− where

119+instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where

240120 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable

241121 toIdentity = toHListTable . fmap (toIdentity' @exprs)

242122

243123

244−instance

245− ( ToExprs a exprs

246− , IsMaybeTabular a ~ 'True

247− , x ~ MaybeTable exprs

248− ) => ExprsFor 'False 'True (Maybe a) x

249− where

124+instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where

250125 fromIdentity =

251126 fmap (fromIdentity' @exprs . hunlabel unlabeler) .

252127 fromHMaybeTable

@@ -255,22 +130,14 @@ instance

255130 fmap (hlabel labeler . toIdentity' @exprs)

256131

257132

258−instance

259− ( ToExprs a exprs

260− , IsListTabular a ~ 'True

261− , x ~ NonEmptyTable exprs

262− ) => ExprsFor 'False 'True (NonEmpty a) x

133+instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)

263134 where

264135 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable

265136 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)

266137

267138

268−instance

269− ( ToExprs a exprs1

270− , ToExprs b exprs2

271− , isTabular ~ 'True

272− , x ~ TheseTable exprs1 exprs2

273− ) => ExprsFor 'False isTabular (These a b) x

139+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>

140+ ToExprs (These a b) x

274141 where

275142 fromIdentity =

276143 bimap

@@ -284,12 +151,8 @@ instance

284151 (hlabel labeler . toIdentity' @exprs2)

285152

286153

287−instance

288− ( ToExprs a exprs1

289− , ToExprs b exprs2

290− , isTabular ~ 'True

291− , x ~ (exprs1, exprs2)

292− ) => ExprsFor 'False isTabular (a, b) x

154+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>

155+ ToExprs (a, b) x

293156 where

294157 fromIdentity (HPair a b) =

295158 ( fromIdentity' @exprs1 $ hunlabel unlabeler a

@@ -305,9 +168,8 @@ instance

305168 ( ToExprs a exprs1

306169 , ToExprs b exprs2

307170 , ToExprs c exprs3

308− , isTabular ~ 'True

309171 , x ~ (exprs1, exprs2, exprs3)

310− ) => ExprsFor 'False isTabular (a, b, c) x

172+ ) => ToExprs (a, b, c) x

311173 where

312174 fromIdentity (HTrio a b c) =

313175 ( fromIdentity' @exprs1 $ hunlabel unlabeler a

@@ -326,9 +188,8 @@ instance

326188 , ToExprs b exprs2

327189 , ToExprs c exprs3

328190 , ToExprs d exprs4

329− , isTabular ~ 'True

330191 , x ~ (exprs1, exprs2, exprs3, exprs4)

331− ) => ExprsFor 'False isTabular (a, b, c, d) x

192+ ) => ToExprs (a, b, c, d) x

332193 where

333194 fromIdentity (HQuartet a b c d) =

334195 ( fromIdentity' @exprs1 $ hunlabel unlabeler a

@@ -350,9 +211,8 @@ instance

350211 , ToExprs c exprs3

351212 , ToExprs d exprs4

352213 , ToExprs e exprs5

353− , isTabular ~ 'True

354214 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)

355− ) => ExprsFor 'False isTabular (a, b, c, d, e) x

215+ ) => ToExprs (a, b, c, d, e) x

356216 where

357217 fromIdentity (HQuintet a b c d e) =

358218 ( fromIdentity' @exprs1 $ hunlabel unlabeler a

@@ -370,34 +230,22 @@ instance

370230 }

371231

372232

373−instance

374− ( HTable t

375− , isTabular ~ 'True

376− , result ~ Col Identity

377− , x ~ t (Col Expr)

378− ) => ExprsFor 'False isTabular (t result) x

233+instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>

234+ ToExprs (t result) x

379235 where

380236 fromIdentity = id

381237 toIdentity = id

382238

383239

384−instance

385− ( Encodes (t Identity) (t Expr)

386− , isTabular ~ 'True

387− , result ~ Identity

388− , x ~ t Expr

389− ) => ExprsFor 'False isTabular (t result) x

240+instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>

241+ ToExprs (t result) x

390242 where

391243 fromIdentity = fromColumns

392244 toIdentity = toColumns

393245

394246

395−instance

396− ( KnownSpec spec

397− , isTabular ~ 'True

398− , isSpecial ~ 'True

399− , x ~ Col Expr spec

400− ) => ExprsFor 'False isTabular (Col Identity spec) x

247+instance (KnownSpec spec, x ~ Col Expr spec) =>

248+ ToExprs (Col Identity spec) x

401249 where

402250 fromIdentity = fromColumns

403251 toIdentity = toColumns

@@ -425,27 +273,75 @@ type family FromExprs a where

425273-- | @Serializable@ witnesses the one-to-one correspondence between the type

426274-- @sql@, which contains SQL expressions, and the type @haskell@, which

427275-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

276+type Serializable :: Type -> Type -> Constraint

428277class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a

429278instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a

430−instance Serializable (Expr Opaque) Opaque

279+instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

431280

432281

433282lit :: forall exprs a. Serializable exprs a => a -> exprs

434−lit = fromColumns . litTable . toIdentity' @exprs

283+lit = fromColumns . litHTable . toIdentity' @exprs

435284

436285

437286parse :: forall exprs a. Serializable exprs a => Hasql.Row a

438−parse = fromIdentity' @exprs <$> parseTable

287+parse = fromIdentity' @exprs <$> parseHTable

288+

289+

290+type Encodes :: Type -> Type -> Constraint

291+class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a

292+

293+

294+instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)

295+

296+

297+instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)

298+

299+

300+instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))

301+

302+

303+instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)

304+

305+

306+instance Encodes a x => Encodes [a] (ListTable x)

307+

308+

309+instance Encodes a x => Encodes (Maybe a) (MaybeTable x)

310+

311+

312+instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)

313+

314+

315+instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)

316+

317+

318+instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)

319+

320+

321+instance (Encodes a x, Encodes b y, Encodes c z) =>

322+ Encodes (a, b, c) (x, y, z)

323+

324+

325+instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>

326+ Encodes (a, b, c, d) (w, x, y, z)

327+

328+

329+instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>

330+ Encodes (a, b, c, d, e) (v, w, x, y, z)

331+

332+

333+litTable :: Encodes a exprs => a -> exprs

334+litTable = lit

439335

440336

441−litTable :: Encodes a b => a -> b

442−litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->

337+litHTable :: HTable t => t (Col Identity) -> t (Col Expr)

338+litHTable as = htabulate $ \field ->

443339 case hfield hspecs field of

444340 SSpec {nullability, info} -> case hfield as field of

445341 Result value -> DB (slitExpr nullability info value)

446342

447343

448−parseTable :: Table Identity a => Hasql.Row a

449−parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

344+parseHTable :: HTable t => Hasql.Row (t (Col Identity))

345+parseHTable = unwrapApplicative $ htabulateA $ \field ->

450346 WrapApplicative $ case hfield hspecs field of

451347 SSpec {nullability, info} -> Result <$> sparseValue nullability info

src/Rel8/Type.hs+11−1

@@ -1,7 +1,9 @@

11{-# language FlexibleInstances #-}

2+{-# language MultiParamTypeClasses #-}

23{-# language StandaloneKindSignatures #-}

34{-# language TypeApplications #-}

45{-# language UndecidableInstances #-}

6+{-# language UndecidableInstances #-}

68module Rel8.Type

79 ( DBType (typeInformation)

@@ -36,7 +38,11 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )

3638

3739-- rel8

3840import Rel8.Opaque ( Opaque )

39−import Rel8.Schema.Nullability ( NotNull, Sql, nullabilization )

41+import Rel8.Schema.Nullability

42+ ( NotNull, Unnullify

43+ , HasNullability, nullabilization

44+ , Sql

45+ )

4046import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

4147import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )

4248

@@ -311,3 +317,7 @@ instance Sql DBType a => DBType (NonEmpty a) where

311317

312318instance {-# OVERLAPPING #-} DBType Opaque where

313319 typeInformation = error "opaque"

320+

321+

322+instance {-# INCOHERENT #-} (HasNullability a, DBType (Unnullify a)) =>

323+ Sql DBType a

src/Rel8/Type/Eq.hs+6−1

@@ -1,5 +1,6 @@

11{-# language FlexibleContexts #-}

22{-# language FlexibleInstances #-}

3+{-# language MultiParamTypeClasses #-}

34{-# language StandaloneKindSignatures #-}

45{-# language UndecidableInstances #-}

@@ -26,7 +27,7 @@ import Data.CaseInsensitive ( CI )

2627

2728-- rel8

2829import Rel8.Opaque ( Opaque )

29−import Rel8.Schema.Nullability ( Sql )

30+import Rel8.Schema.Nullability ( Unnullify, HasNullability, Sql )

3031import Rel8.Type ( DBType )

3132

3233-- scientific

@@ -107,3 +108,7 @@ instance DBEq Value

107108instance Sql DBEq a => DBEq [a]

108109instance Sql DBEq a => DBEq (NonEmpty a)

109110instance DBEq Opaque

111+

112+

113+instance {-# INCOHERENT #-} (HasNullability a, DBEq (Unnullify a)) =>

114+ Sql DBEq a

src/Rel8/Type/Monoid.hs+9−1

@@ -1,6 +1,7 @@

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

45{-# language OverloadedStrings #-}

56{-# language StandaloneKindSignatures #-}

67{-# language TypeFamilies #-}

@@ -26,7 +27,10 @@ import Data.CaseInsensitive ( CI )

2627import {-# SOURCE #-} Rel8.Expr ( Expr )

2728import Rel8.Expr.Array ( sempty )

2829import Rel8.Expr.Serialize ( litExpr )

29−import Rel8.Schema.Nullability ( Sql, nullabilization )

30+import Rel8.Schema.Nullability

31+ ( Unnullify

32+ , Sql, HasNullability, nullabilization

33+ )

3034import Rel8.Type ( DBType, typeInformation )

3135import Rel8.Type.Semigroup ( DBSemigroup )

3236

@@ -80,3 +84,7 @@ instance DBMonoid ByteString where

8084

8185instance DBMonoid Lazy.ByteString where

8286 memptyExpr = litExpr ""

87+

88+

89+instance {-# INCOHERENT #-} (HasNullability a, DBMonoid (Unnullify a)) =>

90+ Sql DBMonoid a

src/Rel8/Type/Num.hs+17

@@ -1,6 +1,10 @@

11{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

25{-# language StandaloneKindSignatures #-}

36{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

59module Rel8.Type.Num

610 ( DBNum, DBIntegral, DBFractional

@@ -13,6 +17,7 @@ import Data.Kind ( Constraint, Type )

1317import Prelude

1418

1519-- rel8

20+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )

1621import Rel8.Type ( DBType )

1722

1823-- scientific

@@ -31,6 +36,10 @@ instance DBNum Double

3136instance DBNum Scientific

3237

3338

39+instance {-# INCOHERENT #-} (HasNullability a, DBNum (Unnullify a)) =>

40+ Sql DBNum a

41+

42+

3443type DBIntegral :: Type -> Constraint

3544class DBNum a => DBIntegral a

3645instance DBIntegral Int16

@@ -38,8 +47,16 @@ instance DBIntegral Int32

3847instance DBIntegral Int64

3948

4049

50+instance {-# INCOHERENT #-} (HasNullability a, DBIntegral (Unnullify a)) =>

51+ Sql DBIntegral a

52+

53+

4154-- | The class of database types that support the @/@ operator.

4255class DBNum a => DBFractional a

4356instance DBFractional Float

4457instance DBFractional Double

4558instance DBFractional Scientific

59+

60+

61+instance {-# INCOHERENT #-} (HasNullability a, DBFractional (Unnullify a)) =>

62+ Sql DBFractional a

src/Rel8/Type/Ord.hs+14−1

@@ -1,5 +1,6 @@

11{-# language FlexibleContexts #-}

22{-# language FlexibleInstances #-}

3+{-# language MultiParamTypeClasses #-}

34{-# language StandaloneKindSignatures #-}

45{-# language UndecidableInstances #-}

@@ -24,7 +25,7 @@ import Data.CaseInsensitive ( CI )

2425

2526-- rel8

2627import Rel8.Opaque ( Opaque )

27−import Rel8.Schema.Nullability ( Sql )

28+import Rel8.Schema.Nullability ( Unnullify, Sql, HasNullability )

2829import Rel8.Type.Eq ( DBEq )

2930

3031-- scientific

@@ -73,6 +74,10 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

7374instance {-# OVERLAPPING #-} DBOrd Opaque

7475

7576

77+instance {-# INCOHERENT #-} (HasNullability a, DBOrd (Unnullify a)) =>

78+ Sql DBOrd a

79+

80+

7681-- | The class of database types that support the @max@ aggregation function.

7782type DBMax :: Type -> Constraint

7883class DBOrd a => DBMax a

@@ -100,6 +105,10 @@ instance Sql DBMax a => DBMax [a]

100105instance Sql DBMax a => DBMax (NonEmpty a)

101106

102107

108+instance {-# INCOHERENT #-} (HasNullability a, DBMax (Unnullify a)) =>

109+ Sql DBMax a

110+

111+

103112-- | The class of database types that support the @min@ aggregation function.

104113type DBMin :: Type -> Constraint

105114class DBOrd a => DBMin a

@@ -125,3 +134,7 @@ instance DBMin ByteString

125134instance DBMin Lazy.ByteString

126135instance Sql DBMin a => DBMin [a]

127136instance Sql DBMin a => DBMin (NonEmpty a)

137+

138+

139+instance {-# INCOHERENT #-} (HasNullability a, DBMin (Unnullify a)) =>

140+ Sql DBMin a

src/Rel8/Type/Semigroup.hs+6−1

@@ -1,6 +1,7 @@

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

45{-# language ScopedTypeVariables #-}

56{-# language StandaloneKindSignatures #-}

67{-# language TypeApplications #-}

@@ -30,7 +31,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

3031-- rel8

3132import {-# SOURCE #-} Rel8.Expr ( Expr )

3233import Rel8.Expr.Opaleye ( zipPrimExprsWith )

33−import Rel8.Schema.Nullability ( Sql )

34+import Rel8.Schema.Nullability ( Unnullify, Sql, HasNullability )

3435import Rel8.Type ( DBType )

3536

3637-- text

@@ -88,3 +89,7 @@ instance DBSemigroup ByteString where

8889

8990instance DBSemigroup Lazy.ByteString where

9091 (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

92+

93+

94+instance {-# INCOHERENT #-} (HasNullability a, DBSemigroup (Unnullify a)) =>

95+ Sql DBSemigroup a

src/Rel8/Type/String.hs+8

@@ -1,5 +1,8 @@

1+{-# language FlexibleContexts #-}

12{-# language FlexibleInstances #-}

3+{-# language MultiParamTypeClasses #-}

24{-# language StandaloneKindSignatures #-}

5+{-# language UndecidableInstances #-}

47module Rel8.Type.String

58 ( DBString

@@ -18,6 +21,7 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString )

1821import Data.CaseInsensitive ( CI )

1922

2023-- rel8

24+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )

2125import Rel8.Type ( DBType )

2226

2327-- text

@@ -35,3 +39,7 @@ instance DBString (CI Text)

3539instance DBString (CI Lazy.Text)

3640instance DBString ByteString

3741instance DBString Lazy.ByteString

42+

43+

44+instance {-# INCOHERENT #-} (HasNullability a, DBString (Unnullify a)) =>

45+ Sql DBString a

src/Rel8/Type/Sum.hs+9

@@ -1,6 +1,10 @@

11{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

25{-# language TypeFamilies #-}

36{-# language StandaloneKindSignatures #-}

7+{-# language UndecidableInstances #-}

59module Rel8.Type.Sum

610 ( DBSum

@@ -13,6 +17,7 @@ import Data.Kind ( Constraint, Type )

1317import Prelude

1418

1519-- rel8

20+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )

1621import Rel8.Type ( DBType )

1722

1823-- scientific

@@ -33,3 +38,7 @@ instance DBSum Double

3338instance DBSum Scientific

3439instance DBSum DiffTime

3540instance DBSum NominalDiffTime

41+

42+

43+instance {-# INCOHERENT #-} (HasNullability a, DBSum (Unnullify a)) =>

44+ Sql DBSum a

tests/Main.hs+6−22

@@ -404,19 +404,13 @@ testDBType getTestDatabase = testGroup "DBType instances"

404404 ]

405405

406406 where

407− dbTypeTest ::

408− ( Eq a, Show a

409− , Rel8.Sql Rel8.DBType a

410− , Rel8.IsMaybe a ~ 'False

411− , Rel8.Serializable (Rel8.Expr a) a

412− , Rel8.Serializable (Rel8.Expr (Maybe a)) (Maybe a)

413− ) => TestName -> Gen a -> TestTree

407+ dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

414408 dbTypeTest name generator = testGroup name

415409 [ databasePropertyTest name (t (==) generator) getTestDatabase

416410 , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

417411 ]

418412

419− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a, Rel8.Serializable (Rel8.Expr a) a)

413+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

420414 => (a -> a -> Bool)

421415 -> Gen a

422416 -> ((Connection -> TestT IO ()) -> PropertyT IO b)

@@ -425,7 +419,7 @@ testDBType getTestDatabase = testGroup "DBType instances"

425419 x <- forAll generator

426420

427421 transaction \connection -> do

428− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.lit x :: Rel8.Expr a)

422+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

429423 diff res eq x

430424

431425 genDay :: Gen Day

@@ -460,23 +454,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

460454 ]

461455

462456 where

463− dbEqTest ::

464− ( Eq a, Show a

465− , Rel8.Sql Rel8.DBEq a

466− , Rel8.IsMaybe a ~ 'False

467− , Rel8.Serializable (Rel8.Expr a) a

468− , Rel8.Serializable (Rel8.Expr (Maybe a)) (Maybe a)

469− ) => TestName -> Gen a -> TestTree

457+ dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree

470458 dbEqTest name generator = testGroup name

471459 [ databasePropertyTest name (t generator) getTestDatabase

472460 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

473461 ]

474462

475− t :: forall a.

476− ( Eq a, Show a

477− , Rel8.Sql Rel8.DBEq a

478− , Rel8.Serializable (Rel8.Expr a) a

479− )

463+ t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

480464 => Gen a

481465 -> ((Connection -> TestT IO ()) -> PropertyT IO ())

482466 -> PropertyT IO ()

@@ -484,7 +468,7 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

484468 (x, y) <- forAll (liftA2 (,) generator generator)

485469

486470 transaction \connection -> do

487− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.lit @(Rel8.Expr a) x Rel8.==. Rel8.lit y

471+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

488472 res === (x == y)

489473

490474 cover 1 "Equal" $ x == y