453171a · squeal · git.iko.soy

git.iko.soy/squeal

Fixing things

commit453171a84d5bfac70c6df4926476e6d549c94794 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 16 Jan 2019, 12:55 (8 years ago) parent6cccbf3

6 files changed+35−126

compare with dev

unifiedsplit

squeal-postgresql/exe/Example.hs+4−4 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+10−106 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+18−7 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs−5 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+1−2 squeal-postgresql/test/Specs/ExceptionHandling.hs+2−2

squeal-postgresql/exe/Example.hs+4−4

@@ -82,16 +82,16 @@ getUsers = select_

8282 & innerJoin (table (#emails `as` #e))

8383 (#u ! #id .== #e ! #user_id)) )

8484

85−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }

85+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }

8686 deriving (Show, GHC.Generic)

8787instance SOP.Generic User

8888instance SOP.HasDatatypeInfo User

8989

9090users :: [User]

9191users =

92− [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]

93− , User "Bob" Nothing [Just 2, Nothing]

94− , User "Carole" (Just "carole@hotmail.com") [Just 3]

92+ [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])

93+ , User "Bob" Nothing (VarArray [Just 2, Nothing])

94+ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])

9595 ]

9696

9797session :: (MonadBase IO pq, MonadPQ Schemas pq) => pq ()

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+10−106

@@ -59,9 +59,9 @@ create multi-dimensional fixed length arrays.

5959

6060>>> :{

6161data Row = Row

62− { col1 :: Vector Int16

63− , col2 :: (Maybe Int16,Maybe Int16)

64− , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))

62+ { col1 :: VarArray (Vector Int16)

63+ , col2 :: FixArray (Maybe Int16,Maybe Int16)

64+ , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))

6565 } deriving (Eq, GHC.Generic)

6666:}

6767

@@ -74,13 +74,13 @@ Once again, we define a simple round trip query.

7474let

7575 roundTrip :: Query_ (Public '[]) Row Row

7676 roundTrip = values_ $

77− parameter @1 (int2 & vararray) `as` #col1 :*

78− parameter @2 (int2 & fixarray @2) `as` #col2 :*

79− parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3

77+ parameter @1 (int2 & vararray) `as` #col1 :*

78+ parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*

79+ parameter @3 (int2 & fixarray @'[3,2]) `as` #col3

8080:}

8181

8282>>> :set -XOverloadedLists

83−>>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6))

83+>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))

8484>>> :{

8585void . withConnection "host=localhost port=5432 dbname=exampledb" $ do

8686 result <- runQueryParams roundTrip input

@@ -322,19 +322,9 @@ instance (ToParam x pg, HasOid pg)

322322 . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)

323323 . getVarArray

324324instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)

325− => ToParam (FixArray x) ('PGfixarray_ dims ty) where

325+ => ToParam (FixArray x) ('PGfixarray dims ty) where

326326 toParam = K . Encoding.array (oid @pg)

327327 . unK . unK . toFixArray @x @dims @ty . getFixArray

328−instance ToArray x ('NotNull ('PGvararray ty))

329− => ToParam x ('PGvararray ty) where

330− toParam

331− = K . Encoding.array (baseOid @x @('NotNull ('PGvararray ty)))

332− . unK . toArray @x @('NotNull ('PGvararray ty))

333−instance ToArray x ('NotNull ('PGfixarray n ty))

334− => ToParam x ('PGfixarray n ty) where

335− toParam

336− = K . Encoding.array (baseOid @x @('NotNull ('PGfixarray n ty)))

337− . unK . toArray @x @('NotNull ('PGfixarray n ty))

338328instance

