From 9e7a44757c19850e62700bbf08681550adc485b9 Mon Sep 17 00:00:00 2001 From: Shane Date: Tue, 15 Aug 2023 19:09:13 +0100 Subject: [PATCH] Add `length{,1}` functions for getting the length of `{List,NonEmpty}Table`s (#268) --- changelog.d/20230707_185339_ollie_scriv.md | 2 +- ...230815_190143_shane.obrien_array_length.md | 3 ++ src/Rel8.hs | 4 ++ src/Rel8/Expr/Array.hs | 11 ++--- src/Rel8/Expr/List.hs | 46 ++++++++++--------- src/Rel8/Expr/NonEmpty.hs | 46 ++++++++++--------- src/Rel8/Schema/HTable/Vectorize.hs | 21 ++++++++- src/Rel8/Table/List.hs | 19 ++++++-- src/Rel8/Table/NonEmpty.hs | 17 +++++-- src/Rel8/Type/Array.hs | 31 ++++++++++++- 10 files changed, 140 insertions(+), 60 deletions(-) create mode 100644 changelog.d/20230815_190143_shane.obrien_array_length.md diff --git a/changelog.d/20230707_185339_ollie_scriv.md b/changelog.d/20230707_185339_ollie_scriv.md index 09afb657..2e4b3522 100644 --- a/changelog.d/20230707_185339_ollie_scriv.md +++ b/changelog.d/20230707_185339_ollie_scriv.md @@ -1,3 +1,3 @@ ### Added -- `Rel8.head`, `Rel8.headTable`, `Rel8.last`, `Rel8.lastExpr` for accessing the first/last elements of arrays and `ListTable`s. We have also added variants for non-empty arrays/`NonEmptyTable` with the `1` suffix (e.g., `head1`). ([#245](https://github.com/circuithub/rel8/pull/245)) +- `Rel8.head`, `Rel8.headExpr`, `Rel8.last`, `Rel8.lastExpr` for accessing the first/last elements of `ListTable`s and arrays. We have also added variants for `NonEmptyTable`s/non-empty arrays with the `1` suffix (e.g., `head1`). ([#245](https://github.com/circuithub/rel8/pull/245)) diff --git a/changelog.d/20230815_190143_shane.obrien_array_length.md b/changelog.d/20230815_190143_shane.obrien_array_length.md new file mode 100644 index 00000000..70aed4ed --- /dev/null +++ b/changelog.d/20230815_190143_shane.obrien_array_length.md @@ -0,0 +1,3 @@ +### Added + +- `Rel8.length` and `Rel8.lengthExpr` for getting the length `ListTable`s and arrays. We have also added variants for `NonEmptyTable`s/non-empty arrays with the `1` suffix (e.g., `length1`). diff --git a/src/Rel8.hs b/src/Rel8.hs index fb4c95e0..74573e64 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -105,6 +105,8 @@ module Rel8 , headExpr , last , lastExpr + , length + , lengthExpr -- ** @NonEmptyTable@ , NonEmptyTable @@ -118,6 +120,8 @@ module Rel8 , head1Expr , last1 , last1Expr + , length1 + , length1Expr -- ** @NullTable@ , NullTable diff --git a/src/Rel8/Expr/Array.hs b/src/Rel8/Expr/Array.hs index c039302d..c1462919 100644 --- a/src/Rel8/Expr/Array.hs +++ b/src/Rel8/Expr/Array.hs @@ -12,7 +12,7 @@ module Rel8.Expr.Array where -- base -import Data.List.NonEmpty ( NonEmpty ) +import Data.List.NonEmpty (NonEmpty) import Prelude -- opaleye @@ -20,14 +20,11 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 import {-# SOURCE #-} Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye - ( fromPrimExpr, toPrimExpr - , zipPrimExprsWith - ) +import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr, zipPrimExprsWith) import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Array ( array ) +import Rel8.Type.Array (array) import Rel8.Type.Information ( TypeInformation(..) ) -import Rel8.Schema.Null ( Unnullify, Sql ) +import Rel8.Schema.Null (Unnullify, Sql) sappend :: Expr [a] -> Expr [a] -> Expr [a] diff --git a/src/Rel8/Expr/List.hs b/src/Rel8/Expr/List.hs index aed6fba9..3158a792 100644 --- a/src/Rel8/Expr/List.hs +++ b/src/Rel8/Expr/List.hs @@ -1,38 +1,42 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + module Rel8.Expr.List ( headExpr, - indexExpr, lastExpr, + sheadExpr, + slastExpr, + lengthExpr, ) where -- base -import Data.Int (Int64) +import Data.Int (Int32) import Prelude --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye - -- rel8 import Rel8.Expr (Expr) import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr) -import Rel8.Schema.Null (Nullify) +import Rel8.Schema.Null (Nullify, Sql, Unnullify) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation) +import qualified Rel8.Type.Array as Prim + + +headExpr :: Sql DBType a => Expr [a] -> Expr (Nullify a) +headExpr = sheadExpr typeInformation + + +lastExpr :: Sql DBType a => Expr [a] -> Expr (Nullify a) +lastExpr = slastExpr typeInformation -headExpr :: Expr [a] -> Expr (Nullify a) -headExpr array = indexExpr array index - where - index = fromPrimExpr $ Opaleye.FunExpr "array_lower" [toPrimExpr array, one] - where - one = Opaleye.ConstExpr (Opaleye.IntegerLit 1) +sheadExpr :: TypeInformation (Unnullify a) -> Expr [a] -> Expr (Nullify a) +sheadExpr info = fromPrimExpr . Prim.head info . toPrimExpr -indexExpr :: Expr [a] -> Expr Int64 -> Expr (Nullify a) -indexExpr array index = - fromPrimExpr (Opaleye.ArrayIndex (toPrimExpr array) (toPrimExpr index)) +slastExpr :: TypeInformation (Unnullify a) -> Expr [a] -> Expr (Nullify a) +slastExpr info = fromPrimExpr . Prim.last info . toPrimExpr -lastExpr :: Expr [a] -> Expr (Nullify a) -lastExpr array = indexExpr array index - where - index = fromPrimExpr $ Opaleye.FunExpr "array_upper" [toPrimExpr array, one] - where - one = Opaleye.ConstExpr (Opaleye.IntegerLit 1) +lengthExpr :: Expr [a] -> Expr Int32 +lengthExpr = fromPrimExpr . Prim.length . toPrimExpr diff --git a/src/Rel8/Expr/NonEmpty.hs b/src/Rel8/Expr/NonEmpty.hs index e92e0395..82bfd83d 100644 --- a/src/Rel8/Expr/NonEmpty.hs +++ b/src/Rel8/Expr/NonEmpty.hs @@ -1,39 +1,43 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + module Rel8.Expr.NonEmpty ( head1Expr, - index1Expr, last1Expr, + shead1Expr, + slast1Expr, + length1Expr, ) where -- base -import Data.Int (Int64) +import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Prelude --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye - -- rel8 import Rel8.Expr (Expr) import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr) -import Rel8.Schema.Null (Nullify) +import Rel8.Schema.Null (Sql, Unnullify) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation) +import qualified Rel8.Type.Array as Prim + + +head1Expr :: Sql DBType a => Expr (NonEmpty a) -> Expr a +head1Expr = shead1Expr typeInformation + + +last1Expr :: Sql DBType a => Expr (NonEmpty a) -> Expr a +last1Expr = slast1Expr typeInformation -head1Expr :: Expr (NonEmpty a) -> Expr a -head1Expr array = fromPrimExpr $ toPrimExpr $ index1Expr array index - where - index = fromPrimExpr $ Opaleye.FunExpr "array_lower" [toPrimExpr array, one] - where - one = Opaleye.ConstExpr (Opaleye.IntegerLit 1) +shead1Expr :: TypeInformation (Unnullify a) -> Expr (NonEmpty a) -> Expr a +shead1Expr info = fromPrimExpr . Prim.head info . toPrimExpr -index1Expr :: Expr (NonEmpty a) -> Expr Int64 -> Expr (Nullify a) -index1Expr array index = - fromPrimExpr (Opaleye.ArrayIndex (toPrimExpr array) (toPrimExpr index)) +slast1Expr :: TypeInformation (Unnullify a) -> Expr (NonEmpty a) -> Expr a +slast1Expr info = fromPrimExpr . Prim.last info . toPrimExpr -last1Expr :: Expr (NonEmpty a) -> Expr a -last1Expr array = fromPrimExpr $ toPrimExpr $ index1Expr array index - where - index = fromPrimExpr $ Opaleye.FunExpr "array_upper" [toPrimExpr array, one] - where - one = Opaleye.ConstExpr (Opaleye.IntegerLit 1) +length1Expr :: Expr (NonEmpty a) -> Expr Int32 +length1Expr = fromPrimExpr . Prim.length . toPrimExpr diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index 16efbfcc..ea58771a 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -2,8 +2,9 @@ {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} +{-# language DeriveFunctor #-} {-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} +{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} @@ -25,12 +26,14 @@ module Rel8.Schema.HTable.Vectorize , happend, hempty , hproject , hcolumn + , First (..) ) where -- base import Data.Kind ( Constraint, Type ) import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.Semigroup as Base import GHC.Generics (Generic) import Prelude @@ -55,7 +58,8 @@ import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) import Rel8.Type.Information ( TypeInformation ) -- semialign -import Data.Zip ( Unzip, Zip, Zippy(..) ) +import Data.Align (Semialign, alignWith) +import Data.Zip (Unzip, Zip, Zippy(..), zipWith) -- semigroupoids import Data.Functor.Apply (Apply) @@ -169,3 +173,16 @@ hnullify f (HVectorize table) = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of spec -> case hfield table (HMapTableField field) of a -> f spec a + + +newtype First a b = First {getFirst :: a} + deriving stock Functor + deriving (Semigroup) via (Base.First a) + + +instance Semialign (First a) where + alignWith _ (First a) _ = First a + + +instance Zip (First a) where + zipWith _ (First a) _ = First a \ No newline at end of file diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs index 369f4693..57e31054 100644 --- a/src/Rel8/Table/List.hs +++ b/src/Rel8/Table/List.hs @@ -17,18 +17,20 @@ module Rel8.Table.List , nameListTable , head , last + , length ) where -- base import Data.Functor.Identity (Identity (Identity)) +import Data.Int (Int32) import Data.Kind ( Type ) -import Prelude hiding (head, last) +import Prelude hiding (head, last, length) -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend, sempty, slistOf ) -import Rel8.Expr.List (headExpr, lastExpr) +import Rel8.Expr.List (lengthExpr, sheadExpr, slastExpr) import Rel8.Schema.Dict ( Dict( Dict ) ) import Rel8.Schema.HTable.List ( HListTable ) import Rel8.Schema.HTable.Vectorize @@ -36,6 +38,7 @@ import Rel8.Schema.HTable.Vectorize , hnullify , happend, hempty , hproject, hcolumn + , First (..) ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) ) @@ -159,7 +162,7 @@ nameListTable = head :: Table Expr a => ListTable Expr a -> NullTable Expr a head = fromColumns . - hnullify (const headExpr) . + hnullify (\Spec {info} -> sheadExpr info) . toColumns @@ -167,5 +170,13 @@ head = last :: Table Expr a => ListTable Expr a -> NullTable Expr a last = fromColumns . - hnullify (const lastExpr) . + hnullify (\Spec {info} -> slastExpr info) . + toColumns + + +-- | Get the length of a 'ListTable' +length :: Table Expr a => ListTable Expr a -> Expr Int32 +length = + getFirst . + hunvectorize (\_ -> First . lengthExpr) . toColumns diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs index 4100ee72..c8fc849c 100644 --- a/src/Rel8/Table/NonEmpty.hs +++ b/src/Rel8/Table/NonEmpty.hs @@ -17,11 +17,13 @@ module Rel8.Table.NonEmpty , nameNonEmptyTable , head1 , last1 + , length1 ) where -- base import Data.Functor.Identity (Identity (Identity), runIdentity) +import Data.Int (Int32) import Data.Kind ( Type ) import Data.List.NonEmpty ( NonEmpty ) import Prelude hiding ( id ) @@ -29,13 +31,14 @@ import Prelude hiding ( id ) -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend1, snonEmptyOf ) -import Rel8.Expr.NonEmpty (head1Expr, last1Expr) +import Rel8.Expr.NonEmpty (length1Expr, shead1Expr, slast1Expr) import Rel8.Schema.Dict ( Dict( Dict ) ) import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize , happend , hproject, hcolumn + , First (..) ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) ) @@ -152,7 +155,7 @@ head1 :: Table Expr a => NonEmptyTable Expr a -> a head1 = fromColumns . runIdentity . - hunvectorize (\_ -> Identity . head1Expr) . + hunvectorize (\Spec {info} -> Identity . shead1Expr info) . toColumns @@ -161,5 +164,13 @@ last1 :: Table Expr a => NonEmptyTable Expr a -> a last1 = fromColumns . runIdentity . - hunvectorize (\_ -> Identity . last1Expr) . + hunvectorize (\Spec {info} -> Identity . slast1Expr info) . + toColumns + + +-- | Get the length of a 'NonEmptyTable' +length1 :: Table Expr a => NonEmptyTable Expr a -> Expr Int32 +length1 = + getFirst . + hunvectorize (\_ -> First . length1Expr) . toColumns diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs index 2ffec3ef..c58b1314 100644 --- a/src/Rel8/Type/Array.hs +++ b/src/Rel8/Type/Array.hs @@ -9,13 +9,14 @@ module Rel8.Type.Array ( array, encodeArrayElement, extractArrayElement , listTypeInformation , nonEmptyTypeInformation + , head, last, length ) where -- base import Data.Foldable ( toList ) import Data.List.NonEmpty ( NonEmpty, nonEmpty ) -import Prelude hiding ( null, repeat, zipWith ) +import Prelude hiding ( head, last, length, null, repeat, zipWith ) -- hasql import qualified Hasql.Decoders as Hasql @@ -126,3 +127,31 @@ extractArrayElement info where pattern = string [char, char] replacement = string [char] + + +head :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr +head info a = extractArrayElement info $ index (lower a) a + + +last :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr +last info a = extractArrayElement info $ index (upper a) a + + +index :: Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr +index i a = Opaleye.ArrayIndex a i + + +lower :: Opaleye.PrimExpr -> Opaleye.PrimExpr +lower a = Opaleye.FunExpr "array_lower" [a, one] + + +upper :: Opaleye.PrimExpr -> Opaleye.PrimExpr +upper a = Opaleye.FunExpr "array_lower" [a, one] + + +length :: Opaleye.PrimExpr -> Opaleye.PrimExpr +length a = Opaleye.FunExpr "array_length" [a, one] + + +one :: Opaleye.PrimExpr +one = Opaleye.ConstExpr (Opaleye.IntegerLit 1) \ No newline at end of file