339329 ( IsEnumType x

340330 , HasDatatypeInfo x

@@ -430,47 +420,6 @@ instance

430420 toFixArray = K . K . Encoding.dimensionArray foldlN

431421 (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from

432422

433−class ToArray (x :: Type) (array :: NullityType) where

434− toArray :: x -> K Encoding.Array array

435− baseOid :: Word32

436− default baseOid :: HasOid (PGTypeOf array) => Word32

437− baseOid = oid @(PGTypeOf array)

438−instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)

439− => ToArray x ('NotNull pg) where

440− toArray = K . Encoding.encodingArray . unK . toParam @x @pg

441−instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)

442− => ToArray (Maybe x) ('Null pg) where

443− toArray = K . maybe Encoding.nullArray

444− (Encoding.encodingArray . unK . toParam @x @pg)

445−instance {-# OVERLAPPING #-} ToArray x array

446− => ToArray (Vector x) ('NotNull ('PGvararray array)) where

447− toArray = K . Encoding.dimensionArray Vector.foldl'

448− (unK . toArray @x @array)

449− baseOid = baseOid @x @array

450−instance {-# OVERLAPPING #-} ToArray x array

451− => ToArray (Maybe (Vector x)) ('Null ('PGvararray array)) where

452− toArray = K . maybe Encoding.nullArray

453− (Encoding.dimensionArray Vector.foldl' (unK . toArray @x @array))

454− baseOid = baseOid @x @array

455−instance {-# OVERLAPPING #-}

456− ( IsProductType product xs

457− , Length xs ~ n

458− , All ((~) x) xs

459− , ToArray x array )

460− => ToArray product ('NotNull ('PGfixarray n array)) where

461− toArray = K . Encoding.dimensionArray foldlN

462− (unK . toArray @x @array) . unZ . unSOP . from

463− baseOid = baseOid @x @array

464−instance {-# OVERLAPPING #-}

465− ( IsProductType product xs

466− , Length xs ~ n

467− , All ((~) x) xs

468− , ToArray x array )

469− => ToArray (Maybe product) ('Null ('PGfixarray n array)) where

470− toArray = K . maybe Encoding.nullArray

471− (Encoding.dimensionArray foldlN (unK . toArray @x @array) . unZ . unSOP . from)

472− baseOid = baseOid @x @array

473−

474423-- | A `ToParams` constraint generically sequences the encodings of `Type`s

475424-- of the fields of a tuple or record to a row of `ColumnType`s. You should

476425-- not define instances of `ToParams`. Instead define `Generic` instances

@@ -567,14 +516,8 @@ instance FromValue pg y

567516 Decoding.array $ Decoding.dimensionArray rep

568517 (fromFixArray @'[] @('Null pg))

569518instance FromFixArray dims ty y

570− => FromValue ('PGfixarray_ dims ty) (FixArray y) where

519+ => FromValue ('PGfixarray dims ty) (FixArray y) where

571520 fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)

572−instance FromArray ('NotNull ('PGvararray ty)) y

573− => FromValue ('PGvararray ty) y where

574− fromValue = Decoding.array (fromArray @('NotNull ('PGvararray ty)) @y)

575−instance FromArray ('NotNull ('PGfixarray n ty)) y

576− => FromValue ('PGfixarray n ty) y where

577− fromValue = Decoding.array (fromArray @('NotNull ('PGfixarray n ty)) @y)

578521instance

579522 ( IsEnumType y

580523 , HasDatatypeInfo y

@@ -663,45 +606,6 @@ instance

663606 in

664607 Decoding.dimensionArray rep (fromFixArray @dims @ty @y)

665608

666−class FromArray (ty :: NullityType) (y :: Type) where

667− fromArray :: Decoding.Array y

668−instance {-# OVERLAPPABLE #-} FromValue pg y

669− => FromArray ('NotNull pg) y where

670− fromArray = Decoding.valueArray (fromValue @pg @y)

671−instance {-# OVERLAPPABLE #-} FromValue pg y

672− => FromArray ('Null pg) (Maybe y) where

673− fromArray = Decoding.nullableValueArray (fromValue @pg @y)

674−instance {-# OVERLAPPING #-} FromArray array y

675− => FromArray ('NotNull ('PGvararray array)) (Vector y) where

676− fromArray =

677− Decoding.dimensionArray Vector.replicateM (fromArray @array @y)

678−instance {-# OVERLAPPING #-} FromArray array y

679− => FromArray ('Null ('PGvararray array)) (Maybe (Vector y)) where

680− fromArray = Just <$>

681− Decoding.dimensionArray Vector.replicateM (fromArray @array @y)

682−instance {-# OVERLAPPING #-}

683− ( FromArray array y

684− , All ((~) y) ys

685− , SListI ys

686− , IsProductType product ys )

687− => FromArray ('NotNull ('PGfixarray n array)) product where

688− fromArray =

689− let

690− rep _ = fmap (to . SOP . Z) . replicateMN

691− in

692− Decoding.dimensionArray rep (fromArray @array @y)

693−instance {-# OVERLAPPING #-}

694− ( FromArray array y

695− , All ((~) y) ys

696− , SListI ys

697− , IsProductType product ys )

698− => FromArray ('Null ('PGfixarray n array)) (Maybe product) where

699− fromArray =

700− let

701− rep _ = fmap (to . SOP . Z) . replicateMN

702− in

703− Just <$> Decoding.dimensionArray rep (fromArray @array @y)

704−

705609-- | A `FromRow` constraint generically sequences the parsings of the columns

706610-- of a `RowType` into the fields of a record `Type` provided they have

707611-- the same field names. You should not define instances of `FromRow`.

@@ -796,7 +700,7 @@ type it's applied to should be stored as a `PGfixarray`.

796700-}

797701newtype FixArray arr = FixArray {getFixArray :: arr}

798702 deriving (Eq, Ord, Show, Read, GHC.Generic)

799−-- type instance PG (FixArray x) = 'PGfixarray (DimPG x) (FixPG x)

703+type instance PG (FixArray x) = 'PGfixarray (DimPG x) (FixPG x)

800704

801705type family DimPG (hask :: Type) :: [Nat] where

802706 DimPG (x,x) = 2 ': DimPG x

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+18−7

@@ -198,6 +198,7 @@ import GHC.OverloadedLabels

198198import GHC.TypeLits

199199import Prelude hiding (id, (.))

200200

201+import qualified Data.ByteString as ByteString

201202import qualified GHC.Generics as GHC

202203

203204import Squeal.PostgreSQL.Render

@@ -1738,14 +1739,24 @@ vararray

17381739vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"

17391740-- | fixed length array

17401741--

1741−-- >>> renderSQL (fixarray @2 json)

1742+-- >>> renderSQL (fixarray @'[2] json)

17421743-- "json[2]"

17431744fixarray

1744− :: forall n schemas nullity pg. KnownNat n

1745+ :: forall dims schemas nullity pg. All KnownNat dims

17451746 => TypeExpression schemas pg

1746− -> TypeExpression schemas (nullity ('PGfixarray n pg))

1747+ -> TypeExpression schemas (nullity ('PGfixarray dims pg))

17471748fixarray ty = UnsafeTypeExpression $

1748− renderSQL ty <> "[" <> renderNat @n <> "]"

1749+ renderSQL ty <> renderDims @dims

1750+ where

1751+ renderDims :: forall ns. All KnownNat ns => ByteString

1752+ renderDims =

1753+ ("[" <>)

1754+ . (<> "]")

1755+ . ByteString.intercalate "]["

1756+ . hcollapse

1757+ $ hcmap (Proxy @KnownNat)

1758+ (K . fromString . show . natVal)

1759+ (hpure Proxy :: NP Proxy ns)

17491760

17501761-- | `pgtype` is a demoted version of a `PGType`

17511762class PGTyped schemas (ty :: NullityType) where

@@ -1775,6 +1786,6 @@ instance PGTyped schemas (nullity 'PGjsonb) where pgtype = jsonb

17751786instance PGTyped schemas ty

17761787 => PGTyped schemas (nullity ('PGvararray ty)) where

17771788 pgtype = vararray (pgtype @schemas @ty)

1778−instance (KnownNat n, PGTyped schemas ty)

1779− => PGTyped schemas (nullity ('PGfixarray n ty)) where

1780− pgtype = fixarray @n (pgtype @schemas @ty)

1789+instance (All KnownNat dims, PGTyped schemas ty)

1790+ => PGTyped schemas (nullity ('PGfixarray dims ty)) where

1791+ pgtype = fixarray @dims (pgtype @schemas @ty)

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs−5

@@ -29,7 +29,6 @@ module Squeal.PostgreSQL.Render

2929 , renderCommaSeparated

3030 , renderCommaSeparatedMaybe

3131 , renderNat

32− , renderNats

3332 , renderSymbol

3433 , RenderSQL (..)

3534 , printSQL

@@ -99,10 +98,6 @@ renderCommaSeparatedMaybe render

9998renderNat :: forall n. KnownNat n => ByteString

10099renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))

101100

102−-- | Render a promoted list of `Nat`s.

103−renderNats :: forall ns. All KnownNat ns => ByteString

104−renderNats = undefined

105−

106101-- | Render a promoted `Symbol`.

107102renderSymbol :: forall s. KnownSymbol s => ByteString

108103renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+1−2

@@ -175,8 +175,7 @@ data PGType

175175 | PGjson -- ^ textual JSON data

176176 | PGjsonb -- ^ binary JSON data, decomposed

177177 | PGvararray NullityType -- ^ variable length array

178− | PGfixarray Nat NullityType -- ^ fixed length array

179− | PGfixarray_ [Nat] NullityType -- ^ fixed length array

178+ | PGfixarray [Nat] NullityType -- ^ fixed length array

180179 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.

181180 | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.

182181 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

squeal-postgresql/test/Specs/ExceptionHandling.hs+2−2

@@ -51,7 +51,7 @@ type Schemas = Public Schema

5151data User =

5252 User { userName :: Text

5353 , userEmail :: Maybe Text

54− , userVec :: Vector (Maybe Int16) }

54+ , userVec :: VarArray (Vector (Maybe Int16)) }

5555 deriving (Show, GHC.Generic)

5656instance SOP.Generic User

5757instance SOP.HasDatatypeInfo User

@@ -101,7 +101,7 @@ connectionString :: Char8.ByteString

101101connectionString = "host=localhost port=5432 dbname=exampledb"

102102

103103testUser :: User

104−testUser = User "TestUser" Nothing []

104+testUser = User "TestUser" Nothing (VarArray [])

105105

106106newUser :: (MonadBase IO m, MonadPQ Schemas m) => User -> m ()

107107newUser u = void $ manipulateParams insertUser (userName u, userVec u)