diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,3 @@ +# 1.0.0.0 (2021-06-18) + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2021 Oliver Charles + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# Welcome! + +Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL databases, built on top of the fantastic Opaleye library. + +The main objectives of Rel8 are: + +* *Conciseness*: Users using Rel8 should not need to write boiler-plate code. By using expressive types, we can provide sufficient information for the compiler to infer code whenever possible. + +* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have excellent and predictable type inference. + +* *Familiar*: writing Rel8 queries should feel like normal Haskell programming. + +For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/). diff --git a/rel8.cabal b/rel8.cabal new file mode 100644 --- /dev/null +++ b/rel8.cabal @@ -0,0 +1,210 @@ +cabal-version: 2.0 +name: rel8 +version: 1.0.0.0 +synopsis: Hey! Hey! Can u rel8? +license: BSD3 +license-file: LICENSE +author: Oliver Charles +maintainer: ollie@ocharles.org.uk +build-type: Simple +extra-doc-files: + README.md + Changelog.md + +library + build-depends: + aeson + , base ^>= 4.14 || ^>=4.15 + , bytestring + , case-insensitive + , contravariant + , hasql ^>= 1.4.5.1 + , opaleye ^>= 0.7.1.0 + , profunctors + , scientific + , semialign + , semigroupoids + , text + , these + , time + , transformers + , uuid + default-language: + Haskell2010 + ghc-options: + -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode + -Wno-missing-import-lists -Wno-prepositive-qualified-module + -Wno-monomorphism-restriction + -Wno-missing-local-signatures + hs-source-dirs: + src + exposed-modules: + Rel8 + Rel8.Expr.Num + Rel8.Expr.Text + Rel8.Expr.Time + + other-modules: + Rel8.Aggregate + + Rel8.Column + Rel8.Column.ADT + Rel8.Column.Either + Rel8.Column.Lift + Rel8.Column.List + Rel8.Column.Maybe + Rel8.Column.NonEmpty + Rel8.Column.These + + Rel8.Expr + Rel8.Expr.Aggregate + Rel8.Expr.Array + Rel8.Expr.Bool + Rel8.Expr.Eq + Rel8.Expr.Function + Rel8.Expr.Null + Rel8.Expr.Opaleye + Rel8.Expr.Ord + Rel8.Expr.Order + Rel8.Expr.Sequence + Rel8.Expr.Serialize + + Rel8.FCF + + Rel8.Kind.Algebra + Rel8.Kind.Context + Rel8.Kind.Labels + + Rel8.Generic.Construction + Rel8.Generic.Construction.ADT + Rel8.Generic.Construction.Record + Rel8.Generic.Map + Rel8.Generic.Record + Rel8.Generic.Reify + Rel8.Generic.Rel8able + Rel8.Generic.Rel8able.Test + Rel8.Generic.Table + Rel8.Generic.Table.ADT + Rel8.Generic.Table.Record + + Rel8.Order + + Rel8.Query + Rel8.Query.Aggregate + Rel8.Query.Distinct + Rel8.Query.Each + Rel8.Query.Either + Rel8.Query.Evaluate + Rel8.Query.Exists + Rel8.Query.Filter + Rel8.Query.Limit + Rel8.Query.List + Rel8.Query.Maybe + Rel8.Query.Null + Rel8.Query.Opaleye + Rel8.Query.Order + Rel8.Query.Set + Rel8.Query.SQL + Rel8.Query.These + Rel8.Query.Values + + Rel8.Schema.Context + Rel8.Schema.Context.Label + Rel8.Schema.Context.Nullify + Rel8.Schema.Dict + Rel8.Schema.HTable + Rel8.Schema.HTable.Either + Rel8.Schema.HTable.Identity + Rel8.Schema.HTable.Label + Rel8.Schema.HTable.List + Rel8.Schema.HTable.MapTable + Rel8.Schema.HTable.Maybe + Rel8.Schema.HTable.NonEmpty + Rel8.Schema.HTable.Nullify + Rel8.Schema.HTable.Product + Rel8.Schema.HTable.These + Rel8.Schema.HTable.Vectorize + Rel8.Schema.Kind + Rel8.Schema.Name + Rel8.Schema.Null + Rel8.Schema.Reify + Rel8.Schema.Result + Rel8.Schema.Spec + Rel8.Schema.Spec.ConstrainDBType + Rel8.Schema.Table + + Rel8.Statement.Delete + Rel8.Statement.Insert + Rel8.Statement.Returning + Rel8.Statement.Select + Rel8.Statement.Update + Rel8.Statement.View + + Rel8.Table + Rel8.Table.ADT + Rel8.Table.Aggregate + Rel8.Table.Alternative + Rel8.Table.Bool + Rel8.Table.Either + Rel8.Table.Eq + Rel8.Table.HKD + Rel8.Table.List + Rel8.Table.Maybe + Rel8.Table.Name + Rel8.Table.NonEmpty + Rel8.Table.Opaleye + Rel8.Table.Ord + Rel8.Table.Order + Rel8.Table.Recontextualize + Rel8.Table.Rel8able + Rel8.Table.Serialize + Rel8.Table.Tag + Rel8.Table.These + Rel8.Table.Undefined + Rel8.Table.Unreify + + Rel8.Type + Rel8.Type.Array + Rel8.Type.Composite + Rel8.Type.Eq + Rel8.Type.Enum + Rel8.Type.Information + Rel8.Type.JSONEncoded + Rel8.Type.JSONBEncoded + Rel8.Type.Monoid + Rel8.Type.Num + Rel8.Type.Ord + Rel8.Type.ReadShow + Rel8.Type.Semigroup + Rel8.Type.String + Rel8.Type.Sum + Rel8.Type.Tag + +test-suite tests + type: exitcode-stdio-1.0 + build-depends: + base + , bytestring + , case-insensitive + , containers + , hasql + , hedgehog ^>=1.0.2 + , lifted-base ^>=0.2.3.12 + , monad-control ^>=1.0.2.3 + , rel8 + , scientific + , tasty + , tasty-hedgehog + , text + , time + , tmp-postgres ^>=1.34.1.0 + , uuid + + main-is: Main.hs + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: + -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode + -Wno-missing-import-lists -Wno-prepositive-qualified-module + -Wno-deprecations -Wno-monomorphism-restriction + -Wno-missing-local-signatures -Wno-implicit-prelude diff --git a/src/Rel8.hs b/src/Rel8.hs new file mode 100644 --- /dev/null +++ b/src/Rel8.hs @@ -0,0 +1,364 @@ +{-# language DuplicateRecordFields #-} + +module Rel8 + ( -- * Database types + -- ** @DBType@ + DBType(..) + + -- *** Deriving-via helpers + -- **** @JSONEncoded@ + , JSONEncoded(..) + , JSONBEncoded(..) + + -- **** @ReadShow@ + , ReadShow(..) + + -- **** Generic + , Composite(..), DBComposite(..), compose, decompose + , Enum(..), DBEnum(..), Enumable + + -- *** @TypeInformation@ + , TypeInformation(..) + , mapTypeInformation + , parseTypeInformation + + -- ** The @DBType@ hierarchy + , DBSemigroup(..) + , DBMonoid(..) + , DBNum + , DBIntegral + , DBFractional + , DBFloating + + -- * Tables and higher-kinded tables + , Rel8able, KRel8able + , Column + , HADT + , HEither + , HMaybe + , HList + , HNonEmpty + , HThese + , Lift + + , Table(..) + , HTable + , Recontextualize + , AltTable((<|>:)) + , AlternativeTable( emptyTable ) + , EqTable, (==:), (/=:) + , OrdTable, ascTable, descTable + , lit + , bool + , case_ + + -- ** @MaybeTable@ + , MaybeTable + , maybeTable, ($?), nothingTable, justTable + , isNothingTable, isJustTable + , optional + , catMaybeTable + , traverseMaybeTable + , nameMaybeTable + + -- ** @EitherTable@ + , EitherTable + , eitherTable, leftTable, rightTable + , isLeftTable, isRightTable + , keepLeftTable + , keepRightTable + , bitraverseEitherTable + , nameEitherTable + + -- ** @TheseTable@ + , TheseTable + , theseTable, thisTable, thatTable, thoseTable + , isThisTable, isThatTable, isThoseTable + , hasHereTable, hasThereTable + , justHereTable, justThereTable + , alignBy + , keepHereTable, loseHereTable + , keepThereTable, loseThereTable + , keepThisTable, loseThisTable + , keepThatTable, loseThatTable + , keepThoseTable, loseThoseTable + , bitraverseTheseTable + , nameTheseTable + + -- ** @ListTable@ + , ListTable + , listTable + , nameListTable + , many + , manyExpr + , catListTable + , catList + + -- ** @NonEmptyTable@ + , NonEmptyTable + , nonEmptyTable + , nameNonEmptyTable + , some + , someExpr + , catNonEmptyTable + , catNonEmpty + + -- ** @ADT@ + , ADT, ADTable + , BuildADT, buildADT + , ConstructADT, constructADT + , DeconstructADT, deconstructADT + , NameADT, nameADT + , AggregateADT, aggregateADT + + -- ** @HKD@ + , HKD, HKDable + , BuildHKD, buildHKD + , ConstructHKD, constructHKD + , DeconstructHKD, deconstructHKD + , NameHKD, nameHKD + , AggregateHKD, aggregateHKD + + -- ** Table schemas + , TableSchema(..) + , Name + , namesFromLabels + , namesFromLabelsWith + + -- * Expressions + , Expr + , Sql + , litExpr + , unsafeCastExpr + , unsafeLiteral + + -- ** @null@ + , NotNull + , Nullable + , null + , nullify + , nullable + , isNull + , isNonNull + , mapNull + , liftOpNull + , catNull + , coalesce + + -- ** Boolean operations + , DBEq + , true, false, not_ + , (&&.), and_ + , (||.), or_ + , (==.), (/=.), (==?), (/=?) + , in_ + , boolExpr, caseExpr + + -- ** Ordering + , DBOrd + , (<.), (<=.), (>.), (>=.) + , (?), (>=?) + , leastExpr, greatestExpr + + -- ** Functions + , Function + , function + , nullaryFunction + , binaryOperator + + -- * Queries + , Query + , showQuery + + -- ** Selecting rows + , Selects + , each + , values + + -- ** Filtering + , filter + , where_ + , whereExists + , whereNotExists + , distinct + , distinctOn + , distinctOnBy + + -- ** @LIMIT@/@OFFSET@ + , limit + , offset + + -- ** @UNION@ + , union + , unionAll + + -- ** @INTERSECT@ + , intersect + , intersectAll + + -- ** @EXCEPT@ + , except + , exceptAll + + -- ** @EXISTS@ + , exists + , with + , withBy + , without + , withoutBy + + -- ** Aggregation + , Aggregate + , Aggregates + , aggregate + , countRows + , groupBy + , listAgg, listAggExpr + , nonEmptyAgg, nonEmptyAggExpr + , DBMax, max + , DBMin, min + , DBSum, sum, sumWhere + , DBString, stringAgg + , count + , countStar + , countDistinct + , countWhere + , and + , or + + -- ** Ordering + , orderBy + , Order + , asc + , desc + , nullsFirst + , nullsLast + + -- * IO + , Serializable + , ToExprs(..) + , FromExprs + , Result + + -- * Running statements + -- ** @SELECT@ + , select + + -- ** @INSERT@ + , Insert(..) + , OnConflict(..) + , insert + + -- ** @DELETE@ + , Delete(..) + , delete + + -- ** @UPDATE@ + , update + , Update(..) + + -- ** @.. RETURNING@ + , Returning(..) + + -- ** @CREATE VIEW@ + , createView + + -- ** Sequences + , nextval + + , Evaluate + , eval + , evaluate + + -- * Implementation details + , Labelable + , HKDT(..) + ) where + +-- base +import Prelude () + +-- rel8 +import Rel8.Aggregate +import Rel8.Column +import Rel8.Column.ADT +import Rel8.Column.Either +import Rel8.Column.Lift +import Rel8.Column.List +import Rel8.Column.Maybe +import Rel8.Column.NonEmpty +import Rel8.Column.These +import Rel8.Expr +import Rel8.Expr.Aggregate +import Rel8.Expr.Bool +import Rel8.Expr.Eq +import Rel8.Expr.Function +import Rel8.Expr.Null +import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral) +import Rel8.Expr.Ord +import Rel8.Expr.Order +import Rel8.Expr.Serialize +import Rel8.Expr.Sequence +import Rel8.Generic.Rel8able ( KRel8able, Rel8able ) +import Rel8.Order +import Rel8.Query +import Rel8.Query.Aggregate +import Rel8.Query.Distinct +import Rel8.Query.Each +import Rel8.Query.Either +import Rel8.Query.Evaluate +import Rel8.Query.Exists +import Rel8.Query.Filter +import Rel8.Query.Limit +import Rel8.Query.List +import Rel8.Query.Maybe +import Rel8.Query.Null +import Rel8.Query.Order +import Rel8.Query.SQL (showQuery) +import Rel8.Query.Set +import Rel8.Query.These +import Rel8.Query.Values +import Rel8.Schema.Context.Label +import Rel8.Schema.HTable +import Rel8.Schema.Name +import Rel8.Schema.Null hiding ( nullable ) +import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Table +import Rel8.Statement.Delete +import Rel8.Statement.Insert +import Rel8.Statement.Returning +import Rel8.Statement.Select +import Rel8.Statement.Update +import Rel8.Statement.View +import Rel8.Table +import Rel8.Table.ADT +import Rel8.Table.Aggregate +import Rel8.Table.Alternative +import Rel8.Table.Bool +import Rel8.Table.Either +import Rel8.Table.Eq +import Rel8.Table.HKD +import Rel8.Table.List +import Rel8.Table.Maybe +import Rel8.Table.Name +import Rel8.Table.NonEmpty +import Rel8.Table.Ord +import Rel8.Table.Order +import Rel8.Table.Recontextualize +import Rel8.Table.Rel8able () +import Rel8.Table.Serialize +import Rel8.Table.These +import Rel8.Type +import Rel8.Type.Composite +import Rel8.Type.Eq +import Rel8.Type.Enum +import Rel8.Type.Information +import Rel8.Type.JSONBEncoded +import Rel8.Type.JSONEncoded +import Rel8.Type.Monoid +import Rel8.Type.Num +import Rel8.Type.Ord +import Rel8.Type.ReadShow +import Rel8.Type.Semigroup +import Rel8.Type.String +import Rel8.Type.Sum diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Aggregate.hs @@ -0,0 +1,155 @@ +{-# language DataKinds #-} +{-# language DerivingVia #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language PolyKinds #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Aggregate + ( Aggregate(..), foldInputs, mapInputs + , Aggregator(..), unsafeMakeAggregate + , Aggregates + , Col( A, unA ) + ) +where + +-- base +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Functor.Identity ( Identity ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.Aggregate as Opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.PackMap as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Schema.Context ( Interpretation(..) ) +import Rel8.Schema.Context.Label ( Labelable(..) ) +import Rel8.Schema.HTable.Identity ( HIdentity(..), HType ) +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Reify ( notReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Type ( DBType ) + + +-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can +-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As +-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure' +-- operation. This means 'Aggregate' is an instance of 'Apply', and you can +-- combine @Aggregate@s using the @<.>@ combinator. +type Aggregate :: k -> Type +data Aggregate a where + Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a + + +instance Interpretation Aggregate where + data Col Aggregate _spec where + A :: () + => { unA :: !(Aggregate a) } + -> Col Aggregate ('Spec labels a) + + +instance Sql DBType a => Table Aggregate (Aggregate a) where + type Columns (Aggregate a) = HType a + type Context (Aggregate a) = Aggregate + + toColumns = HIdentity . A + fromColumns (HIdentity (A a)) = a + + reify = notReify + unreify = notReify + + +instance Sql DBType a => + Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a) + + +instance Sql DBType a => + Recontextualize Aggregate Expr (Aggregate a) (Expr a) + + +instance Sql DBType a => + Recontextualize Aggregate Result (Aggregate a) (Identity a) + + +instance Sql DBType a => + Recontextualize Aggregate Name (Aggregate a) (Name a) + + +instance Sql DBType a => + Recontextualize Expr Aggregate (Expr a) (Aggregate a) + + +instance Sql DBType a => + Recontextualize Result Aggregate (Identity a) (Aggregate a) + + +instance Sql DBType a => + Recontextualize Name Aggregate (Name a) (Aggregate a) + + +instance Labelable Aggregate where + labeler (A aggregate) = A aggregate + unlabeler (A aggregate) = A aggregate + + +-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's +-- for the columns in @b@. +type Aggregates :: Type -> Type -> Constraint +class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs +instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs + + +foldInputs :: Monoid b + => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b +foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) = + getConst $ flip agg () $ \(aggregator, a) -> + Const $ f (detuplize <$> aggregator) a + where + detuplize (operation, ordering, distinction) = + Aggregator {operation, ordering, distinction} + + +mapInputs :: () + => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a +mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) = + Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input -> + f (fmap transform input) + + +type Aggregator :: Type +data Aggregator = Aggregator + { operation :: Opaleye.AggrOp + , ordering :: [Opaleye.OrderExpr] + , distinction :: Opaleye.AggrDistinct + } + + +unsafeMakeAggregate :: () + => (Expr input -> Opaleye.PrimExpr) + -> (Opaleye.PrimExpr -> Expr output) + -> Maybe Aggregator + -> Expr input + -> Aggregate output +unsafeMakeAggregate input output aggregator expr = + Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ -> + output <$> f (tuplize <$> aggregator, input expr) + where + tuplize Aggregator {operation, ordering, distinction} = + (operation, ordering, distinction) diff --git a/src/Rel8/Column.hs b/src/Rel8/Column.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column.hs @@ -0,0 +1,103 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Column + ( Column, AColumn(..) + , TColumn + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate, Col( A ) ) +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name(..), Col( N ) ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Reify ( Reify, Col(..) ) +import Rel8.Schema.Result ( Col( R ), Result ) +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Type ( DBType ) + + +-- | This type family is used to specify columns in 'Rel8able's. In @Column f +-- a@, @f@ is the context of the column (which should be left polymorphic in +-- 'Rel8able' definitions), and @a@ is the type of the column. +type Column :: K.Context -> Type -> Type +type family Column context a where + Column (Reify context) a = AColumn context a + Column Aggregate a = Aggregate a + Column Expr a = Expr a + Column Name a = Name a + Column Result a = a + + +type AColumn :: K.Context -> Type -> Type +newtype AColumn context a = AColumn (Column context a) + + +instance (Reifiable context, Sql DBType a) => + Table (Reify context) (AColumn context a) + where + type Context (AColumn context a) = Reify context + type Columns (AColumn context a) = HIdentity ('Spec '[] a) + type Unreify (AColumn context a) = Column context a + + fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a + toColumns = HIdentity . Reify . stoColumn contextSing + reify _ = AColumn + unreify _ (AColumn a) = a + + +instance + ( Reifiable context, Reifiable context' + , Sql DBType a + ) => + Recontextualize + (Reify context) + (Reify context') + (AColumn context a) + (AColumn context' a) + + +sfromColumn :: () + => SContext context + -> Col context ('Spec labels a) + -> AColumn context a +sfromColumn = \case + SAggregate -> \(A a) -> AColumn a + SExpr -> \(E a) -> AColumn a + SName -> \(N a) -> AColumn a + SResult -> \(R a) -> AColumn a + SReify context -> \(Reify a) -> AColumn (sfromColumn context a) + + +stoColumn :: () + => SContext context + -> AColumn context a + -> Col context ('Spec labels a) +stoColumn = \case + SAggregate -> \(AColumn a) -> A a + SExpr -> \(AColumn a) -> E a + SName -> \(AColumn a) -> N a + SResult -> \(AColumn a) -> R a + SReify context -> \(AColumn a) -> Reify (stoColumn context a) + + +data TColumn :: K.Context -> Type -> Exp Type +type instance Eval (TColumn f a) = Column f a diff --git a/src/Rel8/Column/ADT.hs b/src/Rel8/Column/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/ADT.hs @@ -0,0 +1,88 @@ +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.ADT + ( HADT, AHADT(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Generic.Rel8able ( GColumns ) +import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing ) +import Rel8.Schema.Context ( Col ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT ) +import Rel8.Table.Recontextualize ( Recontextualize ) + + +type HADT :: K.Context -> K.Rel8able -> Type +type family HADT context t where + HADT (Reify context) t = AHADT context t + HADT Result t = t Result + HADT context t = ADT t context + + +type AHADT :: K.Context -> K.Rel8able -> Type +newtype AHADT context t = AHADT (HADT context t) + + +instance (ADTable t, Reifiable context) => + Table (Reify context) (AHADT context t) + where + type Context (AHADT context t) = Reify context + type Columns (AHADT context t) = GColumns (ADT t) + type Unreify (AHADT context t) = HADT context t + + fromColumns = sfromColumnsADT contextSing + toColumns = stoColumnsADT contextSing + reify _ = AHADT + unreify _ (AHADT a) = a + + +instance + ( Reifiable context, Reifiable context' + , ADTable t, t ~ t' + ) + => Recontextualize + (Reify context) + (Reify context') + (AHADT context t) + (AHADT context' t') + + +sfromColumnsADT :: ADTable t + => SContext context + -> GColumns (ADT t) (Col (Reify context)) + -> AHADT context t +sfromColumnsADT = \case + SAggregate -> AHADT . ADT . hunreify + SExpr -> AHADT . ADT . hunreify + SName -> AHADT . ADT . hunreify + SResult -> AHADT . fromADT . ADT . hunreify + SReify context -> AHADT . sfromColumnsADT context . hunreify + + +stoColumnsADT :: ADTable t + => SContext context + -> AHADT context t + -> GColumns (ADT t) (Col (Reify context)) +stoColumnsADT = \case + SAggregate -> hreify . (\(AHADT (ADT a)) -> a) + SExpr -> hreify . (\(AHADT (ADT a)) -> a) + SName -> hreify . (\(AHADT (ADT a)) -> a) + SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a) + SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a) diff --git a/src/Rel8/Column/Either.hs b/src/Rel8/Column/Either.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/Either.hs @@ -0,0 +1,162 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.Either + ( HEither, AHEither(..) + ) +where + +-- base +import Control.Applicative ( liftA2 ) +import Data.Bifunctor ( Bifunctor, bimap ) +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable.Either ( HEitherTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name(..) ) +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.Either ( EitherTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) + + +-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a +-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the +-- 'Result' context. +type HEither :: K.Context -> Type -> Type -> Type +type family HEither context where + HEither (Reify context) = AHEither context + HEither Aggregate = EitherTable + HEither Expr = EitherTable + HEither Name = EitherTable + HEither Result = Either + + +type AHEither :: K.Context -> Type -> Type -> Type +newtype AHEither context a b = AHEither (HEither context a b) + + +instance Reifiable context => Bifunctor (AHEither context) where + bimap = sbimapEither contextSing + + +instance Reifiable context => Functor (AHEither context a) where + fmap = bimap id + + +instance (Reifiable context, Table (Reify context) a, Table (Reify context) b) + => Table (Reify context) (AHEither context a b) + where + type Context (AHEither context a b) = Reify context + type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b) + type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b) + + fromColumns = sfromColumnsEither contextSing + toColumns = stoColumnsEither contextSing + reify proof = liftA2 bimap reify reify proof . AHEither + unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + , Recontextualize (Reify context) (Reify context') b b' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHEither context a b) + (AHEither context' a' b') + + +sbimapEither :: () + => SContext context + -> (a -> c) + -> (b -> d) + -> AHEither context a b + -> AHEither context c d +sbimapEither = \case + SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a) + SExpr -> \f g (AHEither a) -> AHEither (bimap f g a) + SResult -> \f g (AHEither a) -> AHEither (bimap f g a) + SName -> \f g (AHEither a) -> AHEither (bimap f g a) + SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a) + + +sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> HEitherTable (Columns a) (Columns b) (Col (Reify context)) + -> AHEither context a b +sfromColumnsEither = \case + SAggregate -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SExpr -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SResult -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SName -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SReify context -> + AHEither . + sbimapEither context (fromColumns . hreify) (fromColumns . hreify) . + sfromColumnsEither context . + hunreify + + +stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> AHEither context a b + -> HEitherTable (Columns a) (Columns b) (Col (Reify context)) +stoColumnsEither = \case + SAggregate -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SExpr -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SResult -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SName -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SReify context -> + hreify . + stoColumnsEither context . + sbimapEither context (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) diff --git a/src/Rel8/Column/Lift.hs b/src/Rel8/Column/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/Lift.hs @@ -0,0 +1,87 @@ +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Column.Lift + ( Lift, ALift(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Generic.Rel8able ( GColumns ) +import Rel8.Kind.Context ( Reifiable(..), SContext(..) ) +import Rel8.Schema.Context ( Col ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.Rel8able () +import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD ) +import Rel8.Table.Recontextualize ( Recontextualize ) + + +type Lift :: K.Context -> Type -> Type +type family Lift context a where + Lift (Reify context) a = ALift context a + Lift Result a = a + Lift context a = HKD a context + + +type ALift :: K.Context -> Type -> Type +newtype ALift context a = ALift + { unALift :: Lift context a + } + + +instance (Reifiable context, HKDable a) => + Table (Reify context) (ALift context a) + where + type Context (ALift context a) = Reify context + type Columns (ALift context a) = GColumns (HKD a) + type Unreify (ALift context a) = Lift context a + + fromColumns = sfromColumnsLift contextSing + toColumns = stoColumnsLift contextSing + reify _ = ALift + unreify _ (ALift a) = a + + +instance (Reifiable context, Reifiable context', HKDable a) => + Recontextualize + (Reify context) + (Reify context') + (ALift context a) + (ALift context' a) + + +sfromColumnsLift :: HKDable a + => SContext context + -> GColumns (HKD a) (Col (Reify context)) + -> ALift context a +sfromColumnsLift = \case + SAggregate -> ALift . fromColumns . hunreify + SExpr -> ALift . fromColumns . hunreify + SName -> ALift . fromColumns . hunreify + SResult -> ALift . fromHKD . HKD . hunreify + SReify context -> ALift . sfromColumnsLift context . hunreify + + +stoColumnsLift :: HKDable a + => SContext context + -> ALift context a + -> GColumns (HKD a) (Col (Reify context)) +stoColumnsLift = \case + SAggregate -> hreify . toColumns . unALift + SExpr -> hreify . toColumns . unALift + SName -> hreify . toColumns . unALift + SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift + SReify context -> hreify . stoColumnsLift context . unALift diff --git a/src/Rel8/Column/List.hs b/src/Rel8/Column/List.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/List.hs @@ -0,0 +1,145 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.List + ( HList, AHList(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable.List ( HListTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Congruent, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.List ( ListTable( ListTable ) ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability ) + + +-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable' +-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context. +type HList :: K.Context -> Type -> Type +type family HList context where + HList (Reify context) = AHList context + HList Aggregate = ListTable + HList Expr = ListTable + HList Name = ListTable + HList Result = [] + + +type AHList :: K.Context -> Type -> Type +newtype AHList context a = AHList (HList context a) + + +instance (Reifiable context, Unreifiable a, Table (Reify context) a) => + Table (Reify context) (AHList context a) + where + type Context (AHList context a) = Reify context + type Columns (AHList context a) = HListTable (Columns a) + type Unreify (AHList context a) = HList context (Unreify a) + + fromColumns = sfromColumnsList contextSing + toColumns = stoColumnsList contextSing + + reify _ = sreifyList (unreifiability contextSing) + unreify _ = sunreifyList (unreifiability contextSing) + + +instance + ( Reifiable context, Reifiable context' + , Unreifiable a, Unreifiable a' + , Recontextualize (Reify context) (Reify context') a a' + ) + => Recontextualize + (Reify context) + (Reify context') + (AHList context a) + (AHList context' a') + + +smapList :: Congruent a b + => SContext context + -> (a -> b) + -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b))) + -> AHList context a + -> AHList context b +smapList = \case + SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a)) + SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a)) + SResult -> \f _ (AHList as) -> AHList (fmap f as) + SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a)) + SReify context -> \f g (AHList as) -> AHList (smapList context f g as) + + +sfromColumnsList :: Table (Reify context) a + => SContext context + -> HListTable (Columns a) (Col (Reify context)) + -> AHList context a +sfromColumnsList = \case + SAggregate -> AHList . ListTable + SExpr -> AHList . ListTable + SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify + SName -> AHList . ListTable + SReify context -> + AHList . + smapList context (fromColumns . hreify) hreify . + sfromColumnsList context . + hunreify + + +stoColumnsList :: Table (Reify context) a + => SContext context + -> AHList context a + -> HListTable (Columns a) (Col (Reify context)) +stoColumnsList = \case + SAggregate -> \(AHList (ListTable a)) -> a + SExpr -> \(AHList (ListTable a)) -> a + SResult -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a) + SName -> \(AHList (ListTable a)) -> a + SReify context -> + hreify . + stoColumnsList context . + smapList context (hunreify . toColumns) hunreify . + (\(AHList a) -> a) + + +sreifyList :: Table (Reify context) a + => Unreifiability context a + -> HList context (Unreify a) + -> AHList context a +sreifyList = \case + UResult -> AHList . fmap (reify Refl) + Unreifiability context -> + smapList context (reify Refl) hreify . + AHList + + +sunreifyList :: Table (Reify context) a + => Unreifiability context a + -> AHList context a + -> HList context (Unreify a) +sunreifyList = \case + UResult -> fmap (unreify Refl) . (\(AHList a) -> a) + Unreifiability context -> + (\(AHList a) -> a) . + smapList context (unreify Refl) hunreify diff --git a/src/Rel8/Column/Maybe.hs b/src/Rel8/Column/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/Maybe.hs @@ -0,0 +1,127 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.Maybe + ( HMaybe, AHMaybe(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.Maybe ( MaybeTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) + + +-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a +-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result' +-- context. +type HMaybe :: K.Context -> Type -> Type +type family HMaybe context where + HMaybe (Reify context) = AHMaybe context + HMaybe Aggregate = MaybeTable + HMaybe Expr = MaybeTable + HMaybe Name = MaybeTable + HMaybe Result = Maybe + + +type AHMaybe :: K.Context -> Type -> Type +newtype AHMaybe context a = AHMaybe (HMaybe context a) + + +instance Reifiable context => Functor (AHMaybe context) where + fmap = smapMaybe contextSing + + +instance (Reifiable context, Table (Reify context) a) => + Table (Reify context) (AHMaybe context a) + where + type Context (AHMaybe context a) = Reify context + type Columns (AHMaybe context a) = HMaybeTable (Columns a) + type Unreify (AHMaybe context a) = HMaybe context (Unreify a) + + fromColumns = sfromColumnsMaybe contextSing + toColumns = stoColumnsMaybe contextSing + reify proof = fmap fmap reify proof . AHMaybe + unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHMaybe context a) + (AHMaybe context' a') + + +smapMaybe :: () + => SContext context + -> (a -> b) + -> AHMaybe context a + -> AHMaybe context b +smapMaybe = \case + SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SName -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a) + + +sfromColumnsMaybe :: Table (Reify context) a + => SContext context + -> HMaybeTable (Columns a) (Col (Reify context)) + -> AHMaybe context a +sfromColumnsMaybe = \case + SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SReify context -> + AHMaybe . + smapMaybe context (fromColumns . hreify) . + sfromColumnsMaybe context . + hunreify + + +stoColumnsMaybe :: Table (Reify context) a + => SContext context + -> AHMaybe context a + -> HMaybeTable (Columns a) (Col (Reify context)) +stoColumnsMaybe = \case + SAggregate -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SExpr -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SResult -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SName -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SReify context -> + hreify . + stoColumnsMaybe context . + smapMaybe context (hunreify . toColumns) . + (\(AHMaybe a) -> a) diff --git a/src/Rel8/Column/NonEmpty.hs b/src/Rel8/Column/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/NonEmpty.hs @@ -0,0 +1,148 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.NonEmpty + ( HNonEmpty, AHNonEmpty(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Congruent, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability ) + + +-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a +-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the +-- 'Result' context. +type HNonEmpty :: K.Context -> Type -> Type +type family HNonEmpty context where + HNonEmpty (Reify context) = AHNonEmpty context + HNonEmpty Aggregate = NonEmptyTable + HNonEmpty Expr = NonEmptyTable + HNonEmpty Name = NonEmptyTable + HNonEmpty Result = NonEmpty + + +type AHNonEmpty :: K.Context -> Type -> Type +newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a) + + +instance (Reifiable context, Unreifiable a, Table (Reify context) a) => + Table (Reify context) (AHNonEmpty context a) + where + type Context (AHNonEmpty context a) = Reify context + type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a) + type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a) + + fromColumns = sfromColumnsNonEmpty contextSing + toColumns = stoColumnsNonEmpty contextSing + + reify _ = sreifyNonEmpty (unreifiability contextSing) + unreify _ = sunreifyNonEmpty (unreifiability contextSing) + + +instance + ( Reifiable context, Reifiable context' + , Unreifiable a, Unreifiable a' + , Recontextualize (Reify context) (Reify context') a a' + ) + => Recontextualize + (Reify context) + (Reify context') + (AHNonEmpty context a) + (AHNonEmpty context' a') + + +smapNonEmpty :: Congruent a b + => SContext context + -> (a -> b) + -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b))) + -> AHNonEmpty context a + -> AHNonEmpty context b +smapNonEmpty = \case + SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a)) + SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a)) + SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as) + SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a)) + SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as) + + +sfromColumnsNonEmpty :: Table (Reify context) a + => SContext context + -> HNonEmptyTable (Columns a) (Col (Reify context)) + -> AHNonEmpty context a +sfromColumnsNonEmpty = \case + SAggregate -> AHNonEmpty . NonEmptyTable + SExpr -> AHNonEmpty . NonEmptyTable + SResult -> + AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify + SName -> AHNonEmpty . NonEmptyTable + SReify context -> + AHNonEmpty . + smapNonEmpty context (fromColumns . hreify) hreify . + sfromColumnsNonEmpty context . + hunreify + + +stoColumnsNonEmpty :: Table (Reify context) a + => SContext context + -> AHNonEmpty context a + -> HNonEmptyTable (Columns a) (Col (Reify context)) +stoColumnsNonEmpty = \case + SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a + SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a + SResult -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a) + SName -> \(AHNonEmpty (NonEmptyTable a)) -> a + SReify context -> + hreify . + stoColumnsNonEmpty context . + smapNonEmpty context (hunreify . toColumns) hunreify . + (\(AHNonEmpty a) -> a) + + +sreifyNonEmpty :: Table (Reify context) a + => Unreifiability context a + -> HNonEmpty context (Unreify a) + -> AHNonEmpty context a +sreifyNonEmpty = \case + UResult -> AHNonEmpty . fmap (reify Refl) + Unreifiability context -> + smapNonEmpty context (reify Refl) hreify . + AHNonEmpty + + +sunreifyNonEmpty :: Table (Reify context) a + => Unreifiability context a + -> AHNonEmpty context a + -> HNonEmpty context (Unreify a) +sunreifyNonEmpty = \case + UResult -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a) + Unreifiability context -> + (\(AHNonEmpty a) -> a) . + smapNonEmpty context (unreify Refl) hunreify diff --git a/src/Rel8/Column/These.hs b/src/Rel8/Column/These.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Column/These.hs @@ -0,0 +1,166 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Column.These + ( HThese, AHThese(..) + ) +where + +-- base +import Control.Applicative ( liftA2 ) +import Data.Bifunctor ( Bifunctor, bimap ) +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable.These ( HTheseTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.These ( TheseTable ) + +-- these +import Data.These ( These ) + + +-- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a +-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the +-- 'Result' context. +type HThese :: K.Context -> Type -> Type -> Type +type family HThese context where + HThese (Reify context) = AHThese context + HThese Aggregate = TheseTable + HThese Expr = TheseTable + HThese Name = TheseTable + HThese Result = These + + +type AHThese :: K.Context -> Type -> Type -> Type +newtype AHThese context a b = AHThese (HThese context a b) + + +instance Reifiable context => Bifunctor (AHThese context) where + bimap = sbimapThese contextSing + + +instance Reifiable context => Functor (AHThese context a) where + fmap = bimap id + + +instance (Reifiable context, Table (Reify context) a, Table (Reify context) b) + => Table (Reify context) (AHThese context a b) + where + type Context (AHThese context a b) = Reify context + type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b) + type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b) + + fromColumns = sfromColumnsThese contextSing + toColumns = stoColumnsThese contextSing + reify proof = liftA2 bimap reify reify proof . AHThese + unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + , Recontextualize (Reify context) (Reify context') b b' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHThese context a b) + (AHThese context' a' b') + + +sbimapThese :: () + => SContext context + -> (a -> c) + -> (b -> d) + -> AHThese context a b + -> AHThese context c d +sbimapThese = \case + SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a) + SExpr -> \f g (AHThese a) -> AHThese (bimap f g a) + SResult -> \f g (AHThese a) -> AHThese (bimap f g a) + SName -> \f g (AHThese a) -> AHThese (bimap f g a) + SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a) + + +sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> HTheseTable (Columns a) (Columns b) (Col (Reify context)) + -> AHThese context a b +sfromColumnsThese = \case + SAggregate -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SExpr -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SResult -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SName -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SReify context -> + AHThese . + sbimapThese context (fromColumns . hreify) (fromColumns . hreify) . + sfromColumnsThese context . + hunreify + + +stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> AHThese context a b + -> HTheseTable (Columns a) (Columns b) (Col (Reify context)) +stoColumnsThese = \case + SAggregate -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SExpr -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SResult -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SName -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SReify context -> + hreify . + stoColumnsThese context . + sbimapThese context (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr.hs @@ -0,0 +1,155 @@ +{-# language DataKinds #-} +{-# language DerivingStrategies #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Expr + ( Expr(..) + , Col( E, unE ) + ) +where + +-- base +import Data.Functor.Identity ( Identity ) +import Data.Kind ( Type ) +import Data.String ( IsString, fromString ) +import Prelude hiding ( null ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr.Function ( function, nullaryFunction ) +import Rel8.Expr.Null ( liftOpNull, nullify ) +import Rel8.Expr.Opaleye + ( castExpr + , fromPrimExpr + , mapPrimExpr + , zipPrimExprsWith + ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Schema.Context ( Interpretation, Col ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable ) +import Rel8.Schema.Reify ( notReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns, reify, unreify + ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Type ( DBType ) +import Rel8.Type.Monoid ( DBMonoid, memptyExpr ) +import Rel8.Type.Num ( DBFloating, DBFractional, DBNum ) +import Rel8.Type.Semigroup ( DBSemigroup, (<>.) ) + + +-- | Typed SQL expressions. +type role Expr representational +type Expr :: k -> Type +data Expr a where + Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k) + + +deriving stock instance Show (Expr a) + + +instance Sql DBSemigroup a => Semigroup (Expr a) where + (<>) = case nullable @a of + Null -> liftOpNull (<>.) + NotNull -> (<>.) + {-# INLINABLE (<>) #-} + + +instance Sql DBMonoid a => Monoid (Expr a) where + mempty = case nullable @a of + Null -> nullify memptyExpr + NotNull -> memptyExpr + {-# INLINABLE mempty #-} + + +instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where + fromString = litExpr . case nullable @a of + Null -> Just . fromString + NotNull -> fromString + + +instance Sql DBNum a => Num (Expr a) where + (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+)) + (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*)) + (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-)) + + abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs) + negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate) + + signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN")) + + fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit + + +instance Sql DBFractional a => Fractional (Expr a) where + (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/)) + + fromRational = + castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac + + +instance Sql DBFloating a => Floating (Expr a) where + pi = nullaryFunction "PI" + exp = function "exp" + log = function "ln" + sqrt = function "sqrt" + (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^)) + logBase = function "log" + sin = function "sin" + cos = function "cos" + tan = function "tan" + asin = function "asin" + acos = function "acos" + atan = function "atan" + sinh = function "sinh" + cosh = function "cosh" + tanh = function "tanh" + asinh = function "asinh" + acosh = function "acosh" + atanh = function "atanh" + + +instance Interpretation Expr where + data Col Expr _spec where + E :: {unE :: !(Expr a)} -> Col Expr ('Spec labels a) + + +instance Sql DBType a => Table Expr (Expr a) where + type Columns (Expr a) = HType a + type Context (Expr a) = Expr + + toColumns a = HType (E a) + fromColumns (HType (E a)) = a + reify = notReify + unreify = notReify + + +instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a) + + +instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a) + + +instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a) + + +instance Labelable Expr where + labeler (E a) = E a + unlabeler (E a) = E a diff --git a/src/Rel8/Expr.hs-boot b/src/Rel8/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr.hs-boot @@ -0,0 +1,22 @@ +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language RoleAnnotations #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Expr + ( Expr(..) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude () + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + + +type role Expr representational +type Expr :: k -> Type +data Expr a where + Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k) diff --git a/src/Rel8/Expr/Aggregate.hs b/src/Rel8/Expr/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Aggregate.hs @@ -0,0 +1,189 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Aggregate + ( count, countDistinct, countStar, countWhere + , and, or + , min, max + , sum, sumWhere + , stringAgg + , groupByExpr + , listAggExpr, nonEmptyAggExpr + , slistAggExpr, snonEmptyAggExpr + ) +where + +-- base +import Data.Int ( Int64 ) +import Data.List.NonEmpty ( NonEmpty ) +import Prelude hiding ( and, max, min, null, or, sum ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Expr.Bool ( caseExpr ) +import Rel8.Expr.Opaleye + ( castExpr + , fromPrimExpr + , fromPrimExpr + , toPrimExpr + ) +import Rel8.Expr.Null ( null ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Schema.Null ( Sql, Unnullify ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Array ( encodeArrayElement ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type.Information ( TypeInformation ) +import Rel8.Type.Num ( DBNum ) +import Rel8.Type.Ord ( DBMax, DBMin ) +import Rel8.Type.String ( DBString ) +import Rel8.Type.Sum ( DBSum ) + + +-- | Count the occurances of a single column. Corresponds to @COUNT(a)@ +count :: Expr a -> Aggregate Int64 +count = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrCount + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Count the number of distinct occurances of a single column. Corresponds to +-- @COUNT(DISTINCT a)@ +countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64 +countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrCount + , ordering = [] + , distinction = Opaleye.AggrDistinct + } + + +-- | Corresponds to @COUNT(*)@. +countStar :: Aggregate Int64 +countStar = count (litExpr True) + + +-- | A count of the number of times a given expression is @true@. +countWhere :: Expr Bool -> Aggregate Int64 +countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null) + + +-- | Corresponds to @bool_and@. +and :: Expr Bool -> Aggregate Bool +and = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrBoolAnd + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Corresponds to @bool_or@. +or :: Expr Bool -> Aggregate Bool +or = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrBoolOr + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Produce an aggregation for @Expr a@ using the @max@ function. +max :: Sql DBMax a => Expr a -> Aggregate a +max = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrMax + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Produce an aggregation for @Expr a@ using the @max@ function. +min :: Sql DBMin a => Expr a -> Aggregate a +min = unsafeMakeAggregate toPrimExpr fromPrimExpr $ + Just Aggregator + { operation = Opaleye.AggrMin + , ordering = [] + , distinction = Opaleye.AggrAll + } + +-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for +-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support +-- this, and will add explicit cast back to the original input type. This can +-- lead to overflows, and if you anticipate very large sums, you should upcast +-- your input. +sum :: Sql DBSum a => Expr a -> Aggregate a +sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $ + Just Aggregator + { operation = Opaleye.AggrSum + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Take the sum of all expressions that satisfy a predicate. +sumWhere :: (Sql DBNum a, Sql DBSum a) + => Expr Bool -> Expr a -> Aggregate a +sumWhere condition a = sum (caseExpr [(condition, a)] 0) + + +-- | Corresponds to @string_agg()@. +stringAgg :: Sql DBString a + => Expr db -> Expr a -> Aggregate a +stringAgg delimiter = + unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $ + Just Aggregator + { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter) + , ordering = [] + , distinction = Opaleye.AggrAll + } + + +-- | Aggregate a value by grouping by it. +groupByExpr :: Sql DBEq a => Expr a -> Aggregate a +groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing + + +-- | Collect expressions values as a list. +listAggExpr :: Sql DBType a => Expr a -> Aggregate [a] +listAggExpr = slistAggExpr typeInformation + + +-- | Collect expressions values as a non-empty list. +nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a) +nonEmptyAggExpr = snonEmptyAggExpr typeInformation + + +slistAggExpr :: () + => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a] +slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just + Aggregator + { operation = Opaleye.AggrArr + , ordering = [] + , distinction = Opaleye.AggrAll + } + where + to = encodeArrayElement info . toPrimExpr + + +snonEmptyAggExpr :: () + => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a) +snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just + Aggregator + { operation = Opaleye.AggrArr + , ordering = [] + , distinction = Opaleye.AggrAll + } + where + to = encodeArrayElement info . toPrimExpr diff --git a/src/Rel8/Expr/Array.hs b/src/Rel8/Expr/Array.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Array.hs @@ -0,0 +1,58 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Array + ( listOf, nonEmptyOf + , slistOf, snonEmptyOf + , sappend, sappend1, sempty + ) +where + +-- base +import Data.List.NonEmpty ( NonEmpty ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr ) +import Rel8.Expr.Opaleye + ( fromPrimExpr, toPrimExpr + , zipPrimExprsWith + ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Array ( array ) +import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Schema.Null ( Unnullify, Sql ) + + +sappend :: Expr [a] -> Expr [a] -> Expr [a] +sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a) +sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +sempty :: TypeInformation (Unnullify a) -> Expr [a] +sempty info = fromPrimExpr $ array info [] + + +slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a] +slistOf info = fromPrimExpr . array info . fmap toPrimExpr + + +snonEmptyOf :: TypeInformation (Unnullify a) -> NonEmpty (Expr a) -> Expr (NonEmpty a) +snonEmptyOf info = fromPrimExpr . array info . fmap toPrimExpr + + +listOf :: Sql DBType a => [Expr a] -> Expr [a] +listOf = slistOf typeInformation + + +nonEmptyOf :: Sql DBType a => NonEmpty (Expr a) -> Expr (NonEmpty a) +nonEmptyOf = snonEmptyOf typeInformation diff --git a/src/Rel8/Expr/Bool.hs b/src/Rel8/Expr/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Bool.hs @@ -0,0 +1,90 @@ +{-# language GADTs #-} + +module Rel8.Expr.Bool + ( false, true + , (&&.), (||.), not_ + , and_, or_ + , boolExpr + , caseExpr + , coalesce + ) +where + +-- base +import Data.Foldable ( foldl' ) +import Prelude hiding ( null ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith ) +import Rel8.Expr.Serialize ( litExpr ) + + +-- | The SQL @false@ literal. +false :: Expr Bool +false = litExpr False + + +-- | The SQL @true@ literal. +true :: Expr Bool +true = litExpr True + + +-- | The SQL @AND@ operator. +(&&.) :: Expr Bool -> Expr Bool -> Expr Bool +(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd) +infixr 3 &&. + + +-- | The SQL @OR@ operator. +(||.) :: Expr Bool -> Expr Bool -> Expr Bool +(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr) +infixr 2 ||. + + +-- | The SQL @NOT@ operator. +not_ :: Expr Bool -> Expr Bool +not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot) + + +-- | Fold @AND@ over a collection of expressions. +and_ :: Foldable f => f (Expr Bool) -> Expr Bool +and_ = foldl' (&&.) true + + +-- | Fold @OR@ over a collection of expressions. +or_ :: Foldable f => f (Expr Bool) -> Expr Bool +or_ = foldl' (||.) false + + +-- | Eliminate a boolean-valued expression. +-- +-- Corresponds to 'Data.Bool.bool'. +boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a +boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse + + +-- | A multi-way if/then/else statement. The first argument to @caseExpr@ is a +-- list of alternatives. The first alternative that is of the form @(true, x)@ +-- will be returned. If no such alternative is found, a fallback expression is +-- returned. +-- +-- Corresponds to a @CASE@ expression in SQL. +caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a +caseExpr branches (Expr fallback) = + Expr $ Opaleye.CaseExpr (map go branches) fallback + where + go (condition, value) = (toPrimExpr condition, toPrimExpr value) + + +-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as +-- @False@. This can be useful when combined with 'Rel8.where_', which expects +-- a @Bool@, and produces expressions that optimize better than general case +-- analysis. +coalesce :: Expr (Maybe Bool) -> Expr Bool +coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue]) + where + untrue = Opaleye.ConstExpr (Opaleye.BoolLit False) diff --git a/src/Rel8/Expr/Eq.hs b/src/Rel8/Expr/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Eq.hs @@ -0,0 +1,101 @@ +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language ViewPatterns #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Eq + ( (==.), (/=.) + , (==?), (/=?) + , in_ + ) +where + +-- base +import Data.Foldable ( toList ) +import Data.List.NonEmpty ( nonEmpty ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr ) +import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce ) +import Rel8.Expr.Null ( isNull, unsafeLiftOpNull ) +import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith ) +import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable ) +import Rel8.Type.Eq ( DBEq ) + + +eq :: DBEq a => Expr a -> Expr a -> Expr Bool +eq = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:==)) + + +ne :: DBEq a => Expr a -> Expr a -> Expr Bool +ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>)) + + +-- | Compare two expressions for equality. +-- +-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate +-- @null@ values as @true@. This differs from @=@ which would return @null@. +-- This operator matches Haskell's '==' operator. For an operator identical to +-- SQL @=@, see '==?'. +(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool +(==.) = case nullable @a of + Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb + NotNull -> eq +infix 4 ==. +{-# INLINABLE (==.) #-} + + +-- | Test if two expressions are different (not equal). +-- +-- This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return +-- @false@ when comparing two @null@ values. This differs from ordinary @=@ +-- which would return @null@. This operator is closer to Haskell's '==' +-- operator. For an operator identical to SQL @=@, see '/=?'. +(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool +(/=.) = case nullable @a of + Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb + NotNull -> ne +infix 4 /=. +{-# INLINABLE (/=.) #-} + + +-- | Test if two expressions are equal. This operator is usually the best +-- choice when forming join conditions, as PostgreSQL has a much harder time +-- optimizing a join that has multiple 'True' conditions. +-- +-- This corresponds to the SQL @=@ operator, though it will always return a +-- 'Bool'. +(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a ==? b = coalesce $ unsafeLiftOpNull eq a b +infix 4 ==? + + +-- | Test if two expressions are different. +-- +-- This corresponds to the SQL @<>@ operator, though it will always return a +-- 'Bool'. +(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a /=? b = coalesce $ unsafeLiftOpNull ne a b +infix 4 /=? + + +-- | Like the SQL @IN@ operator, but implemented by folding over a list with +-- '==.' and '||.'. +in_ :: forall a f. (Sql DBEq a, Foldable f) + => Expr a -> f (Expr a) -> Expr Bool +in_ a (toList -> as) = case nullable @a of + Null -> or_ $ map (a ==.) as + NotNull -> case nonEmpty as of + Nothing -> false + Just xs -> + fromPrimExpr $ + Opaleye.BinExpr Opaleye.OpIn + (toPrimExpr a) + (Opaleye.ListExpr (toPrimExpr <$> xs)) diff --git a/src/Rel8/Expr/Function.hs b/src/Rel8/Expr/Function.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Function.hs @@ -0,0 +1,63 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Expr.Function + ( Function, function + , nullaryFunction + , binaryOperator + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Opaleye + ( castExpr + , fromPrimExpr, toPrimExpr, zipPrimExprsWith + ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Type ( DBType ) + + +-- | This type class exists to allow 'function' to have arbitrary arity. It's +-- mostly an implementation detail, and typical uses of 'Function' shouldn't +-- need this to be specified. +type Function :: Type -> Type -> Constraint +class Function arg res where + applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res + + +instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where + applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a] + + +instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where + applyArgument f a = applyArgument (f . (toPrimExpr a :)) + + +-- | Construct an n-ary function that produces an 'Expr' that when called runs +-- a SQL function. +function :: Function args result => String -> args -> result +function = applyArgument . Opaleye.FunExpr + + +-- | Construct a function call for functions with no arguments. +nullaryFunction :: Sql DBType a => String -> Expr a +nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name []) + + +-- | Construct an expression by applying an infix binary operator to two +-- operands. +binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c +binaryOperator operator a b = + castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b diff --git a/src/Rel8/Expr/Null.hs b/src/Rel8/Expr/Null.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Null.hs @@ -0,0 +1,102 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} + +{-# options -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Null + ( null, snull, nullableExpr, nullableOf + , isNull, isNonNull + , nullify, unsafeUnnullify + , mapNull, liftOpNull + , unsafeMapNull, unsafeLiftOpNull + ) +where + +-- base +import Prelude hiding ( null ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Bool ( (||.), boolExpr ) +import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr ) +import Rel8.Schema.Null ( NotNull ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Information ( TypeInformation ) + + +-- | Lift an expression that can't be @null@ to a type that might be @null@. +-- This is an identity operation in terms of any generated query, and just +-- modifies the query's type. +nullify :: NotNull a => Expr a -> Expr (Maybe a) +nullify (Expr a) = Expr a + + +unsafeUnnullify :: Expr (Maybe a) -> Expr a +unsafeUnnullify (Expr a) = Expr a + + +-- | Like 'maybe', but to eliminate @null@. +nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b +nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma) + + +nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a) +nullableOf = maybe null nullify + + +-- | Like 'Data.Maybe.isNothing', but for @null@. +isNull :: Expr (Maybe a) -> Expr Bool +isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull) + + +-- | Like 'Data.Maybe.isJust', but for @null@. +isNonNull :: Expr (Maybe a) -> Expr Bool +isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull) + + +-- | Lift an operation on non-@null@ values to an operation on possibly @null@ +-- values. When given @null@, @mapNull f@ returns @null@. +-- +-- This is like 'fmap' for 'Maybe'. +mapNull :: DBType b + => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b) +mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma) + + +-- | Lift a binary operation on non-@null@ expressions to an equivalent binary +-- operator on possibly @null@ expressions. If either of the final arguments +-- are @null@, @liftOpNull@ returns @null@. +-- +-- This is like 'liftA2' for 'Maybe'. +liftOpNull :: DBType c + => (Expr a -> Expr b -> Expr c) + -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c) +liftOpNull f ma mb = + boolExpr (unsafeLiftOpNull f ma mb) null + (isNull ma ||. isNull mb) +{-# INLINABLE liftOpNull #-} + + +snull :: TypeInformation a -> Expr (Maybe a) +snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit + + +-- | Corresponds to SQL @null@. +null :: DBType a => Expr (Maybe a) +null = snull typeInformation + + +unsafeMapNull :: NotNull b + => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b) +unsafeMapNull f ma = nullify (f (unsafeUnnullify ma)) + + +unsafeLiftOpNull :: NotNull c + => (Expr a -> Expr b -> Expr c) + -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c) +unsafeLiftOpNull f ma mb = + nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb)) diff --git a/src/Rel8/Expr/Num.hs b/src/Rel8/Expr/Num.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Num.hs @@ -0,0 +1,77 @@ +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Num + ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate + ) +where + +-- base +import Prelude () + +-- rel +import Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Function ( function ) +import Rel8.Expr.Opaleye ( castExpr ) +import Rel8.Schema.Null ( Homonullable, Sql ) +import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum ) + + +-- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful +-- if you need to turn an @Expr Int32@ into an @Expr Double@. +fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b) + => Expr a -> Expr b +fromIntegral (Expr a) = castExpr (Expr a) + + +-- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful +-- to convert @Expr Float@ to @Expr Double@. +realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b) + => Expr a -> Expr b +realToFrac (Expr a) = castExpr (Expr a) + + +-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger +-- integer. +-- +-- Corresponds to the @ceiling()@ function. +ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) + => Expr a -> Expr b +ceiling = function "ceiling" + + +-- | Perform integral division. Corresponds to the @div()@ function. +div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a +div = function "div" + + +-- | Corresponds to the @mod()@ function. +mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a +mod = function "mod" + + +-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller +-- integer. +-- +-- Corresponds to the @floor()@ function. +floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) + => Expr a -> Expr b +floor = function "floor" + + +-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest +-- integer. +-- +-- Corresponds to the @round()@ function. +round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) + => Expr a -> Expr b +round = function "round" + + +-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest +-- integer towards zero. +truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) + => Expr a -> Expr b +truncate = function "trunc" diff --git a/src/Rel8/Expr/Opaleye.hs b/src/Rel8/Expr/Opaleye.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Opaleye.hs @@ -0,0 +1,88 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Opaleye + ( castExpr, unsafeCastExpr + , scastExpr, sunsafeCastExpr + , unsafeLiteral + , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr + , toColumn, fromColumn + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Internal.Column as Opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) +import Rel8.Schema.Null ( Unnullify, Sql ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Information ( TypeInformation(..) ) + + +castExpr :: Sql DBType a => Expr a -> Expr a +castExpr = scastExpr typeInformation + + +-- | Cast an expression to a different type. Corresponds to a @CAST()@ function +-- call. +unsafeCastExpr :: Sql DBType b => Expr a -> Expr b +unsafeCastExpr = sunsafeCastExpr typeInformation + + +scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a +scastExpr = sunsafeCastExpr + + +sunsafeCastExpr :: () + => TypeInformation (Unnullify b) -> Expr a -> Expr b +sunsafeCastExpr TypeInformation {typeName} = + fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr + + +-- | Unsafely construct an expression from literal SQL. +-- +-- This is an escape hatch, and can be used if Rel8 can not adequately express +-- the query you need. If you find yourself using this function, please let us +-- know, as it may indicate that something is missing from Rel8! +unsafeLiteral :: String -> Expr a +unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit + + +fromPrimExpr :: Opaleye.PrimExpr -> Expr a +fromPrimExpr = Expr + + +toPrimExpr :: Expr a -> Opaleye.PrimExpr +toPrimExpr (Expr a) = a + + +mapPrimExpr :: (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b +mapPrimExpr f = fromPrimExpr . f . toPrimExpr + + +zipPrimExprsWith :: () + => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr) + -> Expr a -> Expr b -> Expr c +zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b)) + + +traversePrimExpr :: Functor f + => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b) +traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr + + +toColumn :: Opaleye.PrimExpr -> Opaleye.Column b +toColumn = Opaleye.Column + + +fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr +fromColumn (Opaleye.Column a) = a diff --git a/src/Rel8/Expr/Ord.hs b/src/Rel8/Expr/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Ord.hs @@ -0,0 +1,137 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Ord + ( (<.), (<=.), (>.), (>=.) + , (?), (>=?) + , leastExpr, greatestExpr + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Bool ( (&&.), (||.), coalesce ) +import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull ) +import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable ) +import Rel8.Type.Ord ( DBOrd ) + + +lt :: DBOrd a => Expr a -> Expr a -> Expr Bool +lt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<)) + + +le :: DBOrd a => Expr a -> Expr a -> Expr Bool +le = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<=)) + + +gt :: DBOrd a => Expr a -> Expr a -> Expr Bool +gt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>)) + + +ge :: DBOrd a => Expr a -> Expr a -> Expr Bool +ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=)) + + +-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@ +-- as @null@ will sort below any other value. For a version of @<@ that exactly +-- matches SQL, see '( Expr a -> Expr a -> Expr Bool +(<.) = case nullable @a of + Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma lt +infix 4 <. + + +-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@ +-- as @null@ will sort below any other value. For a version of @<=@ that exactly +-- matches SQL, see '(<=?)'. +(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool +(<=.) = case nullable @a of + Null -> \ma mb -> isNull ma ||. ma <=? mb + NotNull -> le +infix 4 <=. + + +-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@ +-- as @null@ will sort below any other value. For a version of @>@ that exactly +-- matches SQL, see '(>?)'. +(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool +(>.) = case nullable @a of + Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb + NotNull -> gt +infix 4 >. + + +-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@ +-- as @null@ will sort below any other value. For a version of @>=@ that +-- exactly matches SQL, see '(>=?)'. +(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool +(>=.) = case nullable @a of + Null -> \ma mb -> isNull mb ||. ma >=? mb + NotNull -> ge +infix 4 >=. + + +-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments +-- are @null@. +( Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a <=? b = coalesce $ unsafeLiftOpNull le a b +infix 4 <=? + + +-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments +-- are @null@. +(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a >? b = coalesce $ unsafeLiftOpNull gt a b +infix 4 >? + + +-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments +-- are @null@. +(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool +a >=? b = coalesce $ unsafeLiftOpNull ge a b +infix 4 >=? + + +-- | Given two expressions, return the expression that sorts less than the +-- other. +-- +-- Corresponds to the SQL @least()@ function. +leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a +leastExpr ma mb = case nullable @a of + Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma + NotNull -> least_ ma mb + where + least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b]) + + +-- | Given two expressions, return the expression that sorts greater than the +-- other. +-- +-- Corresponds to the SQL @greatest()@ function. +greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a +greatestExpr ma mb = case nullable @a of + Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma + NotNull -> greatest_ ma mb + where + greatest_ a b = + Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b]) diff --git a/src/Rel8/Expr/Order.hs b/src/Rel8/Expr/Order.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Order.hs @@ -0,0 +1,69 @@ +{-# language DataKinds #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Order + ( asc + , desc + , nullsFirst + , nullsLast + ) +where + +-- base +import Data.Bifunctor ( first ) +import Prelude + +-- opaleye +import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) ) +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.Order as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Null ( unsafeUnnullify ) +import Rel8.Expr.Opaleye ( toPrimExpr ) +import Rel8.Order ( Order( Order ) ) +import Rel8.Type.Ord ( DBOrd ) + + +-- | Sort a column in ascending order. +asc :: DBOrd a => Order (Expr a) +asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)]) + where + orderOp :: Opaleye.OrderOp + orderOp = Opaleye.OrderOp + { orderDirection = Opaleye.OpAsc + , orderNulls = Opaleye.NullsLast + } + + +-- | Sort a column in descending order. +desc :: DBOrd a => Order (Expr a) +desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)]) + where + orderOp :: Opaleye.OrderOp + orderOp = Opaleye.OrderOp + { orderDirection = Opaleye.OpDesc + , orderNulls = Opaleye.NullsFirst + } + + +-- | Transform an ordering so that @null@ values appear first. This corresponds +-- to @NULLS FIRST@ in SQL. +nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a)) +nullsFirst (Order (Opaleye.Order f)) = + Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify + where + g :: Opaleye.OrderOp -> Opaleye.OrderOp + g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst } + + +-- | Transform an ordering so that @null@ values appear first. This corresponds +-- to @NULLS LAST@ in SQL. +nullsLast :: Order (Expr a) -> Order (Expr (Maybe a)) +nullsLast (Order (Opaleye.Order f)) = + Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify + where + g :: Opaleye.OrderOp -> Opaleye.OrderOp + g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsLast } diff --git a/src/Rel8/Expr/Sequence.hs b/src/Rel8/Expr/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Sequence.hs @@ -0,0 +1,21 @@ +module Rel8.Expr.Sequence + ( nextval + ) +where + +-- base +import Data.Int ( Int64 ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Function ( function ) +import Rel8.Expr.Serialize ( litExpr ) + +-- text +import Data.Text ( pack ) + + +-- | See https://www.postgresql.org/docs/current/functions-sequence.html +nextval :: String -> Expr Int64 +nextval = function "nextval" . litExpr . pack diff --git a/src/Rel8/Expr/Serialize.hs b/src/Rel8/Expr/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Serialize.hs @@ -0,0 +1,49 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language TypeFamilies #-} + +module Rel8.Expr.Serialize + ( litExpr + , slitExpr + , sparseValue + ) +where + +-- base +import Prelude + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) +import Rel8.Expr.Opaleye ( scastExpr ) +import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Information ( TypeInformation(..) ) + + +-- | Produce an expression from a literal. +-- +-- Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems +-- of inference in polymorphic code. +litExpr :: Sql DBType a => a -> Expr a +litExpr = slitExpr nullable typeInformation + + +slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a +slitExpr nullity info@TypeInformation {encode} = + scastExpr info . Expr . encoder + where + encoder = case nullity of + Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode + NotNull -> encode + + +sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a +sparseValue nullity TypeInformation {decode} = case nullity of + Null -> Hasql.column $ Hasql.nullable decode + NotNull -> Hasql.column $ Hasql.nonNullable decode diff --git a/src/Rel8/Expr/Text.hs b/src/Rel8/Expr/Text.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Text.hs @@ -0,0 +1,275 @@ +{-# language DataKinds #-} + +module Rel8.Expr.Text + ( + -- * String concatenation + (++.) + + -- * Regular expression operators + , (~.), (~*), (!~), (!~*) + + -- * Standard SQL functions + , bitLength, charLength, lower, octetLength, upper + + -- * PostgreSQL functions + , ascii, btrim, chr, convert, convertFrom, convertTo, decode, encode + , initcap, left, length, lengthEncoding, lpad, ltrim, md5 + , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace + , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim + , splitPart, strpos, substr, translate + ) +where + +-- base +import Data.Bool ( Bool ) +import Data.Int ( Int32 ) +import Data.Maybe ( Maybe( Nothing, Just ) ) +import Prelude () + +-- bytestring +import Data.ByteString ( ByteString ) + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction ) + +-- text +import Data.Text (Text) + + +-- | The PostgreSQL string concatenation operator. +(++.) :: Expr Text -> Expr Text -> Expr Text +(++.) = binaryOperator "||" +infixr 6 ++. + + +-- * Regular expression operators + +-- See https://www.postgresql.org/docs/9.5/static/functions-matching.html#FUNCTIONS-POSIX-REGEXP + + +-- | Matches regular expression, case sensitive +-- +-- Corresponds to the @~.@ operator. +(~.) :: Expr Text -> Expr Text -> Expr Bool +(~.) = binaryOperator "~." +infix 2 ~. + + +-- | Matches regular expression, case insensitive +-- +-- Corresponds to the @~*@ operator. +(~*) :: Expr Text -> Expr Text -> Expr Bool +(~*) = binaryOperator "~*" +infix 2 ~* + + +-- | Does not match regular expression, case sensitive +-- +-- Corresponds to the @!~@ operator. +(!~) :: Expr Text -> Expr Text -> Expr Bool +(!~) = binaryOperator "!~" +infix 2 !~ + + +-- | Does not match regular expression, case insensitive +-- +-- Corresponds to the @!~*@ operator. +(!~*) :: Expr Text -> Expr Text -> Expr Bool +(!~*) = binaryOperator "!~*" +infix 2 !~* + + +-- See https://www.postgresql.org/docs/9.5/static/functions-Expr.'PGHtml + +-- * Standard SQL functions + + +-- | Corresponds to the @bit_length@ function. +bitLength :: Expr Text -> Expr Int32 +bitLength = function "bit_length" + + +-- | Corresponds to the @char_length@ function. +charLength :: Expr Text -> Expr Int32 +charLength = function "char_length" + + +-- | Corresponds to the @lower@ function. +lower :: Expr Text -> Expr Text +lower = function "lower" + + +-- | Corresponds to the @octet_length@ function. +octetLength :: Expr Text -> Expr Int32 +octetLength = function "octet_length" + + +-- | Corresponds to the @upper@ function. +upper :: Expr Text -> Expr Text +upper = function "upper" + + +-- | Corresponds to the @ascii@ function. +ascii :: Expr Text -> Expr Int32 +ascii = function "ascii" + + +-- | Corresponds to the @btrim@ function. +btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text +btrim a (Just b) = function "btrim" a b +btrim a Nothing = function "btrim" a + + +-- | Corresponds to the @chr@ function. +chr :: Expr Int32 -> Expr Text +chr = function "chr" + + +-- | Corresponds to the @convert@ function. +convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString +convert = function "convert" + + +-- | Corresponds to the @convert_from@ function. +convertFrom :: Expr ByteString -> Expr Text -> Expr Text +convertFrom = function "convert_from" + + +-- | Corresponds to the @convert_to@ function. +convertTo :: Expr Text -> Expr Text -> Expr ByteString +convertTo = function "convert_to" + + +-- | Corresponds to the @decode@ function. +decode :: Expr Text -> Expr Text -> Expr ByteString +decode = function "decode" + + +-- | Corresponds to the @encode@ function. +encode :: Expr ByteString -> Expr Text -> Expr Text +encode = function "encode" + + +-- | Corresponds to the @initcap@ function. +initcap :: Expr Text -> Expr Text +initcap = function "initcap" + + +-- | Corresponds to the @left@ function. +left :: Expr Text -> Expr Int32 -> Expr Text +left = function "left" + + +-- | Corresponds to the @length@ function. +length :: Expr Text -> Expr Int32 +length = function "length" + + +-- | Corresponds to the @length@ function. +lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32 +lengthEncoding = function "length" + + +-- | Corresponds to the @lpad@ function. +lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text +lpad a b (Just c) = function "lpad" a b c +lpad a b Nothing = function "lpad" a b + + +-- | Corresponds to the @ltrim@ function. +ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text +ltrim a (Just b) = function "ltrim" a b +ltrim a Nothing = function "ltrim" a + + +-- | Corresponds to the @md5@ function. +md5 :: Expr Text -> Expr Text +md5 = function "md5" + + +-- | Corresponds to the @pg_client_encoding()@ expression. +pgClientEncoding :: Expr Text +pgClientEncoding = nullaryFunction "pg_client_encoding" + + +-- | Corresponds to the @quote_ident@ function. +quoteIdent :: Expr Text -> Expr Text +quoteIdent = function "quote_ident" + + +-- | Corresponds to the @quote_literal@ function. +quoteLiteral :: Expr Text -> Expr Text +quoteLiteral = function "quote_literal" + + +-- | Corresponds to the @quote_nullable@ function. +quoteNullable :: Expr Text -> Expr Text +quoteNullable = function "quote_nullable" + + +-- | Corresponds to the @regexp_replace@ function. +regexpReplace :: () + => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text +regexpReplace a b c (Just d) = function "regexp_replace" a b c d +regexpReplace a b c Nothing = function "regexp_replace" a b c + + +-- | Corresponds to the @regexp_split_to_array@ function. +regexpSplitToArray :: () + => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text] +regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c +regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b + + +-- | Corresponds to the @repeat@ function. +repeat :: Expr Text -> Expr Int32 -> Expr Text +repeat = function "repeat" + + +-- | Corresponds to the @replace@ function. +replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text +replace = function "replace" + + +-- | Corresponds to the @reverse@ function. +reverse :: Expr Text -> Expr Text +reverse = function "reverse" + + +-- | Corresponds to the @right@ function. +right :: Expr Text -> Expr Int32 -> Expr Text +right = function "right" + + +-- | Corresponds to the @rpad@ function. +rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text +rpad a b (Just c) = function "rpad" a b c +rpad a b Nothing = function "rpad" a b + + +-- | Corresponds to the @rtrim@ function. +rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text +rtrim a (Just b) = function "rtrim" a b +rtrim a Nothing = function "rtrim" a + + +-- | Corresponds to the @split_part@ function. +splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text +splitPart = function "split_part" + + +-- | Corresponds to the @strpos@ function. +strpos :: Expr Text -> Expr Text -> Expr Int32 +strpos = function "strpos" + + +-- | Corresponds to the @substr@ function. +substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text +substr a b (Just c) = function "substr" a b c +substr a b Nothing = function "substr" a b + + +-- | Corresponds to the @translate@ function. +translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text +translate = function "translate" diff --git a/src/Rel8/Expr/Time.hs b/src/Rel8/Expr/Time.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Time.hs @@ -0,0 +1,167 @@ +module Rel8.Expr.Time + ( -- * Working with @Day@ + today + , toDay + , fromDay + , addDays + , diffDays + , subtractDays + + -- * Working with @UTCTime@ + , now + , addTime + , diffTime + , subtractTime + + -- * Working with @CalendarDiffTime@ + , scaleInterval + , second, seconds + , minute, minutes + , hour, hours + , day, days + , week, weeks + , month, months + , year, years + ) where + +-- base +import Data.Int ( Int32 ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Function ( binaryOperator, nullaryFunction ) +import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral ) + +-- time +import Data.Time.Calendar ( Day ) +import Data.Time.Clock ( UTCTime ) +import Data.Time.LocalTime ( CalendarDiffTime ) + + +-- | Corresponds to @date(now())@. +today :: Expr Day +today = toDay now + + +-- | Corresponds to calling the @date@ function with a given time. +toDay :: Expr UTCTime -> Expr Day +toDay = unsafeCastExpr + + +-- | Corresponds to @x::timestamptz@. +fromDay :: Expr Day -> Expr UTCTime +fromDay = unsafeCastExpr + + +-- | Move forward a given number of days from a particular day. +addDays :: Expr Int32 -> Expr Day -> Expr Day +addDays = flip (binaryOperator "+") + + +-- | Find the number of days between two days. Corresponds to the @-@ operator. +diffDays :: Expr Day -> Expr Day -> Expr Int32 +diffDays = binaryOperator "-" + + +-- | Subtract a given number of days from a particular 'Day'. +subtractDays :: Expr Int32 -> Expr Day -> Expr Day +subtractDays = flip (binaryOperator "-") + + +-- | Corresponds to @now()@. +now :: Expr UTCTime +now = nullaryFunction "now" + + +-- | Add a time interval to a point in time, yielding a new point in time. +addTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime +addTime = flip (binaryOperator "+") + + +-- | Find the duration between two times. +diffTime :: Expr UTCTime -> Expr UTCTime -> Expr CalendarDiffTime +diffTime = binaryOperator "-" + + +-- | Subtract a time interval from a point in time, yielding a new point in time. +subtractTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime +subtractTime = flip (binaryOperator "-") + + +scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime +scaleInterval = binaryOperator "*" + + +-- | An interval of one second. +second :: Expr CalendarDiffTime +second = singleton "second" + + +-- | Create a literal interval from a number of seconds. +seconds :: Expr Double -> Expr CalendarDiffTime +seconds = (`scaleInterval` second) + + +-- | An interval of one minute. +minute :: Expr CalendarDiffTime +minute = singleton "minute" + + +-- | Create a literal interval from a number of minutes. +minutes :: Expr Double -> Expr CalendarDiffTime +minutes = (`scaleInterval` minute) + + +-- | An interval of one hour. +hour :: Expr CalendarDiffTime +hour = singleton "hour" + + +-- | Create a literal interval from a number of hours. +hours :: Expr Double -> Expr CalendarDiffTime +hours = (`scaleInterval` hour) + + +-- | An interval of one day. +day :: Expr CalendarDiffTime +day = singleton "day" + + +-- | Create a literal interval from a number of days. +days :: Expr Double -> Expr CalendarDiffTime +days = (`scaleInterval` day) + + +-- | An interval of one week. +week :: Expr CalendarDiffTime +week = singleton "week" + + +-- | Create a literal interval from a number of weeks. +weeks :: Expr Double -> Expr CalendarDiffTime +weeks = (`scaleInterval` week) + + +-- | An interval of one month. +month :: Expr CalendarDiffTime +month = singleton "month" + + +-- | Create a literal interval from a number of months. +months :: Expr Double -> Expr CalendarDiffTime +months = (`scaleInterval` month) + + +-- | An interval of one year. +year :: Expr CalendarDiffTime +year = singleton "year" + + +-- | Create a literal interval from a number of years. +years :: Expr Double -> Expr CalendarDiffTime +years = (`scaleInterval` year) + + +singleton :: String -> Expr CalendarDiffTime +singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'" diff --git a/src/Rel8/FCF.hs b/src/Rel8/FCF.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/FCF.hs @@ -0,0 +1,26 @@ +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.FCF + ( Exp, Eval + , Compose + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude () + + +type Exp :: Type -> Type +type Exp e = e -> Type + + +type Eval :: Exp e -> e +type family Eval a + + +data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type +type instance Eval (Compose f g a) = f (Eval (g a)) diff --git a/src/Rel8/Generic/Construction.hs b/src/Rel8/Generic/Construction.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Construction.hs @@ -0,0 +1,371 @@ +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} + +module Rel8.Generic.Construction + ( GGBuildable + , GGBuild, ggbuild + , GGConstructable + , GGConstruct, ggconstruct + , GGDeconstruct, ggdeconstruct + , GGName, ggname + , GGAggregate, ggaggregate + ) +where + +-- base +import Data.Bifunctor ( first ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import GHC.TypeLits ( Symbol ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) ) +import Rel8.Expr ( Col( E ), Expr ) +import Rel8.Expr.Aggregate ( groupByExpr ) +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Construction.ADT + ( GConstructorADT, GMakeableADT, gmakeADT + , GConstructableADT + , GBuildADT, gbuildADT, gunbuildADT + , GConstructADT, gconstructADT, gdeconstructADT + , RepresentableConstructors, GConstructors, gcindex, gctabulate + , RepresentableFields, gfindex, gftabulate + ) +import Rel8.Generic.Construction.Record + ( GConstructor + , GConstructable, GConstruct, gconstruct, gdeconstruct + , Representable, gindex, gtabulate + ) +import Rel8.Generic.Table ( GGColumns ) +import Rel8.Kind.Algebra + ( SAlgebra( SProduct, SSum ) + , KnownAlgebra, algebraSing + ) +import qualified Rel8.Kind.Algebra as K +import Rel8.Schema.Context.Nullify ( runTag ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Col( N ), Name( Name ) ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) ) +import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( TTable, TColumns, TUnreify + , Table, fromColumns, toColumns, reify, unreify + ) +import Rel8.Table.Bool ( case_ ) +import Rel8.Type.Tag ( Tag ) + + +type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint +type GGBuildable algebra name rep = + ( KnownAlgebra algebra + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))) + , GGBuildable' algebra name rep + ) + + +type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint +type family GGBuildable' algebra name rep where + GGBuildable' 'K.Product name rep = + ( name ~ GConstructor (Eval (rep (Reify Expr))) + , Representable TUnreify (Eval (rep (Reify Expr))) + , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr))) + ) + GGBuildable' 'K.Sum name rep = + ( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) + , GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr))) + ) + + +type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type +type family GGBuild algebra name rep r where + GGBuild 'K.Product _name rep r = + GConstruct TUnreify (Eval (rep (Reify Expr))) r + GGBuild 'K.Sum name rep r = + GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r + + +ggbuild :: forall algebra name rep a. GGBuildable algebra name rep + => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a) + -> GGBuild algebra name rep a +ggbuild gfromColumns = case algebraSing @algebra of + SProduct -> + gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $ + gfromColumns . + hunreify . + gconstruct + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + SSum -> + gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $ + gfromColumns . + hunreify . + gmakeADT + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @name + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + (\SSpec {info} -> Reify (E (snull info))) + (\SSpec {nullity} -> case nullity of + Null -> id + NotNull -> \(Reify (E a)) -> Reify (E (nullify a))) + (HType . Reify . E . litExpr) + + +type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint +type GGConstructable algebra rep = + ( KnownAlgebra algebra + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) + , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))) + , GGConstructable' algebra rep + ) + + +type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint +type family GGConstructable' algebra rep where + GGConstructable' 'K.Product rep = + ( Representable TUnreify (Eval (rep (Reify Aggregate))) + , Representable TUnreify (Eval (rep (Reify Expr))) + , Representable TUnreify (Eval (rep (Reify Name))) + , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate))) + , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr))) + , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name))) + ) + GGConstructable' 'K.Sum rep = + ( RepresentableConstructors TUnreify (Eval (rep (Reify Expr))) + , RepresentableFields TUnreify (Eval (rep (Reify Aggregate))) + , RepresentableFields TUnreify (Eval (rep (Reify Expr))) + , RepresentableFields TUnreify (Eval (rep (Reify Name))) + , Functor (GConstructors TUnreify (Eval (rep (Reify Expr)))) + , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate))) + , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr))) + , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name))) + ) + + +type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type +type family GGConstruct algebra rep r where + GGConstruct 'K.Product rep r = + GConstruct TUnreify (Eval (rep (Reify Expr))) r -> r + GGConstruct 'K.Sum rep r = + GConstructADT TUnreify (Eval (rep (Reify Expr))) r r + + +ggconstruct :: forall algebra rep a. GGConstructable algebra rep + => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a) + -> GGConstruct algebra rep a -> a +ggconstruct gfromColumns f = case algebraSing @algebra of + SProduct -> + f $ + gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $ + gfromColumns . + hunreify . + gconstruct + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + SSum -> + gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $ + fmap (gfromColumns . hunreify) $ + gconstructADT + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + (\SSpec {info} -> Reify (E (snull info))) + (\SSpec {nullity} -> case nullity of + Null -> id + NotNull -> \(Reify (E a)) -> Reify (E (nullify a))) + (HType . Reify . E . litExpr) + + +type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type +type family GGDeconstruct algebra rep a r where + GGDeconstruct 'K.Product rep a r = + GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r + GGDeconstruct 'K.Sum rep a r = + GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r) + + +ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r) + => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr)) + -> GGDeconstruct algebra rep a r +ggdeconstruct gtoColumns = case algebraSing @algebra of + SProduct -> \build -> + gindex @TUnreify @(Eval (rep (Reify Expr))) @r build . + gdeconstruct + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) . + hreify . + gtoColumns + SSum -> + gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as -> + let + (HType (Reify (E tag)), cases) = + gdeconstructADT + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) + (\SSpec {nullity} -> case nullity of + Null -> id + NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) + constructors $ + hreify $ + gtoColumns as + in + case cases of + ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) -> + case_ cases' r + + +type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type +type family GGName algebra rep a where + GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a + GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a + + +ggname :: forall algebra rep a. GGConstructable algebra rep + => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a) + -> GGName algebra rep a +ggname gfromColumns = case algebraSing @algebra of + SProduct -> + gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $ + gfromColumns . + hunreify . + gconstruct + @(TTable (Reify Name)) + @TColumns + @TUnreify + @(Col (Reify Name)) + @(Eval (rep (Reify Name))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + SSum -> \tag -> + gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $ + gfromColumns . + hunreify . + gbuildADT + @(TTable (Reify Name)) + @TColumns + @TUnreify + @(Col (Reify Name)) + @(Eval (rep (Reify Name))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + (\_ _ (Reify (N (Name a))) -> Reify (N (Name a))) + (HType (Reify (N tag))) + + +type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type +type family GGAggregate algebra rep r where + GGAggregate 'K.Product rep r = + GConstruct TUnreify (Eval (rep (Reify Aggregate))) r -> + GConstruct TUnreify (Eval (rep (Reify Expr))) r + GGAggregate 'K.Sum rep r = + GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r -> + GBuildADT TUnreify (Eval (rep (Reify Expr))) r + + +ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep + => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg) + -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr)) + -> GGAggregate algebra rep agg -> exprs -> agg +ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of + SProduct -> flip f exprs $ + gfromColumns . + hunreify . + gconstruct + @(TTable (Reify Aggregate)) + @TColumns + @TUnreify + @(Col (Reify Aggregate)) + @(Eval (rep (Reify Aggregate))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + where + f = + gindex @TUnreify @(Eval (rep (Reify Expr))) @agg . + agg . + gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg + exprs = + gdeconstruct + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $ + hreify $ + gtoColumns es + SSum -> flip f exprs $ + gfromColumns . + hunreify . + gbuildADT + @(TTable (Reify Aggregate)) + @TColumns + @TUnreify + @(Col (Reify Aggregate)) + @(Eval (rep (Reify Aggregate))) + (\(_ :: proxy x) -> toColumns . reify @_ @x Refl) + (\tag' SSpec {nullity} (Reify (A (Aggregate a))) -> + Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a) + (HType (Reify (A (groupByExpr tag)))) + where + f = + gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg . + agg . + gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg + (HType (Reify (E tag)), exprs) = + gunbuildADT + @(TTable (Reify Expr)) + @TColumns + @TUnreify + @(Col (Reify Expr)) + @(Eval (rep (Reify Expr))) + (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) + (\SSpec {nullity} -> case nullity of + Null -> id + NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $ + hreify $ + gtoColumns es diff --git a/src/Rel8/Generic/Construction/ADT.hs b/src/Rel8/Generic/Construction/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Construction/ADT.hs @@ -0,0 +1,493 @@ +{-# language AllowAmbiguousTypes #-} +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Construction.ADT + ( GConstructableADT + , GBuildADT, gbuildADT, gunbuildADT + , GConstructADT, gconstructADT, gdeconstructADT + , GFields, RepresentableFields, gftabulate, gfindex + , GConstructors, RepresentableConstructors, gctabulate, gcindex + , GConstructorADT, GMakeableADT, gmakeADT + ) +where + +-- base +import Data.Bifunctor ( first ) +import Data.Functor.Identity ( runIdentity ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.Generics + ( (:+:), (:*:)( (:*:) ), M1, U1 + , C, D + , Meta( MetaData, MetaCons ) + ) +import GHC.TypeLits + ( ErrorMessage( (:<>:), Text ), TypeError + , Symbol, KnownSymbol, symbolVal + ) +import Prelude hiding ( null ) + +-- rel8 +import Rel8.FCF ( Exp ) +import Rel8.Generic.Construction.Record + ( GConstruct, GConstructable, gconstruct, gdeconstruct + , GFields, Representable, gtabulate, gindex + , FromColumns, ToColumns + ) +import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' ) +import Rel8.Generic.Table.Record ( GColumns ) +import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HType ) +import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) +import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import Rel8.Schema.Null ( Nullify ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec ) +import qualified Rel8.Schema.Kind as K +import Rel8.Type.Tag ( Tag( Tag ) ) + +-- text +import Data.Text ( pack ) + + +type Null :: K.HContext -> Type +type Null context = forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels (Nullify a)) + + +type Nullifier :: K.HContext -> Type +type Nullifier context = forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels a) + -> context ('Spec labels (Nullify a)) + + +type Unnullifier :: K.HContext -> Type +type Unnullifier context = forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels (Nullify a)) + -> context ('Spec labels a) + + +type NoConstructor :: Symbol -> Symbol -> ErrorMessage +type NoConstructor datatype constructor = + ( 'Text "The type `" ':<>: + 'Text datatype ':<>: + 'Text "` has no constructor `" ':<>: + 'Text constructor ':<>: + 'Text "`." + ) + + +type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type +type family GConstructorADT name rep where + GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) = + GConstructorADT' name rep (TypeError (NoConstructor datatype name)) + + +type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type +type family GConstructorADT' name rep fallback where + GConstructorADT' name (M1 D _ rep) fallback = + GConstructorADT' name rep fallback + GConstructorADT' name (a :+: b) fallback = + GConstructorADT' name a (GConstructorADT' name b fallback) + GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep + GConstructorADT' _ _ fallback = fallback + + +type GConstructADT + :: (Type -> Exp Type) + -> (Type -> Type) -> Type -> Type -> Type +type family GConstructADT f rep r x where + GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x + GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x) + GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x + + +type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type +type family GConstructors f rep where + GConstructors f (M1 D _ rep) = GConstructors f rep + GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b + GConstructors f (M1 C _ rep) = (->) (GFields f rep) + + +type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint +class RepresentableConstructors f rep where + gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a + gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a + + +instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where + gctabulate = gctabulate @f @rep + gcindex = gcindex @f @rep + + +instance (RepresentableConstructors f a, RepresentableConstructors f b) => + RepresentableConstructors f (a :+: b) + where + gctabulate f = + gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b) + gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b + + +instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where + gctabulate f = f . gindex @f @rep + gcindex f = f . gtabulate @f @rep + + +type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type +type family GBuildADT f rep r where + GBuildADT f (M1 D _ rep) r = GBuildADT f rep r + GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r) + GBuildADT f (M1 C _ rep) r = GConstruct f rep r + + +type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type +type family GFieldsADT f rep where + GFieldsADT f (M1 D _ rep) = GFieldsADT f rep + GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b) + GFieldsADT f (M1 C _ rep) = GFields f rep + + +type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint +class RepresentableFields f rep where + gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a + gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a + + +instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where + gftabulate = gftabulate @f @rep + gfindex = gfindex @f @rep + + +instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where + gftabulate f = + gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b) + gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b + + +instance Representable f rep => RepresentableFields f (M1 C meta rep) where + gftabulate = gtabulate @f @rep + gfindex = gindex @f @rep + + +type GConstructableADT + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext -> (Type -> Type) -> Constraint +class GConstructableADT _Table _Columns f context rep where + gbuildADT :: () + => ToColumns _Table _Columns f context + -> (Tag -> Nullifier context) + -> HType Tag context + -> GFieldsADT f rep + -> GColumnsADT _Columns rep context + + gunbuildADT :: () + => FromColumns _Table _Columns f context + -> Unnullifier context + -> GColumnsADT _Columns rep context + -> (HType Tag context, GFieldsADT f rep) + + gconstructADT :: () + => ToColumns _Table _Columns f context + -> Null context + -> Nullifier context + -> (Tag -> HType Tag context) + -> GConstructors f rep (GColumnsADT _Columns rep context) + + gdeconstructADT :: () + => FromColumns _Table _Columns f context + -> Unnullifier context + -> GConstructors f rep r + -> GColumnsADT _Columns rep context + -> (HType Tag context, NonEmpty (Tag, r)) + + +instance + ( htable ~ HLabel "tag" (HType Tag) + , GConstructableADT' _Table _Columns f context htable rep + , HLabelable context + ) + => GConstructableADT _Table _Columns f context (M1 D meta rep) + where + gbuildADT toColumns nullifier = + gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier . + hlabel hlabeler + + gunbuildADT fromColumns unnullifier = + first (hunlabel hunlabeler) . + gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier + + gconstructADT toColumns null nullifier mk = + gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier + (hlabel hlabeler . mk) + + gdeconstructADT fromColumns unnullifier cases = + first (hunlabel hunlabeler) . + gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases + + +type GConstructableADT' + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint +class GConstructableADT' _Table _Columns f context htable rep where + gbuildADT' :: () + => ToColumns _Table _Columns f context + -> (Tag -> Nullifier context) + -> htable context + -> GFieldsADT f rep + -> GColumnsADT' _Columns htable rep context + + gunbuildADT' :: () + => FromColumns _Table _Columns f context + -> Unnullifier context + -> GColumnsADT' _Columns htable rep context + -> (htable context, GFieldsADT f rep) + + gconstructADT' :: () + => ToColumns _Table _Columns f context + -> Null context + -> Nullifier context + -> (Tag -> htable context) + -> GConstructors f rep (GColumnsADT' _Columns htable rep context) + + gdeconstructADT' :: () + => FromColumns _Table _Columns f context + -> Unnullifier context + -> GConstructors f rep r + -> GColumnsADT' _Columns htable rep context + -> (htable context, NonEmpty (Tag, r)) + + gfill :: () + => Null context + -> htable context + -> GColumnsADT' _Columns htable rep context + + +instance + ( htable' ~ GColumnsADT' _Columns htable a + , Functor (GConstructors f a) + , GConstructableADT' _Table _Columns f context htable a + , GConstructableADT' _Table _Columns f context htable' b + ) + => GConstructableADT' _Table _Columns f context htable (a :+: b) + where + gbuildADT' toColumns nullifier htable (a, b) = + gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier + (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a) + b + + gunbuildADT' fromColumns unnullifier columns = + case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of + (htable', b) -> + case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of + (htable, a) -> (htable, (a, b)) + + gconstructADT' toColumns null nullifier mk = + fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*: + gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk) + + gdeconstructADT' fromColumns unnullifier (a :*: b) columns = + case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of + (htable', cases) -> + case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of + (htable, cases') -> (htable, cases' <> cases) + + gfill null = + gfill @_Table @_Columns @f @context @htable' @b null . + gfill @_Table @_Columns @f @context @htable @a null + + +instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => + GConstructableADT' _Table _Columns f context htable (M1 C meta U1) + where + gbuildADT' _ _ = const + gunbuildADT' _ _ = (, ()) + gconstructADT' _ _ _ f _ = f tag + where + tag = Tag $ pack $ symbolVal (Proxy @label) + gdeconstructADT' _ _ r htable = (htable, pure (tag, r ())) + where + tag = Tag $ pack $ symbolVal (Proxy @label) + gfill _ = id + + +instance {-# OVERLAPPABLE #-} + ( HTable (GColumns _Columns rep) + , KnownSymbol label + , meta ~ 'MetaCons label _fixity _isRecord + , HLabelable context + , GConstructable _Table _Columns f context rep + , GColumnsADT' _Columns htable (M1 C meta rep) ~ + HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + ) + => GConstructableADT' _Table _Columns f context htable (M1 C meta rep) + where + gbuildADT' toColumns nullifier htable = + HProduct htable . + hlabel hlabeler . + hnullify (nullifier tag) . + gconstruct @_Table @_Columns @f @context @rep toColumns + where + tag = Tag $ pack $ symbolVal (Proxy @label) + + gunbuildADT' fromColumns unnullifier (HProduct htable a) = + ( htable + , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $ + runIdentity $ + hunnullify (\spec -> pure . unnullifier spec) $ + hunlabel hunlabeler + a + ) + + gconstructADT' toColumns _ nullifier mk = + HProduct htable . + hlabel hlabeler . + hnullify nullifier . + gconstruct @_Table @_Columns @f @context @rep toColumns + where + tag = Tag $ pack $ symbolVal (Proxy @label) + htable = mk tag + + gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) = + ( htable + , pure (tag, r a) + ) + where + a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $ + runIdentity $ + hunnullify (\spec -> pure . unnullifier spec) $ + hunlabel hunlabeler + columns + tag = Tag $ pack $ symbolVal (Proxy @label) + + gfill null htable = HProduct htable (hlabel hlabeler (hnulls null)) + + +type GMakeableADT + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext -> Symbol -> (Type -> Type) -> Constraint +class GMakeableADT _Table _Columns f context name rep where + gmakeADT :: () + => ToColumns _Table _Columns f context + -> Null context + -> Nullifier context + -> (Tag -> HType Tag context) + -> GFields f (GConstructorADT name rep) + -> GColumnsADT _Columns rep context + + +instance + ( htable ~ HLabel "tag" (HType Tag) + , meta ~ 'MetaData datatype _module _package _newtype + , fallback ~ TypeError (NoConstructor datatype name) + , fields ~ GFields f (GConstructorADT' name rep fallback) + , GMakeableADT' _Table _Columns f context htable name rep fields + , HLabelable context + , KnownSymbol name + ) + => GMakeableADT _Table _Columns f context name (M1 D meta rep) + where + gmakeADT toColumns null nullifier wrap = + gmakeADT' + @_Table @_Columns @f @context @htable @name @rep @fields + toColumns null nullifier htable + where + tag = Tag $ pack $ symbolVal (Proxy @name) + htable = hlabel hlabeler (wrap tag) + + +type GMakeableADT' + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint +class GMakeableADT' _Table _Columns f context htable name rep fields where + gmakeADT' :: () + => ToColumns _Table _Columns f context + -> Null context + -> Nullifier context + -> htable context + -> fields + -> GColumnsADT' _Columns htable rep context + + +instance + ( htable' ~ GColumnsADT' _Columns htable a + , GMakeableADT' _Table _Columns f context htable name a fields + , GMakeableADT' _Table _Columns f context htable' name b fields + ) + => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields + where + gmakeADT' toColumns null nullifier htable x = + gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields + toColumns null nullifier + (gmakeADT' + @_Table @_Columns @f @context @htable @name @a @fields toColumns + null nullifier htable x) + x + + +instance {-# OVERLAPPING #-} + GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields + where + gmakeADT' _ _ _ = const + + +instance {-# OVERLAPS #-} + GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields + where + gmakeADT' _ _ _ = const + + +instance {-# OVERLAPS #-} + ( HTable (GColumns _Columns rep) + , KnownSymbol name + , HLabelable context + , GConstructable _Table _Columns f context rep + , fields ~ GFields f rep + , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~ + HProduct htable (HLabel name (HNullify (GColumns _Columns rep))) + ) + => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields + where + gmakeADT' toColumns _ nullifier htable = + HProduct htable . + hlabel hlabeler . + hnullify nullifier . + gconstruct @_Table @_Columns @f @context @rep toColumns + + +instance {-# OVERLAPPABLE #-} + ( HTable (GColumns _Columns rep) + , KnownSymbol label + , HLabelable context + , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~ + HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + ) + => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields + where + gmakeADT' _ null _ htable _ = + HProduct htable $ + hlabel hlabeler $ + hnulls null diff --git a/src/Rel8/Generic/Construction/Record.hs b/src/Rel8/Generic/Construction/Record.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Construction/Record.hs @@ -0,0 +1,173 @@ +{-# language AllowAmbiguousTypes #-} +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Construction.Record + ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct + , GFields, Representable, gtabulate, gindex + , FromColumns, ToColumns + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.Generics + ( (:*:), K1, M1, U1 + , D, C, S, Meta( MetaData, MetaCons, MetaSel ) + ) +import GHC.TypeLits + ( ErrorMessage( (:<>:), Text ), TypeError + , Symbol, KnownSymbol + ) +import Prelude + +-- rel8 +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Table.Record ( GColumns ) +import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import qualified Rel8.Schema.Kind as K + + +type FromColumns + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext + -> Type +type FromColumns _Table _Columns f context = forall proxy x. + Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x) + + +type ToColumns + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext + -> Type +type ToColumns _Table _Columns f context = forall proxy x. + Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context + + +type GConstructor :: (Type -> Type) -> Symbol +type family GConstructor rep where + GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name + GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError ( + 'Text "`" ':<>: + 'Text name ':<>: + 'Text "` does not appear to have exactly 1 constructor" + ) + + +type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type +type family GConstruct f rep r where + GConstruct f (M1 _ _ rep) r = GConstruct f rep r + GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r) + GConstruct _ U1 r = r + GConstruct f (K1 _ a) r = Eval (f a) -> r + + +type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type +type family GFields f rep where + GFields f (M1 _ _ rep) = GFields f rep + GFields f (a :*: b) = (GFields f a, GFields f b) + GFields _ U1 = () + GFields f (K1 _ a) = Eval (f a) + + +type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint +class Representable f rep where + gtabulate :: (GFields f rep -> a) -> GConstruct f rep a + gindex :: GConstruct f rep a -> GFields f rep -> a + + +instance Representable f rep => Representable f (M1 i meta rep) where + gtabulate = gtabulate @f @rep + gindex = gindex @f @rep + + +instance (Representable f a, Representable f b) => + Representable f (a :*: b) + where + gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b) + gindex f (a, b) = gindex @f @b (gindex @f @a f a) b + + +instance Representable f U1 where + gtabulate = ($ ()) + gindex = const + + +instance Representable f (K1 i a) where + gtabulate = id + gindex = id + + +type GConstructable + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Exp Type) + -> K.HContext -> (Type -> Type) -> Constraint +class GConstructable _Table _Columns f context rep where + gconstruct :: () + => ToColumns _Table _Columns f context + -> GFields f rep + -> GColumns _Columns rep context + gdeconstruct :: () + => FromColumns _Table _Columns f context + -> GColumns _Columns rep context + -> GFields f rep + + +instance (GConstructable _Table _Columns f context rep) => + GConstructable _Table _Columns f context (M1 D meta rep) + where + gconstruct = gconstruct @_Table @_Columns @f @context @rep + gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep + + +instance (GConstructable _Table _Columns f context rep) => + GConstructable _Table _Columns f context (M1 C meta rep) + where + gconstruct = gconstruct @_Table @_Columns @f @context @rep + gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep + + +instance + ( GConstructable _Table _Columns f context a + , GConstructable _Table _Columns f context b + ) + => GConstructable _Table _Columns f context (a :*: b) + where + gconstruct toColumns (a, b) = HProduct + (gconstruct @_Table @_Columns @f @context @a toColumns a) + (gconstruct @_Table @_Columns @f @context @b toColumns b) + gdeconstruct fromColumns (HProduct a b) = + ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a + , gdeconstruct @_Table @_Columns @f @context @b fromColumns b + ) + + +instance + ( Eval (_Table a) + , HTable (Eval (_Columns a)) + , HLabelable context + , KnownSymbol label + , meta ~ 'MetaSel ('Just label) _su _ss _ds + ) + => GConstructable _Table _Columns f context (M1 S meta (K1 i a)) + where + gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a) + gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler diff --git a/src/Rel8/Generic/Map.hs b/src/Rel8/Generic/Map.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Map.hs @@ -0,0 +1,93 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language EmptyCase #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Map + ( GMap, GMappable (gmap, gunmap) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import GHC.Generics + ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1 + ) +import Prelude () + +-- rel8 +import Rel8.FCF ( Eval, Exp ) + + +type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type +type family GMap f rep where + GMap f (M1 i c rep) = M1 i c (GMap f rep) + GMap _ V1 = V1 + GMap f (rep1 :+: rep2) = GMap f rep1 :+: GMap f rep2 + GMap _ U1 = U1 + GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2 + GMap f (K1 i a) = K1 i (Eval (f a)) + + +type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint +class GMappable constraint rep where + gmap :: () + => proxy f + -> (forall a. Eval (constraint a) => a -> Eval (f a)) + -> rep x + -> GMap f rep x + + gunmap :: () + => proxy f + -> (forall a. Eval (constraint a) => Eval (f a) -> a) + -> GMap f rep x + -> rep x + + +instance GMappable constraint rep => GMappable constraint (M1 i c rep) where + gmap proxy f (M1 a) = M1 (gmap @constraint proxy f a) + gunmap proxy f (M1 a) = M1 (gunmap @constraint proxy f a) + + +instance GMappable constraint V1 where + gmap _ _ = \case + gunmap _ _ = \case + + +instance (GMappable constraint rep1, GMappable constraint rep2) => + GMappable constraint (rep1 :+: rep2) + where + gmap proxy f = \case + L1 a -> L1 (gmap @constraint proxy f a) + R1 a -> R1 (gmap @constraint proxy f a) + gunmap proxy f = \case + L1 a -> L1 (gunmap @constraint proxy f a) + R1 a -> R1 (gunmap @constraint proxy f a) + + +instance GMappable constraint U1 where + gmap _ _ U1 = U1 + gunmap _ _ U1 = U1 + + +instance (GMappable constraint rep1, GMappable constraint rep2) => + GMappable constraint (rep1 :*: rep2) + where + gmap proxy f (a :*: b) = + gmap @constraint proxy f a :*: gmap @constraint proxy f b + gunmap proxy f (a :*: b) = + gunmap @constraint proxy f a :*: gunmap @constraint proxy f b + + +instance Eval (constraint a) => GMappable constraint (K1 i a) where + gmap _ f (K1 a) = K1 (f a) + gunmap _ f (K1 a) = K1 (f a) diff --git a/src/Rel8/Generic/Record.hs b/src/Rel8/Generic/Record.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Record.hs @@ -0,0 +1,153 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Record + ( Record(..) + , GRecordable, GRecord, grecord, gunrecord + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import GHC.Generics + ( Generic, Rep, from, to + , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 ) + , Meta( MetaCons, MetaSel ), D, C, S + ) +import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol ) +import Prelude hiding ( Show ) + + +type GRecord :: (Type -> Type) -> Type -> Type +type family GRecord rep where + GRecord (M1 D meta rep) = M1 D meta (GRecord rep) + GRecord (l :+: r) = GRecord l :+: GRecord r + GRecord (M1 C ('MetaCons name fixity 'False) rep) = + M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep)) + GRecord rep = rep + + +type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type) +type family Count n rep where + Count n (M1 S ('MetaSel _selector su ss ds) rep) = + '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep) + Count n (a :*: b) = CountHelper1 (Count n a) b + Count n rep = '(n, rep) + + +type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type) +type family CountHelper1 tuple b where + CountHelper1 '(n, a) b = CountHelper2 a (Count n b) + + +type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type) +type family CountHelper2 a tuple where + CountHelper2 a '(n, b) = '(n, a :*: b) + + +type Show :: Nat -> Symbol +type Show n = + AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))) + + +type Show' :: Nat -> Symbol +type family Show' n where + Show' 0 = "" + Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)) + + +type ShowDigit :: Nat -> Symbol +type family ShowDigit n where + ShowDigit 0 = "0" + ShowDigit 1 = "1" + ShowDigit 2 = "2" + ShowDigit 3 = "3" + ShowDigit 4 = "4" + ShowDigit 5 = "5" + ShowDigit 6 = "6" + ShowDigit 7 = "7" + ShowDigit 8 = "8" + ShowDigit 9 = "9" + + +type Snd :: (a, b) -> b +type family Snd tuple where + Snd '(_a, b) = b + + +type GRecordable :: (Type -> Type) -> Constraint +class GRecordable rep where + grecord :: rep x -> GRecord rep x + gunrecord :: GRecord rep x -> rep x + + +instance GRecordable rep => GRecordable (M1 D meta rep) where + grecord (M1 a) = M1 (grecord a) + gunrecord (M1 a) = M1 (gunrecord a) + + +instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where + grecord (L1 a) = L1 (grecord a) + grecord (R1 a) = R1 (grecord a) + gunrecord (L1 a) = L1 (gunrecord a) + gunrecord (R1 a) = R1 (gunrecord a) + + +instance Countable 0 rep => + GRecordable (M1 C ('MetaCons name fixity 'False) rep) + where + grecord (M1 a) = M1 (count @0 a) + gunrecord (M1 a) = M1 (uncount @0 a) + + +instance {-# OVERLAPPABLE #-} GRecord rep ~ rep => GRecordable rep where + grecord = id + gunrecord = id + + +type Countable :: Nat -> (Type -> Type) -> Constraint +class Countable n rep where + count :: rep x -> Snd (Count n rep) x + uncount :: Snd (Count n rep) x -> rep x + + +instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where + count (M1 a) = M1 a + uncount (M1 a) = M1 a + + +instance + ( Countable n a, Countable n' b + , '(n', a') ~ Count n a + , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b)) + ) + => Countable n (a :*: b) + where + count (a :*: b) = count @n a :*: count @n' b + uncount (a :*: b) = uncount @n a :*: uncount @n' b + + +instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where + count = id + uncount = id + + +newtype Record a = Record + { unrecord :: a + } + + +instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where + type Rep (Record a) = GRecord (Rep a) + + from (Record a) = grecord (from a) + to = Record . to . gunrecord diff --git a/src/Rel8/Generic/Reify.hs b/src/Rel8/Generic/Reify.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Reify.hs @@ -0,0 +1,24 @@ +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Generic.Reify + ( ARep + ) +where + +-- base +import Data.Functor.Contravariant ( Contravariant, contramap ) +import Data.Kind ( Type ) +import Data.Void ( Void, absurd ) +import GHC.Generics ( Generic, Rep, from, to ) +import Prelude + + +type ARep :: (Type -> Type) -> Type +newtype ARep rep = ARep (rep Void) + + +instance (Contravariant rep, Functor rep) => Generic (ARep rep) where + type Rep (ARep rep) = rep + from (ARep a) = fmap absurd a + to = ARep . contramap absurd diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Rel8able.hs @@ -0,0 +1,175 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Rel8able + ( KRel8able, Rel8able + , Algebra + , GRep + , GColumns, gfromColumns, gtoColumns + , greify, gunreify + , TUnreifyContext + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import GHC.Generics ( Generic, Rep, from, to ) +import Prelude + +-- rel8 +import Rel8.Kind.Context ( Reifiable ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap ) +import Rel8.Generic.Record ( Record(..) ) +import Rel8.Generic.Table ( GAlgebra ) +import qualified Rel8.Generic.Table.Record as G +import qualified Rel8.Kind.Algebra as K ( Algebra(..) ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.Context.Label ( Labelable ) +import Rel8.Schema.HTable ( HTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Reify ( Reify, UnwrapReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( fromColumns, toColumns, reify, unreify + , TTable, TColumns, TContext, TUnreify + ) + + +-- | The kind of 'Rel8able' types +type KRel8able :: Type +type KRel8able = K.Rel8able + + +-- | This type class allows you to define custom 'Table's using higher-kinded +-- data types. Higher-kinded data types are data types of the pattern: +-- +-- @ +-- data MyType f = +-- MyType { field1 :: Column f T1 OR HK1 f +-- , field2 :: Column f T2 OR HK2 f +-- , ... +-- , fieldN :: Column f Tn OR HKn f +-- } +-- @ +-- +-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type. +-- +-- That is, higher-kinded data are records where all fields in the record are +-- all either of the type @Column f T@ (for any @T@), or are themselves +-- higher-kinded data: +-- +-- [Nested] +-- +-- @ +-- data Nested f = +-- Nested { nested1 :: MyType f +-- , nested2 :: MyType f +-- } +-- @ +-- +-- The @Rel8able@ type class is used to give us a special mapping operation +-- that lets us change the type parameter @f@. +-- +-- [Supplying @Rel8able@ instances] +-- +-- This type class should be derived generically for all table types in your +-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language +-- extensions: +-- +-- @ +-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\} +-- +-- data MyType f = MyType { fieldA :: Column f T } +-- deriving ( GHC.Generics.Generic, Rel8able ) +-- @ +type Rel8able :: K.Rel8able -> Constraint +class HTable (GColumns t) => Rel8able t where + type GColumns t :: K.HTable + + gfromColumns :: (Labelable context, Reifiable context) + => GColumns t (Col (Reify context)) -> t (Reify context) + + gtoColumns :: (Labelable context, Reifiable context) + => t (Reify context) -> GColumns t (Col (Reify context)) + + greify :: (Labelable context, Reifiable context) + => t context -> t (Reify context) + + gunreify :: (Labelable context, Reifiable context) + => t (Reify context) -> t context + + type GColumns t = G.GColumns TColumns (GRep t (Reify Result)) + + default gfromColumns :: forall context. + ( Generic (Record (t (Reify context))) + , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context)) + , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t + ) + => GColumns t (Col (Reify context)) -> t (Reify context) + gfromColumns = + unrecord . + to . + G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns + + default gtoColumns :: forall context. + ( Generic (Record (t (Reify context))) + , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context)) + , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t + ) + => t (Reify context) -> GColumns t (Col (Reify context)) + gtoColumns = + G.gtoColumns @(TTable (Reify context)) @TColumns toColumns . + from . + Record + + default greify :: forall context. + ( Generic (Record (t context)) + , Generic (Record (t (Reify context))) + , GMappable (TTable (Reify context)) (GRep t (Reify context)) + , GRep t context ~ GMap TUnreify (GRep t (Reify context)) + ) + => t context -> t (Reify context) + greify = + unrecord . + to . + gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) . + from . + Record + + default gunreify :: forall context. + ( Generic (Record (t context)) + , Generic (Record (t (Reify context))) + , GMappable (TTable (Reify context)) (GRep t (Reify context)) + , GRep t context ~ GMap TUnreify (GRep t (Reify context)) + ) + => t (Reify context) -> t context + gunreify = + unrecord . + to . + gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) . + from . + Record + + +type Algebra :: K.Rel8able -> K.Algebra +type Algebra t = GAlgebra (GRep t (Reify Result)) + + +type GRep :: K.Rel8able -> K.Context -> Type -> Type +type GRep t context = Rep (Record (t context)) + + +data TUnreifyContext :: Type -> Exp K.Context +type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a)) diff --git a/src/Rel8/Generic/Rel8able/Test.hs b/src/Rel8/Generic/Rel8able/Test.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Rel8able/Test.hs @@ -0,0 +1,157 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneDeriving #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +{-# options_ghc -O0 #-} + +module Rel8.Generic.Rel8able.Test + ( module Rel8.Generic.Rel8able.Test + ) +where + +-- base +import GHC.Generics ( Generic ) +import Prelude + +-- rel8 +import Rel8 + +-- text +import Data.Text ( Text ) + + +data TableTest f = TableTest + { foo :: Column f Bool + , bar :: Column f (Maybe Bool) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TablePair f = TablePair + { foo :: Column f Bool + , bars :: (Column f Text, Column f Text) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableMaybe f = TableMaybe + { foo :: Column f [Maybe Bool] + , bars :: HMaybe f (TablePair f, TablePair f) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableEither f = TableEither + { foo :: Column f Bool + , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableThese f = TableThese + { foo :: Column f Bool + , bars :: HThese f (TableMaybe f) (TableEither f) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableList f = TableList + { foo :: Column f Bool + , bars :: HList f (TableThese f) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableNonEmpty f = TableNonEmpty + { foo :: Column f Bool + , bars :: HNonEmpty f (TableList f, TableMaybe f) + } + deriving stock Generic + deriving anyclass Rel8able + + +data TableNest f = TableNest + { foo :: Column f Bool + , bars :: HList f (HMaybe f (TablePair f)) + } + deriving stock Generic + deriving anyclass Rel8able + + +data S3Object = S3Object + { bucketName :: Text + , objectKey :: Text + } + deriving stock Generic + + +deriving via HKDT S3Object + instance Table Result S3Object + + +deriving via HKDT S3Object + instance x ~ HKD S3Object Expr => ToExprs x S3Object + + +data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC + deriving stock Generic + + +deriving via HKDT HKDSum + instance Table Result HKDSum + + +deriving via HKDT HKDSum + instance x ~ HKD HKDSum Expr => ToExprs x HKDSum + + +data HKDTest f = HKDTest + { s3Object :: Lift f S3Object + , hkdSum :: Lift f HKDSum + } + deriving stock Generic + deriving anyclass Rel8able + + +data NonRecord f = NonRecord + (Column f Bool) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + deriving stock Generic + deriving anyclass Rel8able + + +data TableSum f + = TableSumA (Column f Bool) (Column f Text) + | TableSumB + | TableSumC (Column f Text) + deriving stock Generic + + +data TableProduct f = TableProduct + { sum :: HADT f TableSum + , list :: TableList f + , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f) + } + deriving stock Generic + deriving anyclass Rel8able diff --git a/src/Rel8/Generic/Table.hs b/src/Rel8/Generic/Table.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Table.hs @@ -0,0 +1,188 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Table + ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable + , GGToExprs, ggfromResult, ggtoResult + , GAlgebra + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 ) +import Prelude () + +-- rel8 +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Table.ADT + ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT + , GToExprsADT, gtoResultADT, gfromResultADT + ) +import Rel8.Generic.Table.Record + ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable + , GToExprs, gtoResult, gfromResult + ) +import Rel8.Kind.Algebra + ( Algebra( Product, Sum ) + , SAlgebra( SProduct, SSum ) + , KnownAlgebra, algebraSing + ) +import Rel8.Schema.Context ( Col ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null ( Nullify ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec ) +import Rel8.Schema.Result ( Result ) + + +data GGTable + :: Algebra + -> (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> K.HContext + -> (Type -> Type) + -> Exp Constraint + + +type instance Eval (GGTable 'Product _Table _Columns context rep) = + GTable _Table _Columns context rep + + +type instance Eval (GGTable 'Sum _Table _Columns context rep) = + GTableADT _Table _Columns context rep + + +data GGToExprs + :: Algebra + -> (Type -> Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Type) + -> (Type -> Type) + -> Exp Constraint + + +type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) = + GToExprs _ToExprs _Columns exprs rep + + +type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) = + GToExprsADT _ToExprs _Columns exprs rep + + +data GGColumns + :: Algebra + -> (Type -> Exp K.HTable) + -> (Type -> Type) + -> Exp K.HTable + + +type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep + + +type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep + + +data GGContext + :: Algebra + -> (Type -> Exp K.Context) + -> (Type -> Type) + -> Exp K.Context + + +type instance Eval (GGContext 'Product _Context rep) = GContext _Context rep + + +type instance Eval (GGContext 'Sum _Context _rep) = Result + + +type GAlgebra :: (Type -> Type) -> Algebra +type family GAlgebra rep where + GAlgebra (M1 _ _ rep) = GAlgebra rep + GAlgebra V1 = 'Sum + GAlgebra (_ :+: _) = 'Sum + GAlgebra U1 = 'Sum + GAlgebra (_ :*: _) = 'Product + GAlgebra (K1 _ _) = 'Product + + +ggfromColumns :: forall algebra _Table _Columns rep context x. + ( KnownAlgebra algebra + , Eval (GGTable algebra _Table _Columns context rep) + ) + => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec) + -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec) + -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a) + -> Eval (GGColumns algebra _Columns rep) context + -> rep x +ggfromColumns = case algebraSing @algebra of + SProduct -> \_ _ -> gfromColumns @_Table @_Columns + SSum -> gfromColumnsADT @_Table @_Columns + + +ggtoColumns :: forall algebra _Table _Columns rep context x. + ( KnownAlgebra algebra + , Eval (GGTable algebra _Table _Columns context rep) + ) + => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec) + -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec) + -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context) + -> rep x + -> Eval (GGColumns algebra _Columns rep) context +ggtoColumns = case algebraSing @algebra of + SProduct -> \_ _ -> gtoColumns @_Table @_Columns + SSum -> gtoColumnsADT @_Table @_Columns + + +ggtable :: forall algebra _Table _Columns rep context. + ( KnownAlgebra algebra + , Eval (GGTable algebra _Table _Columns context rep) + ) + => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) + -> (forall a labels. () + => SSpec ('Spec labels a) + -> context ('Spec labels a) + -> context ('Spec labels (Nullify a))) + -> Eval (GGColumns algebra _Columns rep) context +ggtable = case algebraSing @algebra of + SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table + SSum -> gtableADT @_Table @_Columns @_ @rep + + +ggfromResult :: forall algebra _ToExprs _Columns exprs rep x. + ( KnownAlgebra algebra + , Eval (GGToExprs algebra _ToExprs _Columns exprs rep) + ) + => (forall expr a proxy. Eval (_ToExprs expr a) + => proxy expr + -> Eval (_Columns expr) (Col Result) + -> a) + -> Eval (GGColumns algebra _Columns exprs) (Col Result) + -> rep x +ggfromResult = case algebraSing @algebra of + SProduct -> gfromResult @_ToExprs @_Columns @exprs + SSum -> gfromResultADT @_ToExprs @_Columns @exprs + + +ggtoResult :: forall algebra _ToExprs _Columns exprs rep x. + ( KnownAlgebra algebra + , Eval (GGToExprs algebra _ToExprs _Columns exprs rep) + ) + => (forall expr a proxy. Eval (_ToExprs expr a) + => proxy expr + -> a + -> Eval (_Columns expr) (Col Result)) + -> rep x + -> Eval (GGColumns algebra _Columns exprs) (Col Result) +ggtoResult = case algebraSing @algebra of + SProduct -> gtoResult @_ToExprs @_Columns @exprs + SSum -> gtoResultADT @_ToExprs @_Columns @exprs diff --git a/src/Rel8/Generic/Table/ADT.hs b/src/Rel8/Generic/Table/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Table/ADT.hs @@ -0,0 +1,363 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Table.ADT + ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT + , GTableADT', GColumnsADT' + , GToExprsADT, gfromResultADT, gtoResultADT + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.Generics + ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 ) + , C, D + , Meta( MetaCons ) + ) +import GHC.TypeLits ( KnownSymbol, symbolVal ) +import Prelude hiding ( null ) + +-- rel8 +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Table.Record + ( GTable, GColumns, gtable + , GToExprs, gfromResult, gtoResult + ) +import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler ) +import Rel8.Schema.HTable ( HTable, hmap ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType ) +import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) +import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null ( Nullify ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec ) +import Rel8.Schema.Result + ( Col( R ), Result + , null, nullifier, unnullifier + ) +import Rel8.Type.Tag ( Tag( Tag ) ) + +-- text +import Data.Text ( pack ) + + +type GColumnsADT + :: (Type -> Exp K.HTable) + -> (Type -> Type) -> K.HTable +type family GColumnsADT _Columns rep where + GColumnsADT _Columns (M1 D _ rep) = + GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep + + +type GColumnsADT' + :: (Type -> Exp K.HTable) + -> K.HTable -> (Type -> Type) -> K.HTable +type family GColumnsADT' _Columns htable rep where + GColumnsADT' _Columns htable (a :+: b) = + GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b + GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable + GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) = + HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + + +type GTableADT + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> K.HContext -> (Type -> Type) -> Constraint +class GTableADT _Table _Columns context rep where + gfromColumnsADT :: () + => (forall spec. context spec -> Col Result spec) + -> (forall spec. Col Result spec -> context spec) + -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a) + -> GColumnsADT _Columns rep context + -> rep x + + gtoColumnsADT :: () + => (forall spec. context spec -> Col Result spec) + -> (forall spec. Col Result spec -> context spec) + -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context) + -> rep x + -> GColumnsADT _Columns rep context + + gtableADT :: () + => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) + -> (forall a labels. () + => SSpec ('Spec labels a) + -> context ('Spec labels a) + -> context ('Spec labels (Nullify a))) + -> GColumnsADT _Columns rep context + + +instance + ( htable ~ HLabel "tag" (HType Tag) + , HTable (GColumnsADT _Columns (M1 D meta rep)) + , Eval (_Table (htable context)) + , Eval (_Columns (htable context)) ~ htable + , GTableADT' _Table _Columns htable context rep + , GToExprsADT' (Const _Table) _Columns htable rep rep + ) + => GTableADT _Table _Columns context (M1 D meta rep) + where + gfromColumnsADT fromContext toContext fromColumns = + gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep) + (const (fromColumns . hmap toContext)) . + hmap fromContext + + gtoColumnsADT fromContext toContext toColumns = + hmap toContext . + gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep) + (const (hmap fromContext . toColumns)) + + gtableADT table hnullifier = + gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable + where + htable = table (Proxy @(htable context)) + + +type GTableADT' + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint +class GTableADT' _Table _Columns htable context rep where + gtableADT' :: () + => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) + -> (forall a labels. () + => SSpec ('Spec labels a) + -> context ('Spec labels a) + -> context ('Spec labels (Nullify a))) + -> htable context + -> GColumnsADT' _Columns htable rep context + + +instance + ( htable' ~ GColumnsADT' _Columns htable a + , GTableADT' _Table _Columns htable context a + , GTableADT' _Table _Columns htable' context b + ) + => GTableADT' _Table _Columns htable context (a :+: b) + where + gtableADT' table hnullifier = + gtableADT' @_Table @_Columns @_ @_ @b table hnullifier . + gtableADT' @_Table @_Columns @_ @_ @a table hnullifier + + +instance meta ~ 'MetaCons label _fixity _isRecord => + GTableADT' _Table _Columns htable context (M1 C meta U1) + where + gtableADT' _ _ = id + + +instance {-# OVERLAPPABLE #-} + ( HTable (GColumns _Columns rep) + , GTable _Table _Columns context rep + , HLabelable context + , meta ~ 'MetaCons label _fixity _isRecord + , KnownSymbol label + , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~ + HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + ) + => GTableADT' _Table _Columns htable context (M1 C meta rep) + where + gtableADT' table hnullifier htable = + HProduct htable $ + hlabel hlabeler $ + hnullify hnullifier $ + gtable @_Table @_Columns @_ @rep table + + +type GToExprsADT + :: (Type -> Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Type) -> (Type -> Type) -> Constraint +class GToExprsADT _ToExprs _Columns exprs rep where + gfromResultADT :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> Eval (_Columns expr) (Col Result) + -> a) + -> GColumnsADT _Columns exprs (Col Result) + -> rep x + + gtoResultADT :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> a + -> Eval (_Columns expr) (Col Result)) + -> rep x + -> GColumnsADT _Columns exprs (Col Result) + + +instance + ( htable ~ HLabel "tag" (HType Tag) + , GToExprsADT' _ToExprs _Columns htable exprs rep + ) + => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep) + where + gfromResultADT fromResult columns = + case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of + Just rep -> M1 rep + _ -> error "ADT.fromColumns: mismatch between tag and data" + where + tag = (\(HType (R a)) -> a) . hunlabel @_ @"tag" unlabeler + + gtoResultADT toResult (M1 rep) = + gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep) + where + tag = hlabel @_ @"tag" labeler . HType . R + + +type GToExprsADT' + :: (Type -> Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint +class GToExprsADT' _ToExprs _Columns htable exprs rep where + gfromResultADT' :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> Eval (_Columns expr) (Col Result) + -> a) + -> (htable (Col Result) -> Tag) + -> GColumnsADT' _Columns htable exprs (Col Result) + -> Maybe (rep x) + + gtoResultADT' :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> a + -> Eval (_Columns expr) (Col Result)) + -> (Tag -> htable (Col Result)) + -> Maybe (rep x) + -> GColumnsADT' _Columns htable exprs (Col Result) + + extract :: GColumnsADT' _Columns htable exprs context -> htable context + + +instance + ( htable' ~ GColumnsADT' _Columns htable a + , GToExprsADT' _ToExprs _Columns htable a rep1 + , GToExprsADT' _ToExprs _Columns htable' b rep2 + ) + => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2) + where + gfromResultADT' fromResult f columns = + case ma of + Just a -> Just (L1 a) + Nothing -> R1 <$> + gfromResultADT' @_ToExprs @_Columns @_ @b @rep2 + fromResult + (f . extract @_ToExprs @_Columns @_ @a @rep1) + columns + where + ma = + gfromResultADT' @_ToExprs @_Columns @_ @a @rep1 + fromResult + f + (extract @_ToExprs @_Columns @_ @b @rep2 columns) + + gtoResultADT' toResult tag = \case + Just (L1 a) -> + gtoResultADT' @_ToExprs @_Columns @_ @b @rep2 + toResult + (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 + toResult + tag + (Just a)) + Nothing + Just (R1 b) -> + gtoResultADT' @_ToExprs @_Columns @_ @b @rep2 + toResult + (\tag' -> + gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 + toResult + (\_ -> tag tag') + Nothing) + (Just b) + Nothing -> + gtoResultADT' @_ToExprs @_Columns @_ @b @rep2 + toResult + (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing) + Nothing + + extract = + extract @_ToExprs @_Columns @_ @a @rep1 . + extract @_ToExprs @_Columns @_ @b @rep2 + + +instance + ( meta ~ 'MetaCons label _fixity _isRecord + , KnownSymbol label + ) + => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1) + where + gfromResultADT' _ tag columns + | tag columns == tag' = Just (M1 U1) + | otherwise = Nothing + where + tag' = Tag $ pack $ symbolVal (Proxy @label) + + gtoResultADT' _ tag _ = tag tag' + where + tag' = Tag $ pack $ symbolVal (Proxy @label) + + extract = id + + +instance {-# OVERLAPPABLE #-} + ( HTable (GColumns _Columns exprs) + , GToExprs _ToExprs _Columns exprs rep + , meta ~ 'MetaCons label _fixity _isRecord + , KnownSymbol label + , GColumnsADT' _Columns htable (M1 C meta exprs) ~ + HProduct htable (HLabel label (HNullify (GColumns _Columns exprs))) + ) + => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep) + where + gfromResultADT' fromResult tag (HProduct a b) + | tag a == tag' = + M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$> + hunnullify unnullifier (hunlabel unlabeler b) + | otherwise = Nothing + where + tag' = Tag $ pack $ symbolVal (Proxy @label) + + gtoResultADT' toResult tag = \case + Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null))) + Just (M1 rep) -> HProduct (tag tag') $ + hlabel labeler $ + hnullify nullifier $ + gtoResult @_ToExprs @_Columns @exprs toResult rep + where + tag' = Tag $ pack $ symbolVal (Proxy @label) + + extract (HProduct a _) = a + + +data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint +type instance Eval (Const f x a) = (Eval (f a), x ~ a) diff --git a/src/Rel8/Generic/Table/Record.hs b/src/Rel8/Generic/Table/Record.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Generic/Table/Record.hs @@ -0,0 +1,206 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Generic.Table.Record + ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable + , GToExprs, gfromResult, gtoResult + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.Generics + ( (:*:)( (:*:) ), K1( K1 ), M1( M1 ) + , C, D, S + , Meta( MetaSel ) + ) +import GHC.TypeLits ( KnownSymbol ) +import Prelude hiding ( null ) + +-- rel8 +import Rel8.FCF ( Eval, Exp ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable.Product ( HProduct(..) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Result ( Result ) + + +type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable +type family GColumns _Columns rep where + GColumns _Columns (M1 D _ rep) = GColumns _Columns rep + GColumns _Columns (M1 C _ rep) = GColumns _Columns rep + GColumns _Columns (rep1 :*: rep2) = + HProduct (GColumns _Columns rep1) (GColumns _Columns rep2) + GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) = + HLabel label (Eval (_Columns a)) + + +type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context +type family GContext _Context rep where + GContext _Context (M1 _ _ rep) = GContext _Context rep + GContext _Context (rep1 :*: _rep2) = GContext _Context rep1 + GContext _Context (K1 _ a) = Eval (_Context a) + + +type GTable + :: (Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> K.HContext -> (Type -> Type) -> Constraint +class GTable _Table _Columns context rep + where + gfromColumns :: () + => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a) + -> GColumns _Columns rep context + -> rep x + + gtoColumns :: () + => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context) + -> rep x + -> GColumns _Columns rep context + + gtable :: () + => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) + -> GColumns _Columns rep context + + +instance GTable _Table _Columns context rep => + GTable _Table _Columns context (M1 D c rep) + where + gfromColumns fromColumns = + M1 . gfromColumns @_Table @_Columns @context @rep fromColumns + gtoColumns toColumns (M1 a) = + gtoColumns @_Table @_Columns @context @rep toColumns a + gtable = gtable @_Table @_Columns @context @rep + + +instance GTable _Table _Columns context rep => + GTable _Table _Columns context (M1 C c rep) + where + gfromColumns fromColumns = + M1 . gfromColumns @_Table @_Columns @context @rep fromColumns + gtoColumns toColumns (M1 a) = + gtoColumns @_Table @_Columns @context @rep toColumns a + gtable = gtable @_Table @_Columns @context @rep + + +instance + ( GTable _Table _Columns context rep1 + , GTable _Table _Columns context rep2 + ) + => GTable _Table _Columns context (rep1 :*: rep2) + where + gfromColumns fromColumns (HProduct a b) = + gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*: + gfromColumns @_Table @_Columns @context @rep2 fromColumns b + gtoColumns toColumns (a :*: b) = HProduct + (gtoColumns @_Table @_Columns @context @rep1 toColumns a) + (gtoColumns @_Table @_Columns @context @rep2 toColumns b) + gtable table = HProduct + (gtable @_Table @_Columns @context @rep1 table) + (gtable @_Table @_Columns @context @rep2 table) + + +instance + ( HTable (Eval (_Columns a)) + , Eval (_Table a) + , HLabelable context + , KnownSymbol label + , meta ~ 'MetaSel ('Just label) _su _ss _ds + , k1 ~ K1 i a + ) + => GTable _Table _Columns context (M1 S meta k1) + where + gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler + gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a) + gtable table = hlabel hlabeler (table (Proxy @a)) + + +type GToExprs + :: (Type -> Type -> Exp Constraint) + -> (Type -> Exp K.HTable) + -> (Type -> Type) -> (Type -> Type) -> Constraint +class GToExprs _ToExprs _Columns exprs rep where + gfromResult :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> Eval (_Columns expr) (Col Result) + -> a) + -> GColumns _Columns exprs (Col Result) + -> rep x + gtoResult :: () + => (forall expr a proxy. + ( Eval (_ToExprs expr a) + , HTable (Eval (_Columns expr)) + ) + => proxy expr + -> a + -> Eval (_Columns expr) (Col Result)) + -> rep x + -> GColumns _Columns exprs (Col Result) + + +instance GToExprs _ToExprs _Columns exprs rep => + GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep) + where + gfromResult fromResult = + M1 . gfromResult @_ToExprs @_Columns @exprs fromResult + gtoResult toResult (M1 a) = + gtoResult @_ToExprs @_Columns @exprs toResult a + + +instance GToExprs _ToExprs _Columns exprs rep => + GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep) + where + gfromResult fromResult = + M1 . gfromResult @_ToExprs @_Columns @exprs fromResult + gtoResult toResult (M1 a) = + gtoResult @_ToExprs @_Columns @exprs toResult a + + +instance + ( GToExprs _ToExprs _Columns exprs1 rep1 + , GToExprs _ToExprs _Columns exprs2 rep2 + ) + => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2) + where + gfromResult fromResult (HProduct a b) = + gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*: + gfromResult @_ToExprs @_Columns @exprs2 fromResult b + gtoResult toResult (a :*: b) = + HProduct + (gtoResult @_ToExprs @_Columns @exprs1 toResult a) + (gtoResult @_ToExprs @_Columns @exprs2 toResult b) + + +instance + ( Eval (_ToExprs exprs a) + , HTable (Eval (_Columns exprs)) + , KnownSymbol label + , meta ~ 'MetaSel ('Just label) _su _ss _ds + , k1 ~ K1 i exprs + , k1' ~ K1 i a + ) + => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1') + where + gfromResult fromResult = + M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler + gtoResult toResult (M1 (K1 a)) = + hlabel hlabeler (toResult (Proxy @exprs) a) diff --git a/src/Rel8/Kind/Algebra.hs b/src/Rel8/Kind/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Kind/Algebra.hs @@ -0,0 +1,38 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Kind.Algebra + ( Algebra( Product, Sum ) + , SAlgebra( SProduct, SSum ) + , KnownAlgebra( algebraSing ) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + + +type Algebra :: Type +data Algebra = Product | Sum + + +type SAlgebra :: Algebra -> Type +data SAlgebra algebra where + SProduct :: SAlgebra 'Product + SSum :: SAlgebra 'Sum + + +type KnownAlgebra :: Algebra -> Constraint +class KnownAlgebra algebra where + algebraSing :: SAlgebra algebra + + +instance KnownAlgebra 'Product where + algebraSing = SProduct + + +instance KnownAlgebra 'Sum where + algebraSing = SSum diff --git a/src/Rel8/Kind/Context.hs b/src/Rel8/Kind/Context.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Kind/Context.hs @@ -0,0 +1,81 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Kind.Context + ( Reifiable( contextSing ) + , SContext(..) + , sReifiable + , sLabelable + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Context ( Interpretation ) +import Rel8.Schema.Context.Label ( Labelable ) +import Rel8.Schema.Kind ( Context ) +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify ) +import Rel8.Schema.Result ( Result ) + + +type SContext :: Context -> Type +data SContext context where + SAggregate :: SContext Aggregate + SExpr :: SContext Expr + SName :: SContext Name + SResult :: SContext Result + SReify :: SContext context -> SContext (Reify context) + + +type Reifiable :: Context -> Constraint +class Interpretation context => Reifiable context where + contextSing :: SContext context + + +instance Reifiable Aggregate where + contextSing = SAggregate + + +instance Reifiable Expr where + contextSing = SExpr + + +instance Reifiable Result where + contextSing = SResult + + +instance Reifiable Name where + contextSing = SName + + +instance Reifiable context => Reifiable (Reify context) where + contextSing = SReify contextSing + + +sReifiable :: SContext context -> Dict Reifiable context +sReifiable = \case + SAggregate -> Dict + SExpr -> Dict + SName -> Dict + SResult -> Dict + SReify context -> case sReifiable context of + Dict -> Dict + + +sLabelable :: SContext context -> Dict Labelable context +sLabelable = \case + SAggregate -> Dict + SExpr -> Dict + SName -> Dict + SResult -> Dict + SReify context -> case sLabelable context of + Dict -> Dict diff --git a/src/Rel8/Kind/Labels.hs b/src/Rel8/Kind/Labels.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Kind/Labels.hs @@ -0,0 +1,57 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeOperators #-} + +module Rel8.Kind.Labels + ( Labels + , SLabels( SNil, SCons ) + , KnownLabels( labelsSing ) + , renderLabels + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty, nonEmpty ) +import Data.Maybe ( fromMaybe ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) +import Prelude + + +type Labels :: Type +type Labels = [Symbol] + + +type SLabels :: Labels -> Type +data SLabels labels where + SNil :: SLabels '[] + SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels) + + +type KnownLabels :: Labels -> Constraint +class KnownLabels labels where + labelsSing :: SLabels labels + + +instance KnownLabels '[] where + labelsSing = SNil + + +instance (KnownSymbol label, KnownLabels labels) => + KnownLabels (label ': labels) + where + labelsSing = SCons Proxy labelsSing + + +renderLabels :: SLabels labels -> NonEmpty String +renderLabels = fromMaybe (pure "anon") . nonEmpty . go + where + go :: SLabels labels -> [String] + go = \case + SNil -> [] + SCons label labels -> symbolVal label : go labels diff --git a/src/Rel8/Order.hs b/src/Rel8/Order.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Order.hs @@ -0,0 +1,37 @@ +{-# language DerivingStrategies #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Order + ( Order(..) + , toOrderExprs + ) +where + +-- base +import Data.Functor.Contravariant ( Contravariant ) +import Data.Kind ( Type ) +import Prelude + +-- contravariant +import Data.Functor.Contravariant.Divisible ( Decidable, Divisible ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.Order as Opaleye + + +-- | An ordering expression for @a@. Primitive orderings are defined with +-- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various +-- instances. +-- +-- A common pattern is to use '<>' to combine multiple orderings in sequence, +-- and '>$<' (from 'Contravariant') to select individual columns. +type Order :: Type -> Type +newtype Order a = Order (Opaleye.Order a) + deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid) + + +toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr] +toOrderExprs (Order (Opaleye.Order order)) a = + uncurry Opaleye.OrderExpr <$> order a diff --git a/src/Rel8/Query.hs b/src/Rel8/Query.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query.hs @@ -0,0 +1,49 @@ +{-# language DerivingVia #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Query + ( Query( Query ) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- opaleye +import qualified Opaleye.Select as Opaleye + +-- rel8 +import Rel8.Query.Set ( unionAll ) +import Rel8.Query.Values ( values ) +import Rel8.Table.Alternative + ( AltTable, (<|>:) + , AlternativeTable, emptyTable + ) + +-- semigroupoids +import Data.Functor.Apply ( Apply, WrappedApplicative(..) ) +import Data.Functor.Bind ( Bind, (>>-) ) + + +-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has +-- semantics similar to the list (@[]@) monad. +type Query :: Type -> Type +newtype Query a = Query (Opaleye.Select a) + deriving newtype (Functor, Applicative, Monad) + deriving Apply via (WrappedApplicative Opaleye.Select) + + +instance Bind Query where + (>>-) = (>>=) + + +-- | '<|>:' = 'unionAll'. +instance AltTable Query where + (<|>:) = unionAll + + +-- | 'emptyTable' = 'values' @[]@. +instance AlternativeTable Query where + emptyTable = values [] diff --git a/src/Rel8/Query.hs-boot b/src/Rel8/Query.hs-boot new file mode 100644 --- /dev/null +++ b/src/Rel8/Query.hs-boot @@ -0,0 +1,17 @@ +{-# language StandaloneKindSignatures #-} + +module Rel8.Query + ( Query( Query ) + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude () + +-- opaleye +import qualified Opaleye.Select as Opaleye + + +type Query :: Type -> Type +newtype Query a = Query (Opaleye.Select a) diff --git a/src/Rel8/Query/Aggregate.hs b/src/Rel8/Query/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Aggregate.hs @@ -0,0 +1,37 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + +module Rel8.Query.Aggregate + ( aggregate + , countRows + ) +where + +-- base +import Data.Int ( Int64 ) +import Prelude + +-- opaleye +import qualified Opaleye.Aggregate as Opaleye + +-- rel8 +import Rel8.Aggregate ( Aggregates ) +import Rel8.Expr ( Expr ) +import Rel8.Expr.Aggregate ( countStar ) +import Rel8.Query ( Query ) +import Rel8.Query.Maybe ( optional ) +import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Table.Opaleye ( aggregator ) +import Rel8.Table.Maybe ( maybeTable ) + + +-- | Apply an aggregation to all rows returned by a 'Query'. +aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs +aggregate = mapOpaleye (Opaleye.aggregate aggregator) + + +-- | Count the number of rows returned by a query. Note that this is different +-- from @countStar@, as even if the given query yields no rows, @countRows@ +-- will return @0@. +countRows :: Query a -> Query (Expr Int64) +countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar) diff --git a/src/Rel8/Query/Distinct.hs b/src/Rel8/Query/Distinct.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Distinct.hs @@ -0,0 +1,45 @@ +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Rel8.Query.Distinct + ( distinct + , distinctOn + , distinctOnBy + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Distinct as Opaleye +import qualified Opaleye.Internal.Order as Opaleye +import qualified Opaleye.Internal.QueryArr as Opaleye + +-- rel8 +import Rel8.Order ( Order( Order ) ) +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Table.Eq ( EqTable ) +import Rel8.Table.Opaleye ( distinctspec, unpackspec ) + + +-- | Select all distinct rows from a query, removing duplicates. @distinct q@ +-- is equivalent to the SQL statement @SELECT DISTINCT q@. +distinct :: EqTable a => Query a -> Query a +distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec) + + +-- | Select all distinct rows from a query, where rows are equivalent according +-- to a projection. If multiple rows have the same projection, it is +-- unspecified which row will be returned. If this matters, use 'distinctOnBy'. +distinctOn :: EqTable b => (a -> b) -> Query a -> Query a +distinctOn proj = + mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q)) + + +-- | Select all distinct rows from a query, where rows are equivalent according +-- to a projection. If there are multiple rows with the same projection, the +-- first row according to the specified 'Order' will be returned. +distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a +distinctOnBy proj (Order order) = + mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q)) diff --git a/src/Rel8/Query/Each.hs b/src/Rel8/Query/Each.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Each.hs @@ -0,0 +1,32 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + +module Rel8.Query.Each + ( each + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Table as Opaleye + +-- rel8 +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( fromOpaleye ) +import Rel8.Schema.Name ( Selects ) +import Rel8.Schema.Table ( TableSchema ) +import Rel8.Table ( fromColumns, toColumns ) +import Rel8.Table.Opaleye ( table, unpackspec ) + + +-- | Select each row from a table definition. This is equivalent to @FROM +-- table@. +each :: Selects names exprs => TableSchema names -> Query exprs +each = + fmap fromColumns . + fromOpaleye . + Opaleye.selectTableExplicit unpackspec . + table . + fmap toColumns diff --git a/src/Rel8/Query/Either.hs b/src/Rel8/Query/Either.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Either.hs @@ -0,0 +1,65 @@ +{-# language FlexibleContexts #-} + +module Rel8.Query.Either + ( keepLeftTable + , keepRightTable + , bitraverseEitherTable + ) +where + +-- base +import Prelude + +-- rel8 +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Query ( Query ) +import Rel8.Query.Filter ( where_ ) +import Rel8.Query.Maybe ( optional ) +import Rel8.Table.Either + ( EitherTable( EitherTable ) + , isLeftTable, isRightTable + ) +import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable ) + + +-- | Filter 'EitherTable's, keeping only 'leftTable's. +keepLeftTable :: EitherTable a b -> Query a +keepLeftTable e@(EitherTable _ a _) = do + where_ $ isLeftTable e + pure a + + +-- | Filter 'EitherTable's, keeping only 'rightTable's. +keepRightTable :: EitherTable a b -> Query b +keepRightTable e@(EitherTable _ _ b) = do + where_ $ isRightTable e + pure b + + +-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and +-- all @rightTable@s through @g@. The results are then lifted back into +-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse' +-- for 'Either'. +-- +-- For example, +-- +-- >>> :{ +-- select do +-- x <- values (map lit [ Left True, Right (42 :: Int32) ]) +-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x +-- :} +-- [ Left True +-- , Left False +-- , Right 4200 +-- ] +bitraverseEitherTable :: () + => (a -> Query c) + -> (b -> Query d) + -> EitherTable a b + -> Query (EitherTable c d) +bitraverseEitherTable f g e@(EitherTable tag _ _) = do + mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e) + md@(MaybeTable _ d) <- optional (g =<< keepRightTable e) + where_ $ isJustTable mc ==. isLeftTable e + where_ $ isJustTable md ==. isRightTable e + pure $ EitherTable tag c d diff --git a/src/Rel8/Query/Evaluate.hs b/src/Rel8/Query/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Evaluate.hs @@ -0,0 +1,82 @@ +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language NamedFieldPuns #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Query.Evaluate + ( Evaluate + , eval + , evaluate + ) +where + +-- base +import Data.Kind ( Type ) +import Data.Monoid ( Endo ( Endo ), appEndo ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.PackMap as Opaleye +import qualified Opaleye.Internal.PrimQuery as Opaleye +import qualified Opaleye.Internal.QueryArr as Opaleye +import qualified Opaleye.Internal.Tag as Opaleye +import qualified Opaleye.Internal.Unpackspec as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Query ( Query( Query ) ) +import Rel8.Table ( Table ) +import Rel8.Table.Opaleye ( unpackspec ) + +-- semigroupoids +import Data.Functor.Apply ( Apply ) +import Data.Functor.Bind ( Bind, (>>-) ) + +-- transformers +import Control.Monad.Trans.State.Strict ( State, get, put, runState ) + + +type Evaluations :: Type +data Evaluations = Evaluations + { tag :: !Opaleye.Tag + , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr)) + } + + +-- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects, +-- breaking the referential transparency we would otherwise enjoy. +-- +-- To try to recover our ability to reason about such expressions, 'Evaluate' +-- allows us to control the evaluation order of side-effects by sequencing +-- them monadically. +type Evaluate :: Type -> Type +newtype Evaluate a = Evaluate (State Evaluations a) + deriving newtype (Functor, Apply, Applicative, Monad) + + +instance Bind Evaluate where + (>>-) = (>>=) + + +-- | 'eval' takes expressions that could potentially have side effects and +-- \"runs\" them in the 'Evaluate' monad. The returned expressions have no +-- side effetcs and can safely be reused. +eval :: Table Expr a => a -> Evaluate a +eval a = Evaluate $ do + Evaluations {tag, bindings} <- get + let + tag' = Opaleye.next tag + (a', bindings') = Opaleye.run $ + Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a + put Evaluations {tag = tag', bindings = bindings <> Endo (bindings' ++)} + pure a' + + +-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad. +evaluate :: Evaluate a -> Query a +evaluate (Evaluate m) = Query $ Opaleye.QueryArr $ \(_, query, tag) -> + case runState m (Evaluations tag mempty) of + (a, Evaluations {tag = tag', bindings}) -> + (a, Opaleye.Rebind True (appEndo bindings mempty) query, tag') diff --git a/src/Rel8/Query/Exists.hs b/src/Rel8/Query/Exists.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Exists.hs @@ -0,0 +1,68 @@ +{-# language DataKinds #-} + +module Rel8.Query.Exists + ( exists, inQuery + , whereExists, with, withBy + , whereNotExists, without, withoutBy + ) +where + +-- base +import Prelude hiding ( filter ) + +-- opaleye +import qualified Opaleye.Operators as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Query ( Query ) +import Rel8.Query.Filter ( filter ) +import Rel8.Query.Maybe ( optional ) +import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Table.Eq ( EqTable, (==:) ) +import Rel8.Table.Maybe ( isJustTable ) + + +-- | Checks if a query returns at least one row. +exists :: Query a -> Query (Expr Bool) +exists = fmap isJustTable . optional . whereExists +-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it +-- into a release of Opaleye + + +inQuery :: EqTable a => a -> Query a -> Query (Expr Bool) +inQuery a = exists . (>>= filter (a ==:)) + + +-- | Produce the empty query if the given query returns no rows. @whereExists@ +-- is equivalent to @WHERE EXISTS@ in SQL. +whereExists :: Query a -> Query () +whereExists = mapOpaleye Opaleye.restrictExists + + +-- | Produce the empty query if the given query returns rows. @whereNotExists@ +-- is equivalent to @WHERE NOT EXISTS@ in SQL. +whereNotExists :: Query a -> Query () +whereNotExists = mapOpaleye Opaleye.restrictNotExists + + +-- | @with@ is similar to 'filter', but allows the predicate to be a full query. +-- +-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'. +with :: (a -> Query b) -> a -> Query a +with f a = a <$ whereExists (f a) + + +-- | Like @with@, but with a custom membership test. +withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a +withBy predicate bs = with $ \a -> bs >>= filter (predicate a) + + +-- | Filter rows where @a -> Query b@ yields no rows. +without :: (a -> Query b) -> a -> Query a +without f a = a <$ whereNotExists (f a) + + +-- | Like @without@, but with a custom membership test. +withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a +withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a) diff --git a/src/Rel8/Query/Filter.hs b/src/Rel8/Query/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Filter.hs @@ -0,0 +1,35 @@ +module Rel8.Query.Filter + ( filter + , where_ + ) +where + +-- base +import Prelude hiding ( filter ) + +-- opaleye +import qualified Opaleye.Operators as Opaleye + +-- profunctors +import Data.Profunctor ( lmap ) + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( fromOpaleye ) + + +-- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will +-- return @x@ unchanged when @f x@ is @True@. This is similar to +-- 'Control.Monad.guard', but as the predicate is separate from the argument, +-- it is easy to use in a pipeline of 'Query' transformations. +filter :: (a -> Expr Bool) -> a -> Query a +filter f a = a <$ where_ (f a) + + +-- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent +-- to the SQL @WHERE expr@. +where_ :: Expr Bool -> Query () +where_ condition = + fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict diff --git a/src/Rel8/Query/Limit.hs b/src/Rel8/Query/Limit.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Limit.hs @@ -0,0 +1,27 @@ +module Rel8.Query.Limit + ( limit + , offset + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye + +-- rel8 +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( mapOpaleye ) + + +-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent +-- to the SQL @LIMIT n@. +limit :: Word -> Query a -> Query a +limit = mapOpaleye . Opaleye.limit . fromIntegral + + +-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent +-- to the SQL @OFFSET n@. +offset :: Word -> Query a -> Query a +offset = mapOpaleye . Opaleye.offset . fromIntegral diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/List.hs @@ -0,0 +1,118 @@ +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} + +module Rel8.Query.List + ( many, some + , manyExpr, someExpr + , catListTable, catNonEmptyTable + , catList, catNonEmpty + ) +where + +-- base +import Data.Functor.Identity ( runIdentity ) +import Data.List.NonEmpty ( NonEmpty ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr ( Col( E, unE ), Expr ) +import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr ) +import Rel8.Expr.Opaleye ( mapPrimExpr ) +import Rel8.Query ( Query ) +import Rel8.Query.Aggregate ( aggregate ) +import Rel8.Query.Maybe ( optional ) +import Rel8.Schema.HTable.Vectorize ( hunvectorize ) +import Rel8.Schema.Null ( Sql, Unnullify ) +import Rel8.Schema.Spec ( SSpec( SSpec, info ) ) +import Rel8.Table ( Table, fromColumns, toColumns ) +import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg ) +import Rel8.Table.List ( ListTable( ListTable ) ) +import Rel8.Table.Maybe ( maybeTable ) +import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Array ( extractArrayElement ) +import Rel8.Type.Information ( TypeInformation ) + + +-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0 +-- rows, this function will produce a 'Query' that returns one row containing +-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will +-- return exactly one row, with a @ListTable@ collecting all returned rows. +-- +-- @many@ is analogous to 'Control.Applicative.many' from +-- @Control.Applicative@. +many :: Table Expr a => Query a -> Query (ListTable a) +many = + fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) . + optional . + aggregate . + fmap (listAgg . toColumns) + + +-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns +-- 0 rows, this function will produce a 'Query' that is empty - that is, will +-- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows, +-- @some@ will return exactly one row, with a @NonEmptyTable@ collecting all +-- returned rows. +-- +-- @some@ is analogous to 'Control.Applicative.some' from +-- @Control.Applicative@. +some :: Table Expr a => Query a -> Query (NonEmptyTable a) +some = + fmap (\(NonEmptyTable a) -> NonEmptyTable a) . + aggregate . + fmap (nonEmptyAgg . toColumns) + + +-- | A version of 'many' specialised to single expressions. +manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a]) +manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr + + +-- | A version of 'many' specialised to single expressions. +someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a)) +someExpr = aggregate . fmap nonEmptyAggExpr + + +-- | Expand a 'ListTable' into a 'Query', where each row in the query is an +-- element of the given @ListTable@. +-- +-- @catListTable@ is an inverse to 'many'. +catListTable :: Table Expr a => ListTable a -> Query a +catListTable (ListTable as) = pure $ fromColumns $ runIdentity $ + hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as + + +-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an +-- element of the given @NonEmptyTable@. +-- +-- @catNonEmptyTable@ is an inverse to 'some'. +catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a +catNonEmptyTable (NonEmptyTable as) = pure $ fromColumns $ runIdentity $ + hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as + + +-- | Expand an expression that contains a list into a 'Query', where each row +-- in the query is an element of the given list. +-- +-- @catList@ is an inverse to 'manyExpr'. +catList :: Sql DBType a => Expr [a] -> Query (Expr a) +catList = pure . sunnest typeInformation + + +-- | Expand an expression that contains a non-empty list into a 'Query', where +-- each row in the query is an element of the given list. +-- +-- @catNonEmpty@ is an inverse to 'someExpr'. +catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a) +catNonEmpty = pure . sunnest typeInformation + + +sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a +sunnest info = mapPrimExpr $ + extractArrayElement info . + Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST") diff --git a/src/Rel8/Query/Maybe.hs b/src/Rel8/Query/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Maybe.hs @@ -0,0 +1,73 @@ +module Rel8.Query.Maybe + ( optional + , catMaybeTable + , traverseMaybeTable + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Internal.PackMap as Opaleye +import qualified Opaleye.Internal.PrimQuery as Opaleye +import qualified Opaleye.Internal.QueryArr as Opaleye +import qualified Opaleye.Internal.Tag as Opaleye +import qualified Opaleye.Internal.Unpackspec as Opaleye + +-- rel8 +import Rel8.Expr.Bool ( true ) +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Expr.Opaleye ( toPrimExpr ) +import Rel8.Query ( Query ) +import Rel8.Query.Filter ( where_ ) +import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable ) +import Rel8.Table.Opaleye ( unpackspec ) +import Rel8.Table.Tag ( Tag(..), fromExpr ) + + +-- | Convert a query that might return zero rows to a query that always returns +-- at least one row. +-- +-- To speak in more concrete terms, 'optional' is most useful to write @LEFT +-- JOIN@s. +optional :: Query a -> Query (MaybeTable a) +optional = mapOpaleye $ Opaleye.QueryArr . go + where + go query (i, left, tag) = + (MaybeTable (fromExpr t') a, join, Opaleye.next tag') + where + (MaybeTable Tag {expr = t} a, right, tag') = + Opaleye.runSimpleQueryArr (pure <$> query) (i, tag) + (t', bindings) = Opaleye.run $ + Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t + join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right + condition = toPrimExpr true + + +-- | Filter out 'MaybeTable's, returning only the tables that are not-null. +-- +-- This operation can be used to "undo" the effect of 'optional', which +-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You +-- can think of this as analogous to 'Data.Maybe.catMaybes'. +catMaybeTable :: MaybeTable a -> Query a +catMaybeTable ma@(MaybeTable _ a) = do + where_ $ isJustTable ma + pure a + + +-- | Extend an optional query with another query. This is useful if you want +-- to step through multiple @LEFT JOINs@. +-- +-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means +-- you also have the ability to "expand" one row into multiple rows. If the +-- @a -> Query b@ function returns no rows, then the resulting query will also +-- have no rows. However, regardless of the given @a -> Query b@ function, if +-- the input is @nothingTable@, you will always get exactly one @nothingTable@ +-- back. +traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b) +traverseMaybeTable query ma@(MaybeTable input _) = do + MaybeTable output b <- optional (query =<< catMaybeTable ma) + where_ $ expr output ==. expr input + pure $ MaybeTable input b diff --git a/src/Rel8/Query/Null.hs b/src/Rel8/Query/Null.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Null.hs @@ -0,0 +1,23 @@ +module Rel8.Query.Null + ( catNull + ) +where + +-- base +import Prelude + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Null ( isNonNull, unsafeUnnullify ) +import Rel8.Query ( Query ) +import Rel8.Query.Filter ( where_ ) + + +-- | Filter a 'Query' that might return @null@ to a 'Query' without any +-- @null@s. +-- +-- Corresponds to 'Data.Maybe.catMaybes'. +catNull :: Expr (Maybe a) -> Query (Expr a) +catNull a = do + where_ $ isNonNull a + pure $ unsafeUnnullify a diff --git a/src/Rel8/Query/Opaleye.hs b/src/Rel8/Query/Opaleye.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Opaleye.hs @@ -0,0 +1,34 @@ +module Rel8.Query.Opaleye + ( fromOpaleye + , toOpaleye + , mapOpaleye + , zipOpaleyeWith + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Select as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Query ( Query( Query ) ) + + +fromOpaleye :: Opaleye.Select a -> Query a +fromOpaleye = Query + + +toOpaleye :: Query a -> Opaleye.Select a +toOpaleye (Query a) = a + + +mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b +mapOpaleye f = fromOpaleye . f . toOpaleye + + +zipOpaleyeWith :: () + => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c) + -> Query a -> Query b -> Query c +zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b) diff --git a/src/Rel8/Query/Order.hs b/src/Rel8/Query/Order.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Order.hs @@ -0,0 +1,20 @@ +module Rel8.Query.Order + ( orderBy + ) +where + +-- base +import Prelude () + +-- opaleye +import qualified Opaleye.Order as Opaleye ( orderBy ) + +-- rel8 +import Rel8.Order ( Order( Order ) ) +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( mapOpaleye ) + + +-- | Order the rows returned by a query. +orderBy :: Order a -> Query a -> Query a +orderBy (Order o) = mapOpaleye (Opaleye.orderBy o) diff --git a/src/Rel8/Query/SQL.hs b/src/Rel8/Query/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/SQL.hs @@ -0,0 +1,74 @@ +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +module Rel8.Query.SQL + ( showQuery + , sqlForQuery, sqlForQueryWithNames + ) +where + +-- base +import Data.Foldable ( fold ) +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Void ( Void ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye +import qualified Opaleye.Internal.PrimQuery as Opaleye +import qualified Opaleye.Internal.Print as Opaleye +import qualified Opaleye.Internal.Optimize as Opaleye +import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select ) +import qualified Opaleye.Internal.Sql as Opaleye + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Opaleye ( toPrimExpr ) +import Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( toOpaleye ) +import Rel8.Schema.Name ( Name( Name ), Selects, Col( N ) ) +import Rel8.Schema.HTable ( htabulateA, hfield ) +import Rel8.Table ( Table, toColumns ) +import Rel8.Table.Name ( namesFromLabels ) +import Rel8.Table.Opaleye ( castTable ) + + +-- | Convert a query to a 'String' containing the query as a @SELECT@ +-- statement. +showQuery :: Table Expr a => Query a -> String +showQuery = fold . sqlForQuery + + +sqlForQuery :: Table Expr a + => Query a -> Maybe String +sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns + + +sqlForQueryWithNames :: Selects names exprs + => names -> Query exprs -> Maybe String +sqlForQueryWithNames names query = + show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery + where + (exprs, primQuery, _) = + Opaleye.runSimpleQueryArrStart (toOpaleye query) () + + +optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void) +optimize = Opaleye.removeEmpty . Opaleye.optimize + + +selectFrom :: Selects names exprs + => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select +selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query = + Opaleye.SelectFrom $ Opaleye.newSelect + { Opaleye.attrs = Opaleye.SelectAttrs attributes + , Opaleye.tables = Opaleye.oneTable select + } + where + select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query + attributes = getConst $ htabulateA $ \field -> case hfield names field of + N (Name name) -> case hfield exprs field of + E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr)) + makeAttr label expr = + (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label)) diff --git a/src/Rel8/Query/Set.hs b/src/Rel8/Query/Set.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Set.hs @@ -0,0 +1,58 @@ +{-# language FlexibleContexts #-} + +module Rel8.Query.Set + ( union, unionAll + , intersect, intersectAll + , except, exceptAll + ) +where + +-- base +import Prelude () + +-- opaleye +import qualified Opaleye.Binary as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import {-# SOURCE #-} Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( zipOpaleyeWith ) +import Rel8.Table ( Table ) +import Rel8.Table.Eq ( EqTable ) +import Rel8.Table.Opaleye ( binaryspec ) + + +-- | Combine the results of two queries of the same type, collapsing +-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@. +union :: EqTable a => Query a -> Query a -> Query a +union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec) + + +-- | Combine the results of two queries of the same type, retaining duplicates. +-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@. +unionAll :: Table Expr a => Query a -> Query a -> Query a +unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec) + + +-- | Find the intersection of two queries, collapsing duplicates. @intersect a +-- b@ is the same as the SQL statement @x INTERSECT b@. +intersect :: EqTable a => Query a -> Query a -> Query a +intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec) + + +-- | Find the intersection of two queries, retaining duplicates. @intersectAll +-- a b@ is the same as the SQL statement @x INTERSECT ALL b@. +intersectAll :: EqTable a => Query a -> Query a -> Query a +intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec) + + +-- | Find the difference of two queries, collapsing duplicates @except a b@ is +-- the same as the SQL statement @x INTERSECT b@. +except :: EqTable a => Query a -> Query a -> Query a +except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec) + + +-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@ +-- is the same as the SQL statement @x EXCEPT ALL b@. +exceptAll :: EqTable a => Query a -> Query a -> Query a +exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec) diff --git a/src/Rel8/Query/These.hs b/src/Rel8/Query/These.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/These.hs @@ -0,0 +1,125 @@ +{-# language FlexibleContexts #-} + +module Rel8.Query.These + ( alignBy + , keepHereTable, loseHereTable + , keepThereTable, loseThereTable + , keepThisTable, loseThisTable + , keepThatTable, loseThatTable + , keepThoseTable, loseThoseTable + , bitraverseTheseTable + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Internal.Join as Opaleye +import qualified Opaleye.Internal.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Bool ( boolExpr, not_ ) +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Query ( Query ) +import Rel8.Query.Filter ( where_ ) +import Rel8.Query.Maybe ( optional ) +import Rel8.Query.Opaleye ( zipOpaleyeWith ) +import Rel8.Table ( Table ) +import Rel8.Table.Either ( EitherTable( EitherTable ) ) +import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable ) +import Rel8.Table.Opaleye ( unpackspec ) +import Rel8.Table.Tag ( Tag(..) ) +import Rel8.Table.These + ( TheseTable( TheseTable ) + , hasHereTable, hasThereTable + , isThisTable, isThatTable, isThoseTable + ) +import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) ) + + +-- | Corresponds to a @FULL OUTER JOIN@ between two queries. +alignBy :: (Table Expr a, Table Expr b) + => (a -> b -> Expr Bool) + -> Query a -> Query b -> Query (TheseTable a b) +alignBy condition as bs = + uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs + where + fullOuterJoin a b = + Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on + where + full = Opaleye.FullJoin + on = toColumn . toPrimExpr . uncurry condition + + +-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's. +keepHereTable :: TheseTable a b -> Query (a, MaybeTable b) +keepHereTable = loseThatTable + + +-- | Filter 'TheseTable's, keeping on +loseHereTable :: TheseTable a b -> Query b +loseHereTable = keepThatTable + + +keepThereTable :: TheseTable a b -> Query (MaybeTable a, b) +keepThereTable = loseThisTable + + +loseThereTable :: TheseTable a b -> Query a +loseThereTable = keepThisTable + + +keepThisTable :: TheseTable a b -> Query a +keepThisTable t@(TheseTable (MaybeTable _ a) _) = do + where_ $ isThisTable t + pure a + + +loseThisTable :: TheseTable a b -> Query (MaybeTable a, b) +loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do + where_ $ not_ $ isThisTable t + pure (ma, b) + + +keepThatTable :: TheseTable a b -> Query b +keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do + where_ $ isThatTable t + pure b + + +loseThatTable :: TheseTable a b -> Query (a, MaybeTable b) +loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do + where_ $ not_ $ isThatTable t + pure (a, mb) + + +keepThoseTable :: TheseTable a b -> Query (a, b) +keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do + where_ $ isThoseTable t + pure (a, b) + + +loseThoseTable :: TheseTable a b -> Query (EitherTable a b) +loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do + where_ $ not_ $ isThoseTable t + pure $ EitherTable result a b + where + tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t) + result = (mempty `asTypeOf` result) {expr = tag} + + +bitraverseTheseTable :: () + => (a -> Query c) + -> (b -> Query d) + -> TheseTable a b + -> Query (TheseTable c d) +bitraverseTheseTable f g t = do + mc <- optional (f . fst =<< keepHereTable t) + md <- optional (g . snd =<< keepThereTable t) + where_ $ isJustTable mc ==. hasHereTable t + where_ $ isJustTable md ==. hasThereTable t + pure $ TheseTable mc md diff --git a/src/Rel8/Query/Values.hs b/src/Rel8/Query/Values.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Values.hs @@ -0,0 +1,27 @@ +{-# language FlexibleContexts #-} + +module Rel8.Query.Values + ( values + ) +where + +-- base +import Data.Foldable ( toList ) +import Prelude + +-- opaleye +import qualified Opaleye.Values as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import {-# SOURCE #-} Rel8.Query ( Query ) +import Rel8.Query.Opaleye ( fromOpaleye ) +import Rel8.Table ( Table ) +import Rel8.Table.Opaleye ( valuesspec ) + + +-- | Construct a query that returns the given input list of rows. This is like +-- folding a list of 'return' statements under 'Rel8.union', but uses the SQL +-- @VALUES@ expression for efficiency. +values :: (Table Expr a, Foldable f) => f a -> Query a +values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList diff --git a/src/Rel8/Schema/Context.hs b/src/Rel8/Schema/Context.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Context.hs @@ -0,0 +1,20 @@ +{-# language DataKinds #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Schema.Context + ( Interpretation( Col ) + ) +where + +-- base +import Data.Kind ( Constraint ) +import Prelude () + +-- rel8 +import Rel8.Schema.Kind ( Context, HContext ) + + +type Interpretation :: Context -> Constraint +class Interpretation context where + data Col context :: HContext diff --git a/src/Rel8/Schema/Context/Label.hs b/src/Rel8/Schema/Context/Label.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Context/Label.hs @@ -0,0 +1,62 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} + +module Rel8.Schema.Context.Label + ( Labelable( labeler, unlabeler ) + , HLabelable( hlabeler, hunlabeler ) + ) +where + +-- base +import Data.Kind ( Constraint ) +import Prelude hiding ( null ) + +-- rel8 +import Rel8.Schema.Context ( Interpretation ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Kind ( Context, HContext ) +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Schema.Result ( Col( R ), Result ) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType ) + + +-- | The @Labelable@ class is an internal implementation detail of Rel8, and +-- indicates that we can successfully "name" all columns in a type. +type Labelable :: Context -> Constraint +class Interpretation context => Labelable context where + labeler :: () + => Col context ('Spec labels a) + -> Col context ('Spec (label ': labels) a) + + unlabeler :: () + => Col context ('Spec (label ': labels) a) + -> Col context ('Spec labels a) + + +instance Labelable Result where + labeler (R a) = R a + unlabeler (R a) = R a + + +type HLabelable :: HContext -> Constraint +class HLabelable context where + hlabeler :: () + => context ('Spec labels a) + -> context ('Spec (label ': labels) a) + + hunlabeler :: () + => context ('Spec (label ': labels) a) + -> context ('Spec labels a) + + +instance Labelable context => HLabelable (Col context) where + hlabeler = labeler + hunlabeler = unlabeler + + +instance HLabelable (Dict (ConstrainDBType constraint)) where + hlabeler Dict = Dict + hunlabeler Dict = Dict diff --git a/src/Rel8/Schema/Context/Nullify.hs b/src/Rel8/Schema/Context/Nullify.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Context/Nullify.hs @@ -0,0 +1,188 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language InstanceSigs #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Schema.Context.Nullify + ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier ) + , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier ) + , runTag, unnull + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import GHC.TypeLits ( KnownSymbol ) +import Prelude hiding ( null ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Aggregate + ( Aggregate( Aggregate ), Col( A ) + , mapInputs + , unsafeMakeAggregate + ) +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Bool ( boolExpr ) +import Rel8.Expr.Null ( nullify, unsafeUnnullify ) +import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr ) +import Rel8.Schema.Context ( Interpretation ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name( Name ), Col( N ) ) +import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType ) +import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType +import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName ) + + +type Nullifiable :: K.Context -> Constraint +class Interpretation context => Nullifiable context where + type ConstrainTag context :: Type -> Constraint + type ConstrainTag _context = DefaultConstrainTag + + encodeTag :: + ( Sql (ConstrainTag context) a + , KnownSymbol label + , Taggable a + ) + => Tag label a + -> Col context ('Spec labels a) + + decodeTag :: + ( Sql (ConstrainTag context) a + , KnownSymbol label + , Taggable a + ) + => Col context ('Spec labels a) + -> Tag label a + + nullifier :: () + => Tag label a + -> (Expr a -> Expr Bool) + -> SSpec ('Spec labels x) + -> Col context ('Spec labels x) + -> Col context ('Spec labels (Nullify x)) + + unnullifier :: () + => SSpec ('Spec labels x) + -> Col context ('Spec labels (Nullify x)) + -> Col context ('Spec labels x) + + +instance Nullifiable Aggregate where + encodeTag Tag {aggregator, expr} = + A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr + + decodeTag (A aggregate) = fromAggregate aggregate + + nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) = + A $ + mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $ + Aggregate $ + runTag nullity condition <$> a + where + condition = test expr + + unnullifier SSpec {nullity} (A (Aggregate a)) = + A (Aggregate (unnull nullity <$> a)) + + {-# INLINABLE encodeTag #-} + {-# INLINABLE decodeTag #-} + {-# INLINABLE nullifier #-} + {-# INLINABLE unnullifier #-} + + +instance Nullifiable Expr where + encodeTag Tag {expr} = E expr + decodeTag (E a) = fromExpr a + nullifier Tag {expr} test SSpec {nullity} (E a) = + E $ runTag nullity (test expr) a + unnullifier SSpec {nullity} (E a) = E $ unnull nullity a + + {-# INLINABLE encodeTag #-} + {-# INLINABLE decodeTag #-} + {-# INLINABLE nullifier #-} + {-# INLINABLE unnullifier #-} + + +instance Nullifiable Name where + encodeTag Tag {name} = N name + decodeTag (N name) = fromName name + nullifier _ _ _ (N (Name name)) = N (Name name) + unnullifier _ (N (Name name)) = N (Name name) + + {-# INLINABLE encodeTag #-} + {-# INLINABLE decodeTag #-} + {-# INLINABLE nullifier #-} + {-# INLINABLE unnullifier #-} + + +runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a) +runTag nullity tag a = case nullity of + Null -> boolExpr null a tag + NotNull -> boolExpr null (nullify a) tag + where + null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit + + +unnull :: Nullity a -> Expr (Nullify a) -> Expr a +unnull nullity a = case nullity of + Null -> a + NotNull -> unsafeUnnullify a + + +type HNullifiable :: K.HContext -> Constraint +class HNullifiable context where + type HConstrainTag context :: Type -> Constraint + type HConstrainTag _context = DefaultConstrainTag + + hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a) + => Tag label a + -> context ('Spec labels a) + + hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a) + => context ('Spec labels a) + -> Tag label a + + hnullifier :: () + => Tag label a + -> (Expr a -> Expr Bool) + -> SSpec ('Spec labels x) + -> context ('Spec labels x) + -> context ('Spec labels (Nullify x)) + + hunnullifier :: () + => SSpec ('Spec labels x) + -> context ('Spec labels (Nullify x)) + -> context ('Spec labels x) + + +instance Nullifiable context => HNullifiable (Col context) where + type HConstrainTag (Col context) = ConstrainTag context + hencodeTag = encodeTag + hdecodeTag = decodeTag + hnullifier = nullifier + hunnullifier = unnullifier + + +instance HNullifiable (Dict (ConstrainDBType constraint)) where + type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint + + hencodeTag _ = Dict + hdecodeTag = mempty + hnullifier _ _ = ConstrainDBType.nullifier + hunnullifier = ConstrainDBType.unnullifier + + +type DefaultConstrainTag :: Type -> Constraint +class DefaultConstrainTag a +instance DefaultConstrainTag a diff --git a/src/Rel8/Schema/Dict.hs b/src/Rel8/Schema/Dict.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Dict.hs @@ -0,0 +1,18 @@ +{-# language ConstraintKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.Dict + ( Dict( Dict ) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + + +type Dict :: (a -> Constraint) -> a -> Type +data Dict c a where + Dict :: c a => Dict c a diff --git a/src/Rel8/Schema/HTable.hs b/src/Rel8/Schema/HTable.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable.hs @@ -0,0 +1,181 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language LambdaCase #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilyDependencies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.HTable + ( HTable (HField, HConstrainTable) + , hfield, htabulate, htraverse, hdicts, hspecs + , hmap, htabulateA + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Functor.Compose ( Compose( Compose ), getCompose ) +import Data.Proxy ( Proxy ) +import GHC.Generics + ( (:*:)( (:*:) ) + , Generic (Rep, from, to) + , K1( K1 ) + , M1( M1 ) + ) +import Prelude + +-- rel8 +import Rel8.Schema.Dict ( Dict ) +import Rel8.Schema.Spec ( Spec, SSpec ) +import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import qualified Rel8.Schema.Kind as K + +-- semigroupoids +import Data.Functor.Apply ( Apply, (<.>) ) + + +-- | A @HTable@ is a functor-indexed/higher-kinded data type that is +-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and +-- specified ('hspecs'). +-- +-- This is an internal concept for Rel8, and you should not need to define +-- instances yourself or specify this constraint. +type HTable :: K.HTable -> Constraint +class HTable t where + type HField t = (field :: Spec -> Type) | field -> t + type HConstrainTable t (c :: Spec -> Constraint) :: Constraint + + hfield :: t context -> HField t spec -> context spec + htabulate :: (forall spec. HField t spec -> context spec) -> t context + htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g) + hdicts :: HConstrainTable t c => t (Dict c) + hspecs :: t SSpec + + type HField t = GHField t + type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c + + default hfield :: + ( Generic (t context) + , HField t ~ GHField t + , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context))) + , GHTable context (Rep (t context)) + ) + => t context -> HField t spec -> context spec + hfield table (GHField field) = hfield (toGHColumns (from table)) field + + default htabulate :: + ( Generic (t context) + , HField t ~ GHField t + , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context))) + , GHTable context (Rep (t context)) + ) + => (forall spec. HField t spec -> context spec) -> t context + htabulate f = to $ fromGHColumns $ htabulate (f . GHField) + + default htraverse + :: forall f g m + . ( Apply m + , Generic (t f), GHTable f (Rep (t f)) + , Generic (t g), GHTable g (Rep (t g)) + , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g)) + ) + => (forall spec. f spec -> m (g spec)) -> t f -> m (t g) + htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from + + default hdicts + :: forall c + . ( Generic (t (Dict c)) + , GHTable (Dict c) (Rep (t (Dict c))) + , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c))) + , HConstrainTable (GHColumns (Rep (t Proxy))) c + ) + => t (Dict c) + hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c) + + default hspecs :: + ( Generic (t SSpec) + , GHTable SSpec (Rep (t SSpec)) + ) + => t SSpec + hspecs = to $ fromGHColumns hspecs + + {-# INLINABLE hfield #-} + {-# INLINABLE htabulate #-} + {-# INLINABLE htraverse #-} + {-# INLINABLE hdicts #-} + {-# INLINABLE hspecs #-} + + +hmap :: HTable t + => (forall spec. context spec -> context' spec) -> t context -> t context' +hmap f a = htabulate $ \field -> f (hfield a field) + + +htabulateA :: (HTable t, Apply m) + => (forall spec. HField t spec -> m (context spec)) -> m (t context) +htabulateA f = htraverse getCompose $ htabulate $ Compose . f +{-# INLINABLE htabulateA #-} + + +type GHField :: K.HTable -> Spec -> Type +newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec) + + +type GHTable :: K.HContext -> (Type -> Type) -> Constraint +class HTable (GHColumns rep) => GHTable context rep | rep -> context where + type GHColumns rep :: K.HTable + toGHColumns :: rep x -> GHColumns rep context + fromGHColumns :: GHColumns rep context -> rep x + + +instance GHTable context rep => GHTable context (M1 i c rep) where + type GHColumns (M1 i c rep) = GHColumns rep + toGHColumns (M1 a) = toGHColumns a + fromGHColumns = M1 . fromGHColumns + + +instance HTable table => GHTable context (K1 i (table context)) where + type GHColumns (K1 i (table context)) = table + toGHColumns (K1 a) = a + fromGHColumns = K1 + + +instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where + type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b) + toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b) + fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b + + +-- | A HField type for indexing into HProduct. +type HProductField :: K.HTable -> K.HTable -> Spec -> Type +data HProductField x y spec + = HFst (HField x spec) + | HSnd (HField y spec) + + +instance (HTable x, HTable y) => HTable (HProduct x y) where + type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c) + type HField (HProduct x y) = HProductField x y + + hfield (HProduct l r) = \case + HFst i -> hfield l i + HSnd i -> hfield r i + + htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd)) + htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y + hdicts = HProduct hdicts hdicts + hspecs = HProduct hspecs hspecs + + {-# INLINABLE hfield #-} + {-# INLINABLE htabulate #-} + {-# INLINABLE htraverse #-} + {-# INLINABLE hdicts #-} + {-# INLINABLE hspecs #-} diff --git a/src/Rel8/Schema/HTable/Either.hs b/src/Rel8/Schema/HTable/Either.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Either.hs @@ -0,0 +1,33 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.Either + ( HEitherTable(..) + ) +where + +-- base +import GHC.Generics ( Generic ) +import Prelude () + +-- rel8 +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( HLabel ) +import Rel8.Schema.HTable.Nullify ( HNullify ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Type.Tag ( EitherTag ) + + +type HEitherTable :: K.HTable -> K.HTable -> K.HTable +data HEitherTable left right context = HEitherTable + { htag :: HIdentity ('Spec '["isRight"] EitherTag) context + , hleft :: HLabel "Left" (HNullify left) context + , hright :: HLabel "Right" (HNullify right) context + } + deriving stock Generic + deriving anyclass HTable diff --git a/src/Rel8/Schema/HTable/Identity.hs b/src/Rel8/Schema/HTable/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Identity.hs @@ -0,0 +1,55 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PatternSynonyms #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Schema.HTable.Identity + ( HIdentity( HIdentity, HType, unHIdentity ) + , HType + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude + +-- rel8 +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable + ( HTable, HConstrainTable, HField + , hfield, htabulate, htraverse, hdicts, hspecs + ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing ) + + +type HType :: Type -> K.HTable +type HType a = HIdentity ('Spec '[] a) + + +pattern HType :: context ('Spec '[] a) -> HType a context +pattern HType a = HIdentity a +{-# COMPLETE HType #-} + + +type HIdentity :: Spec -> K.HTable +newtype HIdentity spec context = HIdentity + { unHIdentity :: context spec + } + + +type HIdentityField :: Spec -> Spec -> Type +data HIdentityField _spec spec where + HIdentityField :: HIdentityField spec spec + + +instance KnownSpec spec => HTable (HIdentity spec) where + type HConstrainTable (HIdentity spec) c = c spec + type HField (HIdentity spec) = HIdentityField spec + + hfield (HIdentity a) HIdentityField = a + htabulate f = HIdentity $ f HIdentityField + htraverse f (HIdentity a) = HIdentity <$> f a + hdicts = HIdentity Dict + hspecs = HIdentity specSing diff --git a/src/Rel8/Schema/HTable/Label.hs b/src/Rel8/Schema/HTable/Label.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Label.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.HTable.Label + ( HLabel, Label + , hlabel, hunlabel + ) +where + +-- base +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.TypeLits ( KnownSymbol, Symbol ) +import Prelude + +-- rel8 +import Rel8.Kind.Labels ( SLabels( SCons ) ) +import Rel8.Schema.HTable + ( HTable + , hfield, htabulate, hspecs + ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) +import Rel8.FCF +import Rel8.Schema.HTable.MapTable +import GHC.Generics (Generic) + + +type HLabel :: Symbol -> K.HTable -> K.HTable +newtype HLabel label table context = HLabel (HMapTable (Label label) table context) + deriving stock Generic + deriving anyclass HTable + + +data Label :: Symbol -> Spec -> Exp Spec + + +type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a + + +instance KnownSymbol l => MapSpec (Label l) where + mapInfo = \case + SSpec {..} -> SSpec {labels = SCons Proxy labels, ..} + + +hlabel :: (HTable t, KnownSymbol label) + => (forall labels a. () + => context ('Spec labels a) + -> context ('Spec (label ': labels) a)) + -> t context + -> HLabel label t context +hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) -> + case hfield hspecs field of + SSpec {} -> labeler (hfield a field) +{-# INLINABLE hlabel #-} + + +hunlabel :: (HTable t, KnownSymbol label) + => (forall labels a. () + => context ('Spec (label ': labels) a) + -> context ('Spec labels a)) + -> HLabel label t context + -> t context +hunlabel unlabler (HLabel as) = + htabulate $ \field -> + case hfield hspecs field of + SSpec {} -> case hfield as (HMapTableField field) of + a -> unlabler a +{-# INLINABLE hunlabel #-} diff --git a/src/Rel8/Schema/HTable/List.hs b/src/Rel8/Schema/HTable/List.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/List.hs @@ -0,0 +1,18 @@ +{-# language DataKinds #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.List + ( HListTable + ) +where + +-- base +import Prelude () + +-- rel8 +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.HTable.Vectorize ( HVectorize ) + + +type HListTable :: K.HTable -> K.HTable +type HListTable = HVectorize [] diff --git a/src/Rel8/Schema/HTable/MapTable.hs b/src/Rel8/Schema/HTable/MapTable.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/MapTable.hs @@ -0,0 +1,89 @@ +{-# language AllowAmbiguousTypes #-} +{-# language BlockArguments #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language InstanceSigs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Schema.HTable.MapTable + ( HMapTable(..) + , MapSpec(..) + , Precompose(..) + , HMapTableField(..) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude ( ($), (.), (<$>), fmap ) + +-- rel8 +import Rel8.FCF +import Rel8.Schema.HTable +import Rel8.Schema.Spec ( Spec, SSpec ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Dict ( Dict( Dict ) ) + + +type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type +newtype HMapTable f t g = HMapTable + { unHMapTable :: t (Precompose f g) + } + + +type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type +newtype Precompose f g x = Precompose + { precomposed :: g (Eval (f x)) + } + + +type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type +data HMapTableField f t x where + HMapTableField :: HField t a -> HMapTableField f t (Eval (f a)) + + +instance (HTable t, MapSpec f) => HTable (HMapTable f t) where + type HField (HMapTable f t) = + HMapTableField f t + + type HConstrainTable (HMapTable f t) c = + HConstrainTable t (ComposeConstraint f c) + + hfield (HMapTable x) (HMapTableField i) = + precomposed (hfield x i) + + htabulate f = + HMapTable $ htabulate (Precompose . f . HMapTableField) + + htraverse f (HMapTable x) = + HMapTable <$> htraverse (fmap Precompose . f . precomposed) x + {-# INLINABLE htraverse #-} + + hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c) + hdicts = + htabulate \(HMapTableField j) -> + case hfield (hdicts @_ @(ComposeConstraint f c)) j of + Dict -> Dict + + hspecs = + HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs + {-# INLINABLE hspecs #-} + + +type MapSpec :: (Spec -> Exp Spec) -> Constraint +class MapSpec f where + mapInfo :: SSpec x -> SSpec (Eval (f x)) + + +type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint +class c (Eval (f a)) => ComposeConstraint f c a +instance c (Eval (f a)) => ComposeConstraint f c a diff --git a/src/Rel8/Schema/HTable/Maybe.hs b/src/Rel8/Schema/HTable/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Maybe.hs @@ -0,0 +1,32 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.Maybe + ( HMaybeTable(..) + ) +where + +-- base +import GHC.Generics ( Generic ) +import Prelude + +-- rel8 +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( HLabel ) +import Rel8.Schema.HTable.Nullify ( HNullify ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Type.Tag ( MaybeTag ) + + +type HMaybeTable :: K.HTable -> K.HTable +data HMaybeTable table context = HMaybeTable + { htag :: HIdentity ('Spec '["isJust"] (Maybe MaybeTag)) context + , hjust :: HLabel "Just" (HNullify table) context + } + deriving stock Generic + deriving anyclass HTable diff --git a/src/Rel8/Schema/HTable/NonEmpty.hs b/src/Rel8/Schema/HTable/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/NonEmpty.hs @@ -0,0 +1,19 @@ +{-# language DataKinds #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.NonEmpty + ( HNonEmptyTable + ) +where + +-- base +import Data.List.NonEmpty ( NonEmpty ) +import Prelude () + +-- rel8 +import Rel8.Schema.HTable.Vectorize ( HVectorize ) +import qualified Rel8.Schema.Kind as K + + +type HNonEmptyTable :: K.HTable -> K.HTable +type HNonEmptyTable = HVectorize NonEmpty diff --git a/src/Rel8/Schema/HTable/Nullify.hs b/src/Rel8/Schema/HTable/Nullify.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Nullify.hs @@ -0,0 +1,102 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DerivingStrategies #-} +{-# language DeriveGeneric #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.HTable.Nullify + ( HNullify( HNullify ) + , Nullify + , hnulls, hnullify, hunnullify + ) +where + +-- base +import Prelude hiding ( null ) + +-- rel8 +import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import qualified Rel8.Schema.Null as Type ( Nullify ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) + +-- semigroupoids +import Data.Functor.Apply ( Apply ) +import Rel8.Schema.HTable.MapTable +import Rel8.FCF +import GHC.Generics (Generic) + + +type HNullify :: K.HTable -> K.HTable +newtype HNullify table context = HNullify (HMapTable Nullify table context) + deriving stock Generic + deriving anyclass HTable + + + +-- | Transform a 'Spec' by allowing it to be @null@. +data Nullify :: Spec -> Exp Spec + + +type instance Eval (Nullify ('Spec labels a)) = + 'Spec labels (Type.Nullify a) + + +instance MapSpec Nullify where + mapInfo = \case + SSpec{labels, info, nullity} -> SSpec + { labels + , info + , nullity = case nullity of + Null -> Null + NotNull -> Null + } + + +hnulls :: HTable t + => (forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels (Type.Nullify a))) + -> HNullify t context +hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of + spec@SSpec {} -> null spec +{-# INLINABLE hnulls #-} + + +hnullify :: HTable t + => (forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels a) + -> context ('Spec labels (Type.Nullify a))) + -> t context + -> HNullify t context +hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) -> + case hfield hspecs field of + spec@SSpec {} -> nullifier spec (hfield a field) +{-# INLINABLE hnullify #-} + + +hunnullify :: (HTable t, Apply m) + => (forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels (Type.Nullify a)) + -> m (context ('Spec labels a))) + -> HNullify t context + -> m (t context) +hunnullify unnullifier (HNullify as) = + htabulateA $ \field -> case hfield hspecs field of + spec@SSpec {} -> case hfield as (HMapTableField field) of + a -> unnullifier spec a +{-# INLINABLE hunnullify #-} diff --git a/src/Rel8/Schema/HTable/Product.hs b/src/Rel8/Schema/HTable/Product.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Product.hs @@ -0,0 +1,17 @@ +{-# language DataKinds #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.Product + ( HProduct(..) + ) +where + +-- base +import Prelude () + +-- rel8 +import qualified Rel8.Schema.Kind as K + + +type HProduct :: K.HTable -> K.HTable -> K.HTable +data HProduct a b context = HProduct (a context) (b context) diff --git a/src/Rel8/Schema/HTable/These.hs b/src/Rel8/Schema/HTable/These.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/These.hs @@ -0,0 +1,34 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.HTable.These + ( HTheseTable(..) + ) +where + +-- base +import GHC.Generics ( Generic ) +import Prelude + +-- rel8 +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HIdentity ) +import Rel8.Schema.HTable.Label ( HLabel ) +import Rel8.Schema.HTable.Nullify ( HNullify ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Type.Tag ( MaybeTag ) + + +type HTheseTable :: K.HTable -> K.HTable -> K.HTable +data HTheseTable here there context = HTheseTable + { hhereTag :: HIdentity ('Spec '["hasHere"] (Maybe MaybeTag)) context + , hhere :: HLabel "Here" (HNullify here) context + , hthereTag :: HIdentity ('Spec '["hasThere"] (Maybe MaybeTag)) context + , hthere :: HLabel "There" (HNullify there) context + } + deriving stock Generic + deriving anyclass HTable diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -0,0 +1,151 @@ +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.HTable.Vectorize + ( HVectorize + , hvectorize, hunvectorize + , happend, hempty + ) +where + +-- base +import Data.Kind ( Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Prelude + +-- rel8 +import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.HTable + ( HTable + , hfield, htabulate, htabulateA, hspecs + ) +import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) +import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) +import Rel8.Type.Information ( TypeInformation ) + +-- semialign +import Data.Zip ( Unzip, Zip, Zippy(..) ) +import Rel8.FCF +import Rel8.Schema.HTable.MapTable +import GHC.Generics (Generic) + + +class Vector list where + listNotNull :: proxy a -> Dict NotNull (list a) + vectorTypeInformation :: () + => Nullity a + -> TypeInformation (Unnullify a) + -> TypeInformation (list a) + + +instance Vector [] where + listNotNull _ = Dict + vectorTypeInformation = listTypeInformation + + +instance Vector NonEmpty where + listNotNull _ = Dict + vectorTypeInformation = nonEmptyTypeInformation + + +type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable +newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context) + deriving stock Generic + deriving anyclass HTable + + +data Vectorize :: (Type -> Type) -> Spec -> Exp Spec + + +type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a) + + +instance Vector list => MapSpec (Vectorize list) where + mapInfo = \case + SSpec {..} -> case listNotNull @list nullity of + Dict -> SSpec + { nullity = NotNull + , info = vectorTypeInformation nullity info + , .. + } + + +hvectorize :: (HTable t, Unzip f, Vector list) + => (forall labels a. () + => SSpec ('Spec labels a) + -> f (context ('Spec labels a)) + -> context' ('Spec labels (list a))) + -> f (t context) + -> HVectorize list t context' +hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) -> + case hfield hspecs field of + spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as) +{-# INLINABLE hvectorize #-} + + +hunvectorize :: (HTable t, Zip f, Vector list) + => (forall labels a. () + => SSpec ('Spec labels a) + -> context ('Spec labels (list a)) + -> f (context' ('Spec labels a))) + -> HVectorize list t context + -> f (t context') +hunvectorize unvectorizer (HVectorize table) = + getZippy $ htabulateA $ \field -> case hfield hspecs field of + spec@SSpec{} -> case hfield table (HMapTableField field) of + a -> Zippy (unvectorizer spec a) +{-# INLINABLE hunvectorize #-} + + +happend :: (HTable t, Vector list) => + ( forall labels a. () + => Nullity a + -> TypeInformation (Unnullify a) + -> context ('Spec labels (list a)) + -> context ('Spec labels (list a)) + -> context ('Spec labels (list a)) + ) + -> HVectorize list t context + -> HVectorize list t context + -> HVectorize list t context +happend append (HVectorize as) (HVectorize bs) = HVectorize $ + htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of + (a, b) -> case hfield hspecs j of + SSpec {nullity, info} -> append nullity info a b + + +hempty :: HTable t => + ( forall labels a. () + => Nullity a + -> TypeInformation (Unnullify a) + -> context ('Spec labels [a]) + ) + -> HVectorize [] t context +hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of + SSpec {nullity, info} -> empty nullity info + + +instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where + hlabeler = Precompose . hlabeler . precomposed + hunlabeler = Precompose . hunlabeler . precomposed diff --git a/src/Rel8/Schema/Kind.hs b/src/Rel8/Schema/Kind.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Kind.hs @@ -0,0 +1,33 @@ +{-# language StandaloneKindSignatures #-} + +module Rel8.Schema.Kind + ( Context, Rel8able + , HContext, HTable + ) +where + +-- base +import Data.Kind ( Type ) +import Prelude () + +-- rel8 +import Rel8.Schema.Spec ( Spec ) + + +type HContext :: Type +type HContext = Spec -> Type + + +type HTable :: Type +type HTable = HContext -> Type + + +data X + + +type Context :: Type +type Context = X -> Type + + +type Rel8able :: Type +type Rel8able = Context -> Type diff --git a/src/Rel8/Schema/Name.hs b/src/Rel8/Schema/Name.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Name.hs @@ -0,0 +1,99 @@ +{-# language DataKinds #-} +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language StandaloneDeriving #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Schema.Name + ( Name(..) + , Col( N, unN ) + , Selects + ) +where + +-- base +import Data.Functor.Identity ( Identity ) +import Data.Kind ( Constraint, Type ) +import Data.String ( IsString, fromString ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Schema.Context ( Interpretation, Col ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Reify ( notReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Spec ( Spec( Spec ) ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns, reify, unreify + ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Type ( DBType ) + + +-- | A @Name@ is the name of a column, as it would be defined in a table's +-- schema definition. You can construct names by using the @OverloadedStrings@ +-- extension and writing string literals. This is typically done when providing +-- a 'TableSchema' value. +type Name :: k -> Type +data Name a where + Name :: k ~ Type => !String -> Name (a :: k) + + +deriving stock instance Show (Name a) + + +instance k ~ Type => IsString (Name (a :: k)) where + fromString = Name + + +instance Sql DBType a => Table Name (Name a) where + type Columns (Name a) = HType a + type Context (Name a) = Name + + toColumns a = HType (N a) + fromColumns (HType (N a)) = a + reify = notReify + unreify = notReify + + +instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a) + + +instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a) + + +instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a) + + +instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a) + + +instance Sql DBType a => Recontextualize Name Name (Name a) (Name a) + + +instance Interpretation Name where + data Col Name _spec where + N :: {unN :: !(Name a)} -> Col Name ('Spec labels a) + + +instance Labelable Name where + labeler (N a) = N a + unlabeler (N a) = N a + + +-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for +-- the 'Expr' columns in @b@. +type Selects :: Type -> Type -> Constraint +class Recontextualize Name Expr names exprs => Selects names exprs +instance Recontextualize Name Expr names exprs => Selects names exprs diff --git a/src/Rel8/Schema/Null.hs b/src/Rel8/Schema/Null.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Null.hs @@ -0,0 +1,110 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Schema.Null + ( Nullify, Unnullify + , NotNull + , Homonullable + , Nullity( Null, NotNull ) + , Nullable, nullable + , Sql + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude + + +type IsMaybe :: Type -> Bool +type family IsMaybe a where + IsMaybe (Maybe _) = 'True + IsMaybe _ = 'False + + +type Unnullify' :: Bool -> Type -> Type +type family Unnullify' isMaybe ma where + Unnullify' 'False a = a + Unnullify' 'True (Maybe a) = a + + +type Unnullify :: Type -> Type +type Unnullify a = Unnullify' (IsMaybe a) a + + +type Nullify' :: Bool -> Type -> Type +type family Nullify' isMaybe a where + Nullify' 'False a = a + Nullify' 'True a = Maybe a + + +type Nullify :: Type -> Type +type Nullify a = Maybe (Unnullify a) + + +-- | @nullify a@ means @a@ cannot take @null@ as a value. +type NotNull :: Type -> Constraint +class (Nullable a, IsMaybe a ~ 'False) => NotNull a +instance (Nullable a, IsMaybe a ~ 'False) => NotNull a + + +-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither +-- @a@ or @b@ can be @null@. +type Homonullable :: Type -> Type -> Constraint +class IsMaybe a ~ IsMaybe b => Homonullable a b +instance IsMaybe a ~ IsMaybe b => Homonullable a b + + +type Nullity :: Type -> Type +data Nullity a where + NotNull :: NotNull a => Nullity a + Null :: NotNull a => Nullity (Maybe a) + + +type Nullable' :: Bool -> Type -> Constraint +class + ( IsMaybe a ~ isMaybe + , IsMaybe (Unnullify a) ~ 'False + , Nullify' isMaybe (Unnullify a) ~ a + ) => Nullable' isMaybe a + where + nullable' :: Nullity a + + +instance IsMaybe a ~ 'False => Nullable' 'False a where + nullable' = NotNull + + +instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where + nullable' = Null + + +-- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a +-- type that can take @null@ values or not. +type Nullable :: Type -> Constraint +class Nullable' (IsMaybe a) a => Nullable a +instance Nullable' (IsMaybe a) a => Nullable a + + +nullable :: Nullable a => Nullity a +nullable = nullable' + + +-- | The @Sql@ type class describes both null and not null database values, +-- constrained by a specific class. +-- +-- For example, if you see @Sql DBEq a@, this means any database type that +-- supports equality, and @a@ can either be exactly an @a@, or it could also be +-- @Maybe a@. +type Sql :: (Type -> Constraint) -> Type -> Constraint +class (constraint (Unnullify a), Nullable a) => Sql constraint a +instance (constraint (Unnullify a), Nullable a) => Sql constraint a diff --git a/src/Rel8/Schema/Reify.hs b/src/Rel8/Schema/Reify.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Reify.hs @@ -0,0 +1,74 @@ +{-# language AllowAmbiguousTypes #-} +{-# language EmptyCase #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.Reify + ( Reify, Col( Reify ), hreify, hunreify + , UnwrapReify + , NotReify, notReify + ) +where + +-- base +import Data.Kind ( Constraint ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Schema.Context ( Interpretation, Col ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.HTable ( HTable, hmap ) +import Rel8.Schema.Kind ( Context ) + + +type Reify :: Context -> Context +data Reify context a + + +instance Interpretation (Reify context) where + newtype Col (Reify context) spec = Reify (Col context spec) + + +instance Labelable context => Labelable (Reify context) where + labeler (Reify a) = Reify (labeler a) + unlabeler (Reify a) = Reify (unlabeler a) + + +hreify :: HTable t => t (Col context) -> t (Col (Reify context)) +hreify = hmap Reify + + +hunreify :: HTable t => t (Col (Reify context)) -> t (Col context) +hunreify = hmap (\(Reify a) -> a) + + +type UnwrapReify :: Context -> Context +type family UnwrapReify context where + UnwrapReify (Reify context) = context + + +type IsReify :: Context -> Bool +type family IsReify context where + IsReify (Reify _) = 'True + IsReify _ = 'False + + +type NotReify :: Context -> Constraint +class IsReify context ~ 'False => NotReify context +instance IsReify context ~ 'False => NotReify context + + +notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a +notReify refl = case lemma @context of + Refl -> case refl of + + +lemma :: NotReify context => IsReify context :~: 'False +lemma = Refl diff --git a/src/Rel8/Schema/Result.hs b/src/Rel8/Schema/Result.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Result.hs @@ -0,0 +1,79 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Schema.Result + ( Col( R, unR ), Result + , relabel + , null, nullifier, unnullifier + , vectorizer, unvectorizer + ) +where + +-- base +import Prelude hiding ( null ) + +-- rel8 +import Rel8.Schema.Context ( Interpretation( Col ) ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.Kind ( Context ) +import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) + + +-- | The @Result@ context is the context used for decoded query results. +-- +-- When a query is executed against a PostgreSQL database, Rel8 parses the +-- returned rows, decoding each row into the @Result@ context. +type Result :: Context +data Result a + + +instance Interpretation Result where + data Col Result _spec where + R :: {unR :: !a} -> Col Result ('Spec labels a) + + +relabel :: () + => HIdentity ('Spec labels a) (Col Result) + -> HIdentity ('Spec relabels a) (Col Result) +relabel (HIdentity (R a)) = HIdentity (R a) + + +null :: Col Result ('Spec labels (Maybe a)) +null = R Nothing + + +nullifier :: () + => SSpec ('Spec labels a) + -> Col Result ('Spec labels a) + -> Col Result ('Spec labels (Nullify a)) +nullifier SSpec {nullity} (R a) = R $ case nullity of + Null -> a + NotNull -> Just a + + +unnullifier :: () + => SSpec ('Spec labels a) + -> Col Result ('Spec labels (Nullify a)) + -> Maybe (Col Result ('Spec labels a)) +unnullifier SSpec {nullity} (R a) = + case nullity of + Null -> pure $ R a + NotNull -> R <$> a + + +vectorizer :: Functor f + => SSpec ('Spec labels a) + -> f (Col Result ('Spec labels a)) + -> Col Result ('Spec labels (f a)) +vectorizer _ = R . fmap unR + + +unvectorizer :: Functor f + => SSpec ('Spec labels a) + -> Col Result ('Spec labels (f a)) + -> f (Col Result ('Spec labels a)) +unvectorizer _ (R results) = R <$> results diff --git a/src/Rel8/Schema/Spec.hs b/src/Rel8/Schema/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Spec.hs @@ -0,0 +1,54 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.Spec + ( Spec( Spec ) + , SSpec( SSpec, labels, info, nullity ) + , KnownSpec( specSing ) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- rel8 +import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing ) +import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Information ( TypeInformation ) + + +type Spec :: Type +data Spec = Spec Labels Type + + +type SSpec :: Spec -> Type +data SSpec spec where + SSpec :: + { labels :: SLabels labels + , info :: TypeInformation (Unnullify a) + , nullity :: Nullity a + } + -> SSpec ('Spec labels a) + + +type KnownSpec :: Spec -> Constraint +class KnownSpec spec where + specSing :: SSpec spec + + +instance + ( KnownLabels labels + , Sql DBType a + ) + => KnownSpec ('Spec labels a) + where + specSing = SSpec + { labels = labelsSing + , info = typeInformation + , nullity = nullable + } diff --git a/src/Rel8/Schema/Spec/ConstrainDBType.hs b/src/Rel8/Schema/Spec/ConstrainDBType.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Spec/ConstrainDBType.hs @@ -0,0 +1,89 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language QuantifiedConstraints #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Schema.Spec.ConstrainDBType + ( ConstrainDBType + , dbTypeNullity, dbTypeDict + , nullifier, unnullifier + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude + +-- rel8 +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Null + ( Nullify, Unnullify + , Nullity( Null, NotNull ) + , Sql, nullable + ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) ) + + +type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint +class + ( forall c labels a. () + => (spec ~ 'Spec labels a) + => (forall x. (constraint x => c x)) => Sql c a + ) + => ConstrainDBType constraint spec +instance + ( spec ~ 'Spec labels a + , Sql constraint a + ) + => ConstrainDBType constraint spec + + +dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l a) -> Nullity a +dbTypeNullity = step2 . step1 + where + step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a + step1 Dict = Dict + + step2 :: Dict (Sql c) a -> Nullity a + step2 Dict = nullable + + +dbTypeDict :: Dict (ConstrainDBType c) ('Spec l a) -> Dict c (Unnullify a) +dbTypeDict = step2 . step1 + where + step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a + step1 Dict = Dict + + step2 :: Dict (Sql c) a -> Dict c (Unnullify a) + step2 Dict = Dict + + +fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l a) +fromNullityDict Null Dict = Dict +fromNullityDict NotNull Dict = Dict + + +nullifier :: () + => SSpec ('Spec labels a) + -> Dict (ConstrainDBType c) ('Spec labels a) + -> Dict (ConstrainDBType c) ('Spec labels (Nullify a)) +nullifier SSpec {} dict = case dbTypeDict dict of + Dict -> case dbTypeNullity dict of + Null -> Dict + NotNull -> Dict + + +unnullifier :: () + => SSpec ('Spec labels a) + -> Dict (ConstrainDBType c) ('Spec labels (Nullify a)) + -> Dict (ConstrainDBType c) ('Spec labels a) +unnullifier SSpec {nullity} dict = case dbTypeDict dict of + Dict -> case nullity of + Null -> Dict + NotNull -> case dbTypeNullity dict of + Null -> fromNullityDict nullity Dict diff --git a/src/Rel8/Schema/Table.hs b/src/Rel8/Schema/Table.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Table.hs @@ -0,0 +1,29 @@ +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} + +module Rel8.Schema.Table + ( TableSchema(..) + ) +where + +-- base +import Prelude + + +-- | The schema for a table. This is used to specify the name and schema that a +-- table belongs to (the @FROM@ part of a SQL query), along with the schema of +-- the columns within this table. +-- +-- For each selectable table in your database, you should provide a +-- @TableSchema@ in order to interact with the table via Rel8. +data TableSchema names = TableSchema + { name :: String + -- ^ The name of the table. + , schema :: Maybe String + -- ^ The schema that this table belongs to. If 'Nothing', whatever is on + -- the connection's @search_path@ will be used. + , columns :: names + -- ^ The columns of the table. Typically you would use a a higher-kinded + -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor. + } + deriving stock Functor diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Delete.hs @@ -0,0 +1,92 @@ +{-# language DuplicateRecordFields #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} + +module Rel8.Statement.Delete + ( Delete(..) + , delete + ) +where + +-- base +import Control.Exception ( throwIO ) +import Data.Kind ( Type ) +import Prelude + +-- hasql +import Hasql.Connection ( Connection ) +import qualified Hasql.Decoders as Hasql +import qualified Hasql.Encoders as Hasql +import qualified Hasql.Session as Hasql +import qualified Hasql.Statement as Hasql + +-- opaleye +import qualified Opaleye.Internal.Manipulation as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) +import Rel8.Schema.Name ( Selects ) +import Rel8.Schema.Table ( TableSchema ) +import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) ) +import Rel8.Table ( fromColumns, toColumns ) +import Rel8.Table.Opaleye ( castTable, table, unpackspec ) +import Rel8.Table.Serialize ( Serializable, parse ) + +-- text +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 ) + + +-- | The constituent parts of a @DELETE@ statement. +type Delete :: Type -> Type +data Delete a where + Delete :: Selects names exprs => + { from :: TableSchema names + -- ^ Which table to delete from. + , deleteWhere :: exprs -> Expr Bool + -- ^ Which rows should be selected for deletion. + , returning :: Returning names a + -- ^ What to return from the @DELETE@ statement. + } + -> Delete a + + +-- | Run a @DELETE@ statement. +delete :: Connection -> Delete a -> IO a +delete c Delete {from, deleteWhere, returning} = + case returning of + NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = Hasql.rowsAffected + prepare = False + sql = Opaleye.arrangeDeleteSql from' where' + where + from' = table $ toColumns <$> from + where' = toColumn . toPrimExpr . deleteWhere . fromColumns + + Projection project -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = decoder project + prepare = False + sql = + Opaleye.arrangeDeleteReturningSql unpackspec from' where' project' + where + from' = table $ toColumns <$> from + where' = toColumn . toPrimExpr . deleteWhere . fromColumns + project' = castTable . toColumns . project . fromColumns + where + decoder :: forall exprs projection a. Serializable projection a + => (exprs -> projection) -> Hasql.Result [a] + decoder _ = Hasql.rowList (parse @projection @a) diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Insert.hs @@ -0,0 +1,118 @@ +{-# language DuplicateRecordFields #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} + +module Rel8.Statement.Insert + ( Insert(..) + , OnConflict(..) + , insert + ) +where + +-- base +import Control.Exception ( throwIO ) +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import Data.Kind ( Type ) +import Prelude + +-- hasql +import Hasql.Connection ( Connection ) +import qualified Hasql.Decoders as Hasql +import qualified Hasql.Encoders as Hasql +import qualified Hasql.Session as Hasql +import qualified Hasql.Statement as Hasql + +-- opaleye +import qualified Opaleye.Internal.Manipulation as Opaleye +import qualified Opaleye.Manipulation as Opaleye + +-- rel8 +import Rel8.Schema.Name ( Selects ) +import Rel8.Schema.Table ( TableSchema ) +import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) ) +import Rel8.Table ( fromColumns, toColumns ) +import Rel8.Table.Opaleye ( castTable, table, unpackspec ) +import Rel8.Table.Serialize ( Serializable, parse ) + +-- text +import qualified Data.Text as Text ( pack ) +import Data.Text.Encoding ( encodeUtf8 ) + + +-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@ +-- statement. +type OnConflict :: Type +data OnConflict + = Abort -- ^ @ON CONFLICT ABORT@ + | DoNothing -- ^ @ON CONFLICT DO NOTHING@ + + +-- | The constituent parts of a SQL @INSERT@ statement. +type Insert :: Type -> Type +data Insert a where + Insert :: Selects names exprs => + { into :: TableSchema names + -- ^ Which table to insert into. + , rows :: [exprs] + -- ^ The rows to insert. + , onConflict :: OnConflict + -- ^ What to do if the inserted rows conflict with data already in the + -- table. + , returning :: Returning names a + -- ^ What information to return on completion. + } + -> Insert a + + +-- | Run an @INSERT@ statement +insert :: Connection -> Insert a -> IO a +insert c Insert {into, rows, onConflict, returning} = + case (rows, returning) of + ([], NumberOfRowsAffected) -> pure 0 + ([], Projection _) -> pure [] + + (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = Hasql.rowsAffected + prepare = False + sql = Opaleye.arrangeInsertManySql into' rows' onConflict' + where + into' = table $ toColumns <$> into + rows' = toColumns <$> x :| xs + + (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = decoder project + prepare = False + sql = + Opaleye.arrangeInsertManyReturningSql + unpackspec + into' + rows' + project' + onConflict' + where + into' = table $ toColumns <$> into + rows' = toColumns <$> x :| xs + project' = castTable . toColumns . project . fromColumns + + where + onConflict' = + case onConflict of + DoNothing -> Just Opaleye.DoNothing + Abort -> Nothing + + decoder :: forall exprs projection a. Serializable projection a + => (exprs -> projection) -> Hasql.Result [a] + decoder _ = Hasql.rowList (parse @projection @a) diff --git a/src/Rel8/Statement/Returning.hs b/src/Rel8/Statement/Returning.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Returning.hs @@ -0,0 +1,29 @@ +{-# language GADTs #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Statement.Returning + ( Returning(..) + ) +where + +-- base +import Data.Int ( Int64 ) +import Data.Kind ( Type ) +import Prelude () + +-- rel8 +import Rel8.Schema.Name ( Selects ) +import Rel8.Table.Serialize ( Serializable ) + + +-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of +-- rows affected, or the actual rows modified. 'Projection' allows you to +-- project out of these returned rows, which can be useful if you want to log +-- exactly which rows were deleted, or to view a generated id (for example, if +-- using a column with an autoincrementing counter as a default value). +type Returning :: Type -> Type -> Type +data Returning names a where + NumberOfRowsAffected :: Returning names Int64 + Projection :: (Selects names exprs, Serializable projection a) + => (exprs -> projection) + -> Returning names [a] diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Select.hs @@ -0,0 +1,62 @@ +{-# language MonoLocalBinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} + +module Rel8.Statement.Select + ( select + , selectWithNames + ) +where + +-- base +import Control.Exception ( throwIO ) +import Prelude + +-- hasql +import Hasql.Connection ( Connection ) +import qualified Hasql.Decoders as Hasql +import qualified Hasql.Encoders as Hasql +import qualified Hasql.Session as Hasql +import qualified Hasql.Statement as Hasql + +-- rel8 +import Rel8.Query ( Query ) +import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames ) +import Rel8.Schema.Name ( Selects ) +import Rel8.Table.Serialize ( Serializable, parse ) + +-- text +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 ) + + +-- | Run a @SELECT@ query, returning all rows. +select :: forall exprs a. Serializable exprs a + => Connection -> Query exprs -> IO [a] +select c query = case sqlForQuery query of + Nothing -> pure [] + Just sql -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 (Text.pack sql) + params = Hasql.noParams + decode = Hasql.rowList (parse @exprs @a) + prepare = False + + +selectWithNames :: forall exprs a names. + ( Selects names exprs + , Serializable exprs a + ) + => Connection -> names -> Query exprs -> IO [a] +selectWithNames c names query = case sqlForQueryWithNames names query of + Nothing -> pure [] + Just sql -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 (Text.pack sql) + params = Hasql.noParams + decode = Hasql.rowList (parse @exprs @a) + prepare = False diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Update.hs @@ -0,0 +1,101 @@ +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} + +module Rel8.Statement.Update + ( Update(..) + , update + ) +where + +-- base +import Control.Exception ( throwIO ) +import Data.Kind ( Type ) +import Prelude + +-- hasql +import Hasql.Connection ( Connection ) +import qualified Hasql.Decoders as Hasql +import qualified Hasql.Encoders as Hasql +import qualified Hasql.Session as Hasql +import qualified Hasql.Statement as Hasql + +-- opaleye +import qualified Opaleye.Internal.Manipulation as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) +import Rel8.Schema.Name ( Selects ) +import Rel8.Schema.Table ( TableSchema ) +import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) ) +import Rel8.Table ( fromColumns, toColumns ) +import Rel8.Table.Opaleye ( castTable, table, unpackspec ) +import Rel8.Table.Serialize ( Serializable, parse ) + +-- text +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 ) + + +-- | The constituent parts of an @UPDATE@ statement. +type Update :: Type -> Type +data Update a where + Update :: Selects names exprs => + { target :: TableSchema names + -- ^ Which table to update. + , set :: exprs -> exprs + -- ^ How to update each selected row. + , updateWhere :: exprs -> Expr Bool + -- ^ Which rows to select for update. + , returning :: Returning names a + -- ^ What to return from the @UPDATE@ statement. + } + -> Update a + + +-- | Run an @UPDATE@ statement. +update :: Connection -> Update a -> IO a +update c Update {target, set, updateWhere, returning} = + case returning of + NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = Hasql.rowsAffected + prepare = False + sql = Opaleye.arrangeUpdateSql target' set' where' + where + target' = table $ toColumns <$> target + set' = toColumns . set . fromColumns + where' = toColumn . toPrimExpr . updateWhere . fromColumns + + Projection project -> Hasql.run session c >>= either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 $ Text.pack sql + params = Hasql.noParams + decode = decoder project + prepare = False + sql = + Opaleye.arrangeUpdateReturningSql + unpackspec + target' + set' + where' + project' + where + target' = table $ toColumns <$> target + set' = toColumns . set . fromColumns + where' = toColumn . toPrimExpr . updateWhere . fromColumns + project' = castTable . toColumns . project . fromColumns + + where + decoder :: forall exprs projection a. Serializable projection a + => (exprs -> projection) -> Hasql.Result [a] + decoder _ = Hasql.rowList (parse @projection @a) diff --git a/src/Rel8/Statement/View.hs b/src/Rel8/Statement/View.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/View.hs @@ -0,0 +1,63 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + +module Rel8.Statement.View + ( createView + ) +where + +-- base +import Control.Exception ( throwIO ) +import Control.Monad ( (>=>) ) +import Data.Foldable ( fold ) +import Data.Maybe ( fromMaybe ) +import Prelude + +-- hasql +import Hasql.Connection ( Connection ) +import qualified Hasql.Decoders as Hasql +import qualified Hasql.Encoders as Hasql +import qualified Hasql.Session as Hasql +import qualified Hasql.Statement as Hasql + +-- rel8 +import Rel8.Query ( Query ) +import Rel8.Query.SQL ( sqlForQueryWithNames ) +import Rel8.Schema.Name ( Selects ) +import Rel8.Schema.Table ( TableSchema( TableSchema ) ) +import Rel8.Table.Alternative ( emptyTable ) + +-- text +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 ) + + +-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@ +-- statement that will save the given query as a view. This can be useful if +-- you want to share Rel8 queries with other applications. +createView :: Selects names exprs + => TableSchema names -> Query exprs -> Connection -> IO () +createView (TableSchema name mschema names) query = + Hasql.run session >=> either throwIO pure + where + session = Hasql.statement () statement + statement = Hasql.Statement bytes params decode prepare + bytes = encodeUtf8 (Text.pack sql) + params = Hasql.noParams + decode = Hasql.noResult + prepare = False + sql = "CREATE VIEW " <> title <> " AS " <> select + where + title = case mschema of + Nothing -> quote name + Just schema -> quote schema <> "." <> quote name + select = fromMaybe fallback $ sqlForQueryWithNames names query + where + fallback = fold $ sqlForQueryWithNames names emptyTable + + +quote :: String -> String +quote string = "\"" <> concatMap go string <> "\"" + where + go '"' = "\"\"" + go c = [c] diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table.hs @@ -0,0 +1,386 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Table + ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify) + , Congruent + , TTable, TColumns, TContext, TUnreify + ) +where + +-- base +import Data.Functor ( ($>) ) +import Data.Functor.Identity ( Identity( Identity ) ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Proxy ( Proxy( Proxy ) ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import GHC.Generics ( Generic, Rep, from, to ) +import Prelude hiding ( null ) + +-- rel8 +import Rel8.FCF ( Eval, Exp ) +import Rel8.Kind.Algebra ( KnownAlgebra ) +import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap ) +import Rel8.Generic.Table + ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns + , GAlgebra + ) +import Rel8.Generic.Record ( Record(..) ) +import Rel8.Generic.Reify ( ARep ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Either ( HEitherTable(..) ) +import Rel8.Schema.HTable.Identity ( HIdentity(..), HType ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.List ( HListTable ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) +import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) +import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify ) +import Rel8.Schema.HTable.These ( HTheseTable(..) ) +import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Reify + ( Reify, Col( Reify ), hreify, hunreify + , UnwrapReify + , notReify + ) +import Rel8.Schema.Result + ( Col( R ), Result + , relabel + , null, nullifier, unnullifier + , vectorizer, unvectorizer + ) +import Rel8.Schema.Spec ( KnownSpec ) +import Rel8.Type ( DBType ) +import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) ) + +-- these +import Data.These ( These( This, That, These ) ) +import Data.These.Combinators ( justHere, justThere ) + + +-- | @Table@s are one of the foundational elements of Rel8, and describe data +-- types that have a finite number of columns. Each of these columns contains +-- data under a shared context, and contexts describe how to interpret the +-- metadata about a column to a particular Haskell type. In Rel8, we have +-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the +-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among +-- others. +-- +-- In typical usage of Rel8 you don't need to derive instances of 'Table' +-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a +-- 'Table'. +type Table :: K.Context -> Type -> Constraint +class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where + -- | The 'HTable' functor that describes the schema of this table. + type Columns a :: K.HTable + + -- | The common context that all columns use as an interpretation. + type Context a :: K.Context + + type Unreify a :: Type + + toColumns :: a -> Columns a (Col context) + fromColumns :: Columns a (Col context) -> a + + reify :: context :~: Reify ctx -> Unreify a -> a + unreify :: context :~: Reify ctx -> a -> Unreify a + + type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a))) + type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a))) + type Unreify a = DefaultUnreify a + + default toColumns :: + ( Generic (Record a) + , KnownAlgebra (GAlgebra (Rep (Record a))) + , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a))) + , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a))) + , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a))) + ) + => a -> Columns a (Col context) + toColumns = + ggtoColumns + @(GAlgebra (Rep (Record a))) + @(TTable context) + @TColumns + id + id + toColumns . + from . + Record + + default fromColumns :: + ( Generic (Record a) + , KnownAlgebra (GAlgebra (Rep (Record a))) + , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a))) + , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a))) + , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a))) + ) + => Columns a (Col context) -> a + fromColumns = + unrecord . + to . + ggfromColumns + @(GAlgebra (Rep (Record a))) + @(TTable context) + @TColumns + id + id + fromColumns + + default reify :: + ( Generic (Record a) + , Generic (Record (Unreify a)) + , GMappable (TTable context) (Rep (Record a)) + , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a)) + ) + => context :~: Reify ctx -> Unreify a -> a + reify Refl = + unrecord . + to . + gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) . + from . + Record + + default unreify :: + ( Generic (Record a) + , Generic (Record (Unreify a)) + , GMappable (TTable context) (Rep (Record a)) + , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a)) + ) + => context :~: Reify ctx -> a -> Unreify a + unreify Refl = + unrecord . + to . + gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) . + from . + Record + + +data TTable :: K.Context -> Type -> Exp Constraint +type instance Eval (TTable context a) = Table context a + + +data TColumns :: Type -> Exp K.HTable +type instance Eval (TColumns a) = Columns a + + +data TContext :: Type -> Exp K.Context +type instance Eval (TContext a) = Context a + + +data TUnreify :: Type -> Exp Type +type instance Eval (TUnreify a) = Unreify a + + +type DefaultUnreify :: Type -> Type +type family DefaultUnreify a where + DefaultUnreify (t a b c d e f g) = + t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g) + DefaultUnreify (t a b c d e f) = + t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) + DefaultUnreify (t a b c d e) = + t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) + DefaultUnreify (t a b c d) = + t (Unreify a) (Unreify b) (Unreify c) (Unreify d) + DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c) + DefaultUnreify (t a b) = t (Unreify a) (Unreify b) + DefaultUnreify (t a) = t (Unreify a) + DefaultUnreify a = ARep (GMap TUnreify (Rep a)) + + +-- | Any 'HTable' is also a 'Table'. +instance HTable t => Table context (t (Col context)) where + type Columns (t (Col context)) = t + type Context (t (Col context)) = context + type Unreify (t (Col context)) = t (Col (UnwrapReify context)) + + toColumns = id + fromColumns = id + + reify Refl = hreify + unreify Refl = hunreify + + +-- | Any context is trivially a table. +instance KnownSpec spec => Table context (Col context spec) where + type Columns (Col context spec) = HIdentity spec + type Context (Col context spec) = context + type Unreify (Col context spec) = Col (UnwrapReify context) spec + + toColumns = HIdentity + fromColumns = unHIdentity + + reify Refl = Reify + unreify Refl (Reify a) = a + + +instance Sql DBType a => Table Result (Identity a) where + type Columns (Identity a) = HType a + type Context (Identity a) = Result + + toColumns (Identity a) = HType (R a) + fromColumns (HType (R a)) = Identity a + + reify = notReify + unreify = notReify + + +instance (Table Result a, Table Result b) => Table Result (Either a b) where + type Columns (Either a b) = HEitherTable (Columns a) (Columns b) + type Context (Either a b) = Result + + toColumns = \case + Left table -> HEitherTable + { htag = HIdentity (R IsLeft) + , hleft = hlabel labeler (hnullify nullifier (toColumns table)) + , hright = hlabel labeler (hnulls (const null)) + } + Right table -> HEitherTable + { htag = HIdentity (R IsRight) + , hleft = hlabel labeler (hnulls (const null)) + , hright = hlabel labeler (hnullify nullifier (toColumns table)) + } + + fromColumns HEitherTable {htag, hleft, hright} = case htag of + HIdentity (R tag) -> case tag of + IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft) + IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright) + where + err = error "Either.fromColumns: mismatch between tag and data" + + +instance Table Result a => Table Result [a] where + type Columns [a] = HListTable (Columns a) + type Context [a] = Result + + toColumns = hvectorize vectorizer . fmap toColumns + fromColumns = fmap fromColumns . hunvectorize unvectorizer + + +instance Table Result a => Table Result (Maybe a) where + type Columns (Maybe a) = HMaybeTable (Columns a) + type Context (Maybe a) = Result + + toColumns = \case + Nothing -> HMaybeTable + { htag = HIdentity (R Nothing) + , hjust = hlabel labeler (hnulls (const null)) + } + Just table -> HMaybeTable + { htag = HIdentity (R (Just IsJust)) + , hjust = hlabel labeler (hnullify nullifier (toColumns table)) + } + + fromColumns HMaybeTable {htag, hjust} = case htag of + HIdentity (R tag) -> tag $> + case hunnullify unnullifier (hunlabel unlabeler hjust) of + Nothing -> error "Maybe.fromColumns: mismatch between tag and data" + Just just -> fromColumns just + + +instance Table Result a => Table Result (NonEmpty a) where + type Columns (NonEmpty a) = HNonEmptyTable (Columns a) + type Context (NonEmpty a) = Result + + toColumns = hvectorize vectorizer . fmap toColumns + fromColumns = fmap fromColumns . hunvectorize unvectorizer + + +instance (Table Result a, Table Result b) => Table Result (These a b) where + type Columns (These a b) = HTheseTable (Columns a) (Columns b) + type Context (These a b) = Result + + toColumns tables = HTheseTable + { hhereTag = relabel hhereTag + , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere)) + , hthereTag = relabel hthereTag + , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere)) + } + where + HMaybeTable + { htag = hhereTag + , hjust = hhere + } = toColumns (justHere tables) + HMaybeTable + { htag = hthereTag + , hjust = hthere + } = toColumns (justThere tables) + + fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = + case (fromColumns mhere, fromColumns mthere) of + (Just a, Nothing) -> This (fromColumns a) + (Nothing, Just b) -> That (fromColumns b) + (Just a, Just b) -> These (fromColumns a) (fromColumns b) + _ -> error "These.fromColumns: mismatch between tags and data" + where + mhere = HMaybeTable + { htag = relabel hhereTag + , hjust = hlabel labeler (hunlabel unlabeler hhere) + } + mthere = HMaybeTable + { htag = relabel hthereTag + , hjust = hlabel labeler (hunlabel unlabeler hthere) + } + + +instance (Table context a, Table context b, Labelable context) + => Table context (a, b) + + +instance + ( Table context a, Table context b, Table context c + , Labelable context + ) + => Table context (a, b, c) + + +instance + ( Table context a, Table context b, Table context c, Table context d + , Labelable context + ) + => Table context (a, b, c, d) + + +instance + ( Table context a, Table context b, Table context c, Table context d + , Table context e + , Labelable context + ) + => Table context (a, b, c, d, e) + + +instance + ( Table context a, Table context b, Table context c, Table context d + , Table context e, Table context f + , Labelable context + ) + => Table context (a, b, c, d, e, f) + + +instance + ( Table context a, Table context b, Table context c, Table context d + , Table context e, Table context f, Table context g + , Labelable context + ) + => Table context (a, b, c, d, e, f, g) + + +type Congruent :: Type -> Type -> Constraint +class Columns a ~ Columns b => Congruent a b +instance Columns a ~ Columns b => Congruent a b diff --git a/src/Rel8/Table/ADT.hs b/src/Rel8/Table/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/ADT.hs @@ -0,0 +1,205 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Table.ADT + ( ADT( ADT ) + , ADTable, fromADT, toADT + , BuildableADT + , BuildADT, buildADT + , ConstructableADT + , ConstructADT, constructADT + , DeconstructADT, deconstructADT + , NameADT, nameADT + , AggregateADT, aggregateADT + , ADTRep + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import GHC.Generics ( Generic, Rep, from, to ) +import GHC.TypeLits ( Symbol ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Construction + ( GGBuildable + , GGBuild, ggbuild + , GGConstructable + , GGConstruct, ggconstruct + , GGDeconstruct, ggdeconstruct + , GGName, ggname + , GGAggregate, ggaggregate + ) +import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap ) +import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord ) +import Rel8.Generic.Rel8able + ( Rel8able + , GRep, GColumns, gfromColumns, gtoColumns + , greify, gunreify + ) +import qualified Rel8.Generic.Table.ADT as G +import qualified Rel8.Kind.Algebra as K +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.HTable ( HTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table + , fromColumns, toColumns, reify, unreify + , TTable, TColumns, TUnreify + ) + + +type ADT :: K.Rel8able -> K.Rel8able +newtype ADT t context = ADT (GColumnsADT t (Col context)) + + +instance ADTable t => Rel8able (ADT t) where + type GColumns (ADT t) = GColumnsADT t + + gfromColumns = ADT + gtoColumns (ADT a) = a + + greify (ADT a) = ADT (hreify a) + gunreify (ADT a) = ADT (hunreify a) + + +instance (ADTable t, context ~ Result) => Generic (ADT t context) where + type Rep (ADT t context) = Rep (t context) + + from = + gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) . + gunrecord @(Rep (t (Reify Result))) . + G.gfromColumnsADT + @(TTable (Reify Result)) + @TColumns + (\(Reify a) -> a) + Reify + fromColumns . + hreify . + (\(ADT a) -> a) + + to = + ADT . + hunreify . + G.gtoColumnsADT + @(TTable (Reify Result)) + @TColumns + (\(Reify a) -> a) + Reify + toColumns . + grecord @(Rep (t (Reify Result))) . + gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl) + + +fromADT :: ADTable t => ADT t Result -> t Result +fromADT = to . from + + +toADT :: ADTable t => t Result -> ADT t Result +toADT = to . from + + +type ADTable :: K.Rel8able -> Constraint +class + ( Generic (t Result) + , HTable (GColumnsADT t) + , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result)))) + , GRecordable (Rep (t (Reify Result))) + , GMappable (TTable (Reify Result)) (Rep (t (Reify Result))) + , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result) + ) + => ADTable t +instance + ( Generic (t Result) + , HTable (GColumnsADT t) + , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result)))) + , GRecordable (Rep (t (Reify Result))) + , GMappable (TTable (Reify Result)) (Rep (t (Reify Result))) + , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result) + ) + => ADTable t + + +type BuildableADT :: K.Rel8able -> Symbol -> Constraint +class GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name +instance GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name + + +type BuildADT :: K.Rel8able -> Symbol -> Type +type BuildADT t name = GGBuild 'K.Sum name (ADTRep t) (ADT t Expr) + + +buildADT :: forall t name. BuildableADT t name => BuildADT t name +buildADT = + ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT + + +type ConstructableADT :: K.Rel8able -> Constraint +class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t +instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t + + +type ConstructADT :: K.Rel8able -> Type +type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r + + +constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr +constructADT f = + ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT + (f @(ADT t Expr)) + + +type DeconstructADT :: K.Rel8able -> Type -> Type +type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r + + +deconstructADT :: forall t r. (ConstructableADT t, Table Expr r) + => DeconstructADT t r +deconstructADT = + ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a) + + +type NameADT :: K.Rel8able -> Type +type NameADT t = GGName 'K.Sum (ADTRep t) (ADT t Name) + + +nameADT :: forall t. ConstructableADT t => NameADT t +nameADT = ggname @'K.Sum @(ADTRep t) @(ADT t Name) ADT + + +type AggregateADT :: K.Rel8able -> Type +type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r + + +aggregateADT :: forall t. ConstructableADT t + => AggregateADT t -> ADT t Expr -> ADT t Aggregate +aggregateADT f = + ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a) + (f @(ADT t Aggregate)) + + +data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type) +type instance Eval (ADTRep t context) = GRep t context + + +type GColumnsADT :: K.Rel8able -> K.HTable +type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result)) diff --git a/src/Rel8/Table/Aggregate.hs b/src/Rel8/Table/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Aggregate.hs @@ -0,0 +1,81 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Aggregate + ( groupBy, hgroupBy + , listAgg, nonEmptyAgg + ) +where + +-- base +import Data.Functor.Identity ( Identity( Identity ) ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate, Aggregates, Col( A ) ) +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Aggregate + ( groupByExpr + , slistAggExpr + , snonEmptyAggExpr + ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable ( HTable, hfield, htabulate ) +import Rel8.Schema.HTable.Vectorize ( hvectorize ) +import Rel8.Schema.Spec ( SSpec( SSpec, info ) ) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType ) +import Rel8.Table ( toColumns, fromColumns ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.List ( ListTable ) +import Rel8.Table.NonEmpty ( NonEmptyTable ) +import Rel8.Type.Eq ( DBEq ) + + +-- | Group equal tables together. This works by aggregating each column in the +-- given table with 'groupByExpr'. +groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs) + => exprs -> aggregates +groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns + + +hgroupBy :: HTable t + => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate) +hgroupBy eqs exprs = fromColumns $ htabulate $ \field -> + case hfield eqs field of + Dict -> case hfield exprs field of + E expr -> A $ groupByExpr expr + + +-- | Aggregate rows into a single row containing an array of all aggregated +-- rows. This can be used to associate multiple rows with a single row, without +-- changing the over cardinality of the query. This allows you to essentially +-- return a tree-like structure from queries. +-- +-- For example, if we have a table of orders and each orders contains multiple +-- items, we could aggregate the table of orders, pairing each order with its +-- items: +-- +-- @ +-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr)) +-- ordersWithItems = do +-- order <- each orderSchema +-- items <- aggregate $ listAgg <$> itemsFromOrder order +-- return (order, items) +-- @ +listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates +listAgg (toColumns -> exprs) = fromColumns $ + hvectorize + (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a) + (pure exprs) + + +-- | Like 'listAgg', but the result is guaranteed to be a non-empty list. +nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates +nonEmptyAgg (toColumns -> exprs) = fromColumns $ + hvectorize + (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a) + (pure exprs) diff --git a/src/Rel8/Table/Alternative.hs b/src/Rel8/Table/Alternative.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Alternative.hs @@ -0,0 +1,37 @@ +{-# language FlexibleContexts #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} + +module Rel8.Table.Alternative + ( AltTable ( (<|>:) ) + , AlternativeTable ( emptyTable ) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Table ( Table ) + + +-- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you +-- to take a choice between two tables. See also 'AlternativeTable'. +-- +-- For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two +-- tables and to return the first one that is a "just" MaybeTable. +type AltTable :: (Type -> Type) -> Constraint +class AltTable f where + -- | An associative binary operation on 'Table's. + (<|>:) :: Table Expr a => f a -> f a -> f a + infixl 3 <|>: + + +-- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative +-- functors. +type AlternativeTable :: (Type -> Type) -> Constraint +class AltTable f => AlternativeTable f where + -- | The identity of '<|>:'. + emptyTable :: Table Expr a => f a diff --git a/src/Rel8/Table/Bool.hs b/src/Rel8/Table/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Bool.hs @@ -0,0 +1,49 @@ +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Bool + ( bool + , case_ + , nullable + ) +where + +-- base +import Prelude + +-- rel8 +import Rel8.Expr ( Expr, Col( E, unE ) ) +import Rel8.Expr.Bool ( boolExpr, caseExpr ) +import Rel8.Expr.Null ( isNull, unsafeUnnullify ) +import Rel8.Schema.HTable ( htabulate, hfield ) +import Rel8.Table ( Table, fromColumns, toColumns ) + + +-- | An if-then-else expression on tables. +-- +-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is +-- @True@. +bool :: Table Expr a => a -> a -> Expr Bool -> a +bool (toColumns -> false) (toColumns -> true) condition = + fromColumns $ htabulate $ \field -> + case (hfield false field, hfield true field) of + (E falseExpr, E trueExpr) -> + E (boolExpr falseExpr trueExpr condition) +{-# INLINABLE bool #-} + + +-- | Produce a table expression from a list of alternatives. Returns the first +-- table where the @Expr Bool@ expression is @True@. If no alternatives are +-- true, the given default is returned. +case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a +case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) = + fromColumns $ htabulate $ \field -> case hfield fallback field of + E fallbackExpr -> + case map (fmap (unE . (`hfield` field))) branches of + branchExprs -> E (caseExpr branchExprs fallbackExpr) + + +-- | Like 'maybe', but to eliminate @null@. +nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b +nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma) diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Either.hs @@ -0,0 +1,248 @@ +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +{-# options_ghc -fno-warn-orphans #-} + +module Rel8.Table.Either + ( EitherTable(..) + , eitherTable, leftTable, rightTable + , isLeftTable, isRightTable + , nameEitherTable + ) +where + +-- base +import Control.Applicative ( liftA2 ) +import Data.Bifunctor ( Bifunctor, bimap ) +import Data.Functor.Identity ( runIdentity ) +import Data.Kind ( Type ) +import Prelude hiding ( undefined ) + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Schema.Context.Label + ( Labelable + , HLabelable, hlabeler, hunlabeler + ) +import Rel8.Schema.Context.Nullify + ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag + , hencodeTag, hdecodeTag + , hnullifier, hunnullifier + ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Either ( HEitherTable(..) ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) +import Rel8.Schema.Name ( Name ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Bool ( bool ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Table.Tag ( Tag(..), fromExpr, fromName ) +import Rel8.Table.Undefined ( undefined ) +import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight ) + +-- semigroupoids +import Data.Functor.Apply ( Apply, (<.>) ) +import Data.Functor.Bind ( Bind, (>>-) ) + + +-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or +-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and +-- 'rightTable', and eliminate/pattern match using 'eitherTable'. +-- +-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but +-- adapted to work with Rel8. +type EitherTable :: Type -> Type -> Type +data EitherTable a b = EitherTable + { tag :: Tag "isRight" EitherTag + , left :: a + , right :: b + } + deriving stock Functor + + +instance Bifunctor EitherTable where + bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b) + + +instance Table Expr a => Apply (EitherTable a) where + EitherTable tag l1 f <.> EitherTable tag' l2 a = + EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a) + + +instance Table Expr a => Applicative (EitherTable a) where + pure = rightTable + (<*>) = (<.>) + + +instance Table Expr a => Bind (EitherTable a) where + EitherTable tag l1 a >>- f = case f a of + EitherTable tag' l2 b -> + EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b + + +instance Table Expr a => Monad (EitherTable a) where + (>>=) = (>>-) + + +instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where + a <> b = bool a b (isRightTable a) + + +instance + ( Table context a, Table context b + , Labelable context, Nullifiable context, ConstrainTag context EitherTag + ) => + Table context (EitherTable a b) + where + type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b) + type Context (EitherTable a b) = Context a + + toColumns = toColumns2 toColumns toColumns + fromColumns = fromColumns2 fromColumns fromColumns + reify = liftA2 bimap reify reify + unreify = liftA2 bimap unreify unreify + + +instance + ( Nullifiable from, Labelable from, ConstrainTag from EitherTag + , Nullifiable to, Labelable to, ConstrainTag to EitherTag + , Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + ) + => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2) + + +instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where + eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b)) + + +instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where + ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b)) + + +type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b) + + +instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) => + ToExprs x (Either a b) + where + fromResult = + bimap (fromResult @exprs1) (fromResult @exprs2) . + fromColumns + toResult = + toColumns . + bimap (toResult @exprs1) (toResult @exprs2) + + +-- | Test if an 'EitherTable' is a 'leftTable'. +isLeftTable :: EitherTable a b -> Expr Bool +isLeftTable = isLeft . expr . tag + + +-- | Test if an 'EitherTable' is a 'rightTable'. +isRightTable :: EitherTable a b -> Expr Bool +isRightTable = isRight . expr . tag + + +-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a +-- 'leftTable' and 'rightTable'. +eitherTable :: Table Expr c + => (a -> c) -> (b -> c) -> EitherTable a b -> c +eitherTable f g EitherTable {tag, left, right} = + bool (f left) (g right) (isRight (expr tag)) + + +-- | Construct a left 'EitherTable'. Like 'Left'. +leftTable :: Table Expr b => a -> EitherTable a b +leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined + + +-- | Construct a right 'EitherTable'. Like 'Right'. +rightTable :: Table Expr a => b -> EitherTable a b +rightTable = rightTableWith undefined + + +rightTableWith :: a -> b -> EitherTable a b +rightTableWith = EitherTable (fromExpr (litExpr IsRight)) + + +-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you +-- have a 'EitherTable' that you are storing in a table and need to construct a +-- 'TableSchema'. +nameEitherTable + :: Name EitherTag + -- ^ The name of the column to track whether a row is a 'leftTable' or + -- 'rightTable'. + -> a + -- ^ Names of the columns in the @a@ table. + -> b + -- ^ Names of the columns in the @b@ table. + -> EitherTable a b +nameEitherTable = EitherTable . fromName + + +toColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context EitherTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> (b -> u context) + -> EitherTable a b + -> HEitherTable t u context +toColumns2 f g EitherTable {tag, left, right} = HEitherTable + { htag + , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left + , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right + } + where + htag = HIdentity (hencodeTag tag) + + +fromColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context EitherTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> (u context -> b) + -> HEitherTable t u context + -> EitherTable a b +fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable + { tag + , left = f $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hleft + , right = g $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hright + } + where + tag = hdecodeTag $ unHIdentity htag diff --git a/src/Rel8/Table/Eq.hs b/src/Rel8/Table/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Eq.hs @@ -0,0 +1,145 @@ +{-# language AllowAmbiguousTypes #-} +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Eq + ( EqTable( eqTable ), (==:), (/=:) + ) +where + +-- base +import Data.Foldable ( foldl' ) +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import GHC.Generics ( Rep ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Bool ( (||.), (&&.) ) +import Rel8.Expr.Eq ( (==.), (/=.) ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Record ( Record ) +import Rel8.Generic.Table + ( GGTable, GGColumns, ggtable + , GAlgebra + ) +import Rel8.Kind.Algebra ( KnownAlgebra ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable + ( HTable, HConstrainTable + , htabulateA, hfield, hdicts + ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ) ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier ) +import Rel8.Table ( Table, Columns, toColumns, TColumns ) +import Rel8.Type.Eq ( DBEq ) + + +-- | The class of 'Table's that can be compared for equality. Equality on +-- tables is defined by equality of all columns all columns, so this class +-- means "all columns in a 'Table' have an instance of 'DBEq'". +type EqTable :: Type -> Constraint +class Table Expr a => EqTable a where + eqTable :: Columns a (Dict (ConstrainDBType DBEq)) + + default eqTable :: + ( KnownAlgebra (GAlgebra (Rep (Record a))) + , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a))) + , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a))) + ) + => Columns a (Dict (ConstrainDBType DBEq)) + eqTable = + ggtable + @(GAlgebra (Rep (Record a))) + @TEqTable + @TColumns + @(Rep (Record a)) + table + nullifier + where + table (_ :: proxy x) = eqTable @x + + +data TEqTable :: Type -> Exp Constraint +type instance Eval (TEqTable a) = EqTable a + + +instance + ( HTable t + , f ~ Col Expr + , HConstrainTable t (ConstrainDBType DBEq) + ) + => EqTable (t f) + where + eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq) + + +instance Sql DBEq a => EqTable (Expr a) where + eqTable = HType Dict + + +instance (EqTable a, EqTable b) => EqTable (a, b) + + +instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) + + +instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d) + + +instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) => + EqTable (a, b, c, d, e) + + +instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) => + EqTable (a, b, c, d, e, f) + + +instance + ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f + , EqTable g + ) + => EqTable (a, b, c, d, e, f, g) + + +-- | Compare two 'Table's for equality. This corresponds to comparing all +-- columns inside each table for equality, and combining all comparisons with +-- @AND@. +(==:) :: forall a. EqTable a => a -> a -> Expr Bool +(toColumns -> as) ==: (toColumns -> bs) = + foldl1' (&&.) $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (eqTable @a) field of + Dict -> Const (pure (a ==. b)) +infix 4 ==: + + +-- | Test if two 'Table's are different. This corresponds to comparing all +-- columns inside each table for inequality, and combining all comparisons with +-- @OR@. +(/=:) :: forall a. EqTable a => a -> a -> Expr Bool +(toColumns -> as) /=: (toColumns -> bs) = + foldl1' (||.) $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (eqTable @a) field of + Dict -> Const (pure (a /=. b)) +infix 4 /=: + + +foldl1' :: (a -> a -> a) -> NonEmpty a -> a +foldl1' f (a :| as) = foldl' f a as diff --git a/src/Rel8/Table/HKD.hs b/src/Rel8/Table/HKD.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/HKD.hs @@ -0,0 +1,268 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Table.HKD + ( HKD( HKD ) + , HKDable, fromHKD, toHKD, HKDT(..) + , BuildableHKD + , BuildHKD, buildHKD + , ConstructableHKD + , ConstructHKD, constructHKD + , DeconstructHKD, deconstructHKD + , NameHKD, nameHKD + , AggregateHKD, aggregateHKD + , HKDRep + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Data.Void ( Void ) +import GHC.Generics ( Generic, Rep, from, to ) +import GHC.TypeLits ( Symbol ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Column ( TColumn ) +import Rel8.Expr ( Expr ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Kind.Algebra ( KnownAlgebra ) +import Rel8.Generic.Construction + ( GGBuildable + , GGBuild, ggbuild + , GGConstructable + , GGConstruct, ggconstruct + , GGDeconstruct, ggdeconstruct + , GGName, ggname + , GGAggregate, ggaggregate + ) +import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap ) +import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord ) +import Rel8.Generic.Rel8able + ( Rel8able + , GColumns, gfromColumns, gtoColumns + , greify, gunreify + , TUnreifyContext + ) +import Rel8.Generic.Table + ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns + , GAlgebra + ) +import Rel8.Schema.Context ( Col ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, Unreify + , fromColumns, toColumns, reify, unreify + , TTable, TColumns, TUnreify + ) +import Rel8.Table.Serialize ( ToExprs, fromResult, toResult ) + + +type GColumnsHKD :: Type -> K.HTable +type GColumnsHKD a = + Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) + + +type HKD :: Type -> K.Rel8able +newtype HKD a f = HKD (GColumnsHKD a (Col f)) + + +instance HKDable a => Rel8able (HKD a) where + type GColumns (HKD a) = GColumnsHKD a + + gfromColumns = HKD + gtoColumns (HKD a) = a + + greify (HKD a) = HKD (hreify a) + gunreify (HKD a) = HKD (hunreify a) + + +instance + ( KnownAlgebra (GAlgebra (Rep a)) + , HTable (GColumnsHKD a) + , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a)))) + , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a + , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f + , GRecordable (GMap (TColumn (Reify f)) (Rep a)) + , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a)) + , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a) + ) + => Generic (HKD a f) + where + type Rep (HKD a f) = GMap (TColumn f) (Rep a) + + from = + gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) . + gunrecord @(GMap (TColumn (Reify f)) (Rep a)) . + ggfromColumns + @(GAlgebra (Rep a)) + @(TTable (Reify f)) + @TColumns + (\(Reify a) -> a) + Reify + fromColumns . + hreify . + (\(HKD a) -> a) + + to = + HKD . + hunreify . + ggtoColumns + @(GAlgebra (Rep a)) + @(TTable (Reify f)) + @TColumns + (\(Reify a) -> a) + Reify + toColumns . + grecord @(GMap (TColumn (Reify f)) (Rep a)) . + gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl) + + +type HKDT :: Type -> Type +newtype HKDT a = HKDT + { unHKDT :: a + } + + +instance HKDable a => Table Result (HKDT a) where + type Columns (HKDT a) = GColumnsHKD a + type Context (HKDT a) = Result + type Unreify (HKDT a) = Void + + fromColumns = HKDT . fromHKD . HKD + toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a) + reify = notReify + unreify = notReify + + +instance + ( Table Expr (HKD a Expr) + , Columns (HKD a Expr) ~ GColumns (HKD a) + , HKDable a + , x ~ HKD a Expr + ) + => ToExprs x (HKDT a) + where + toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a) + fromResult = HKDT . fromHKD . HKD + + +fromHKD :: HKDable a => HKD a Result -> a +fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from + + +toHKD :: HKDable a => a -> HKD a Result +toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from + + +class Top_ +instance Top_ + + +data Top :: Type -> Exp Constraint +type instance Eval (Top _) = Top_ + + +class + ( Generic a + , HTable (GColumns (HKD a)) + , KnownAlgebra (GAlgebra (Rep a)) + , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) + , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result + , GRecordable (GMap (TColumn (Reify Result)) (Rep a)) + , GMappable Top (Rep a) + , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a)) + , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a) + ) + => HKDable a +instance + ( Generic a + , HTable (GColumns (HKD a)) + , KnownAlgebra (GAlgebra (Rep a)) + , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) + , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result + , GRecordable (GMap (TColumn (Reify Result)) (Rep a)) + , GMappable Top (Rep a) + , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a)) + , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a) + ) + => HKDable a + + +type BuildableHKD :: Type -> Symbol -> Constraint +class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name +instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name + + +type BuildHKD :: Type -> Symbol -> Type +type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr) + + +buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name +buildHKD = + ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD + + +type ConstructableHKD :: Type -> Constraint +class GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a +instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a + + +type ConstructHKD :: Type -> Type +type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r + + +constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr +constructHKD f = + ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD + (f @(HKD a Expr)) + + +type DeconstructHKD :: Type -> Type -> Type +type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r + + +deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r) + => DeconstructHKD a r +deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a) + + +type NameHKD :: Type -> Type +type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name) + + +nameHKD :: forall a. ConstructableHKD a => NameHKD a +nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD + + +type AggregateHKD :: Type -> Type +type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r + + +aggregateHKD :: forall a. ConstructableHKD a + => AggregateHKD a -> HKD a Expr -> HKD a Aggregate +aggregateHKD f = + ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a) + (f @(HKD a Aggregate)) + + +data HKDRep :: Type -> K.Context -> Exp (Type -> Type) +type instance Eval (HKDRep a context) = + GRecord (GMap (TColumn context) (Rep a)) diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/List.hs @@ -0,0 +1,139 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Table.List + ( ListTable(..) + , listTable, nameListTable + ) +where + +-- base +import Data.Functor.Identity ( Identity( Identity ) ) +import Data.Kind ( Type ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr, Col( E, unE ) ) +import Rel8.Expr.Array ( sappend, sempty, slistOf ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable.List ( HListTable ) +import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize ) +import Rel8.Schema.Name ( Col( N ), Name( Name ) ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Spec ( SSpec(..) ) +import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity ) +import Rel8.Schema.Reify ( hreify, hunreify ) +import Rel8.Table + ( Table, Context, Columns, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Alternative + ( AltTable, (<|>:) + , AlternativeTable, emptyTable + ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Table.Unreify ( Unreifies ) + + +-- | A @ListTable@ value contains zero or more instances of @a@. You construct +-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'. +type ListTable :: Type -> Type +newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a))) + + +instance (Table context a, Unreifies context a) => + Table context (ListTable a) + where + type Columns (ListTable a) = HListTable (Columns a) + type Context (ListTable a) = Context a + + fromColumns = ListTable + toColumns (ListTable a) = a + + reify Refl (ListTable a) = ListTable (hreify a) + unreify Refl (ListTable a) = ListTable (hunreify a) + + +instance + ( Unreifies from a, Unreifies to b + , Recontextualize from to a b + ) + => Recontextualize from to (ListTable a) (ListTable b) + + +instance EqTable a => EqTable (ListTable a) where + eqTable = + hvectorize + (\SSpec {} (Identity dict) -> case dbTypeDict dict of + Dict -> case dbTypeNullity dict of + Null -> Dict + NotNull -> Dict) + (Identity (eqTable @a)) + + +instance OrdTable a => OrdTable (ListTable a) where + ordTable = + hvectorize + (\SSpec {} (Identity dict) -> case dbTypeDict dict of + Dict -> case dbTypeNullity dict of + Null -> Dict + NotNull -> Dict) + (Identity (ordTable @a)) + + +type instance FromExprs (ListTable a) = [FromExprs a] + + +instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where + fromResult = fmap (fromResult @exprs) . fromColumns + toResult = toColumns . fmap (toResult @exprs) + + +instance AltTable ListTable where + (<|>:) = (<>) + + +instance AlternativeTable ListTable where + emptyTable = mempty + + +instance Table Expr a => Semigroup (ListTable a) where + ListTable as <> ListTable bs = ListTable $ + happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs + + +instance Table Expr a => Monoid (ListTable a) where + mempty = ListTable $ hempty $ \_ -> E . sempty + + +-- | Construct a @ListTable@ from a list of expressions. +listTable :: Table Expr a => [a] -> ListTable a +listTable = + ListTable . + hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) . + fmap toColumns + + +-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you +-- have a 'ListTable' that you are storing in a table and need to construct a +-- 'TableSchema'. +nameListTable + :: Table Name a + => a -- ^ The names of the columns of elements of the list. + -> ListTable a +nameListTable = + ListTable . + hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) . + pure . + toColumns diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Maybe.hs @@ -0,0 +1,254 @@ +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Table.Maybe + ( MaybeTable(..) + , maybeTable, nothingTable, justTable + , isNothingTable, isJustTable + , ($?) + , nameMaybeTable + ) +where + +-- base +import Data.Functor.Identity ( runIdentity ) +import Data.Kind ( Type ) +import Prelude hiding ( null, undefined ) + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Bool ( boolExpr ) +import Rel8.Expr.Null ( isNull, isNonNull, null, nullify ) +import Rel8.Schema.Context.Label + ( Labelable, HLabelable, hlabeler, hunlabeler + ) +import Rel8.Schema.Context.Nullify + ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag + , hencodeTag, hdecodeTag + , hnullifier, hunnullifier + ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) +import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Alternative + ( AltTable, (<|>:) + , AlternativeTable, emptyTable + ) +import Rel8.Table.Bool ( bool ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Table.Tag ( Tag(..), fromExpr, fromName ) +import Rel8.Table.Undefined ( undefined ) +import Rel8.Type ( DBType ) +import Rel8.Type.Tag ( MaybeTag ) + +-- semigroupoids +import Data.Functor.Apply ( Apply, (<.>) ) +import Data.Functor.Bind ( Bind, (>>-) ) + + +-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If +-- the outer join fails to match any rows, this is essentialy @Nothing@, and if +-- the outer join does match rows, this is like @Just@. Unfortunately, SQL +-- makes it impossible to distinguish whether or not an outer join matched any +-- rows based generally on the row contents - if you were to join a row +-- entirely of nulls, you can't distinguish if you matched an all null row, or +-- if the match failed. For this reason @MaybeTable@ contains an extra field - +-- a "nullTag" - to track whether or not the outer join produced any rows. +type MaybeTable :: Type -> Type +data MaybeTable a = MaybeTable + { tag :: Tag "isJust" (Maybe MaybeTag) + , just :: a + } + deriving stock Functor + + +instance Apply MaybeTable where + MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a) + + +-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also: +-- 'Rel8.traverseMaybeTable'. +instance Applicative MaybeTable where + (<*>) = (<.>) + pure = justTable + + +instance Bind MaybeTable where + MaybeTable tag a >>- f = case f a of + MaybeTable tag' b -> MaybeTable (tag <> tag') b + + +-- | Has the same behavior as the @Monad@ instance for @Maybe@. +instance Monad MaybeTable where + (>>=) = (>>-) + + +instance AltTable MaybeTable where + ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable + { tag = (tag <> tag') + { expr = boolExpr (expr tag) (expr tag') condition + } + , just = bool a b condition + } + where + condition = isNothingTable ma + + +instance AlternativeTable MaybeTable where + emptyTable = nothingTable + + +instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where + ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma + + +instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where + mempty = nothingTable + + +instance + ( Table context a + , Labelable context, Nullifiable context + , ConstrainTag context MaybeTag + ) => Table context (MaybeTable a) + where + type Columns (MaybeTable a) = HMaybeTable (Columns a) + type Context (MaybeTable a) = Context a + + toColumns = toColumns1 toColumns + fromColumns = fromColumns1 fromColumns + reify = fmap fmap reify + unreify = fmap fmap unreify + + +instance + ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag + , Labelable to, Nullifiable to, ConstrainTag to MaybeTag + , Recontextualize from to a b + ) + => Recontextualize from to (MaybeTable a) (MaybeTable b) + + +instance EqTable a => EqTable (MaybeTable a) where + eqTable = toColumns1 id (justTable (eqTable @a)) + + +instance OrdTable a => OrdTable (MaybeTable a) where + ordTable = toColumns1 id (justTable (ordTable @a)) + + +type instance FromExprs (MaybeTable a) = Maybe (FromExprs a) + + +instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where + fromResult = fmap (fromResult @exprs) . fromColumns + toResult = toColumns . fmap (toResult @exprs) + + +-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'. +isNothingTable :: MaybeTable a -> Expr Bool +isNothingTable (MaybeTable tag _) = isNull (expr tag) + + +-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'. +isJustTable :: MaybeTable a -> Expr Bool +isJustTable (MaybeTable tag _) = isNonNull (expr tag) + + +-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'. +maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b +maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma) +{-# INLINABLE maybeTable #-} + + +-- | The null table. Like 'Nothing'. +nothingTable :: Table Expr a => MaybeTable a +nothingTable = MaybeTable (fromExpr null) undefined + + +-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use +-- 'pure'. +justTable :: a -> MaybeTable a +justTable = MaybeTable (fromExpr mempty) + + +-- | Project a single expression out of a 'MaybeTable'. You can think of this +-- operator like the '$' operator, but it also has the ability to return +-- @null@. +($?) :: forall a b. Sql DBType b + => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b) +f $? ma@(MaybeTable _ a) = case nullable @b of + Null -> boolExpr (f a) null (isNothingTable ma) + NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma) +infixl 4 $? + + +-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you +-- have a 'MaybeTable' that you are storing in a table and need to construct a +-- 'TableSchema'. +nameMaybeTable + :: Name (Maybe MaybeTag) + -- ^ The name of the column to track whether a row is a 'justTable' or + -- 'nothingTable'. + -> a + -- ^ Names of the columns in @a@. + -> MaybeTable a +nameMaybeTable = MaybeTable . fromName + + +toColumns1 :: + ( HTable t + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> MaybeTable a + -> HMaybeTable t context +toColumns1 f MaybeTable {tag, just} = HMaybeTable + { htag + , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just + } + where + htag = HIdentity (hencodeTag tag) + + +fromColumns1 :: + ( HTable t + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> HMaybeTable t context + -> MaybeTable a +fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable + { tag + , just = f $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust) + } + where + tag = hdecodeTag htag diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Name.hs @@ -0,0 +1,84 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Name + ( namesFromLabels + , namesFromLabelsWith + , showExprs + , showLabels + , showNames + ) +where + +-- base +import Data.Foldable ( fold ) +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.List.NonEmpty ( NonEmpty, intersperse ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Opaleye ( toPrimExpr ) +import Rel8.Kind.Labels ( renderLabels ) +import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs ) +import Rel8.Schema.Name ( Name( Name ), Col( N ) ) +import Rel8.Schema.Spec ( SSpec(..) ) +import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns ) + + +-- | Construct a table in the 'Name' context containing the names of all +-- columns. Nested column names will be combined with @/@. +-- +-- See also: 'namesFromLabelsWith'. +namesFromLabels :: Table Name a => a +namesFromLabels = namesFromLabelsWith go + where + go = fold . intersperse "/" + + +-- | Construct a table in the 'Name' context containing the names of all +-- columns. The supplied function can be used to transform column names. +-- +-- This function can be used to generically derive the columns for a +-- 'TableSchema'. For example, +-- +-- @ +-- myTableSchema :: TableSchema (MyTable Name) +-- myTableSchema = TableSchema +-- { columns = namesFromLabelsWith last +-- } +-- @ +-- +-- will construct a 'TableSchema' where each columns names exactly corresponds +-- to the name of the Haskell field. +namesFromLabelsWith :: Table Name a + => (NonEmpty String -> String) -> a +namesFromLabelsWith f = fromColumns $ htabulate $ \field -> + case hfield hspecs field of + SSpec {labels} -> N (Name (f (renderLabels labels))) + + +showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)] +showExprs as = case (namesFromLabels, toColumns as) of + (names, exprs) -> getConst $ htabulateA $ \field -> + case (hfield names field, hfield exprs field) of + (N (Name name), E expr) -> Const [(name, toPrimExpr expr)] + + +showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String] +showLabels _ = getConst $ + htabulateA @(Columns a) $ \field -> case hfield hspecs field of + SSpec {labels} -> Const [renderLabels labels] + + +showNames :: forall a. Table Name a => a -> [String] +showNames (toColumns -> names) = getConst $ + htabulateA @(Columns a) $ \field -> case hfield names field of + N (Name name) -> Const [name] diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/NonEmpty.hs @@ -0,0 +1,131 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Table.NonEmpty + ( NonEmptyTable(..) + , nonEmptyTable, nameNonEmptyTable + ) +where + +-- base +import Data.Functor.Identity ( Identity( Identity ) ) +import Data.Kind ( Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr, Col( E, unE ) ) +import Rel8.Expr.Array ( sappend1, snonEmptyOf ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) +import Rel8.Schema.HTable.Vectorize ( happend, hvectorize ) +import Rel8.Schema.Name ( Col( N ), Name( Name ) ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Reify ( hreify, hunreify ) +import Rel8.Schema.Spec ( SSpec(..) ) +import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity ) +import Rel8.Table + ( Table, Context, Columns, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Alternative ( AltTable, (<|>:) ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Table.Unreify ( Unreifies ) + + +-- | A @NonEmptyTable@ value contains one or more instances of @a@. You +-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'. +type NonEmptyTable :: Type -> Type +newtype NonEmptyTable a = + NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a))) + + +instance (Table context a, Unreifies context a) => + Table context (NonEmptyTable a) + where + type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a) + type Context (NonEmptyTable a) = Context a + + fromColumns = NonEmptyTable + toColumns (NonEmptyTable a) = a + + reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a) + unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a) + + +instance + ( Unreifies from a, Unreifies to b + , Recontextualize from to a b + ) + => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b) + + +instance EqTable a => EqTable (NonEmptyTable a) where + eqTable = + hvectorize + (\SSpec {} (Identity dict) -> case dbTypeDict dict of + Dict -> case dbTypeNullity dict of + Null -> Dict + NotNull -> Dict) + (Identity (eqTable @a)) + + +instance OrdTable a => OrdTable (NonEmptyTable a) where + ordTable = + hvectorize + (\SSpec {} (Identity dict) -> case dbTypeDict dict of + Dict -> case dbTypeNullity dict of + Null -> Dict + NotNull -> Dict) + (Identity (ordTable @a)) + + +type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a) + + +instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a) + where + fromResult = fmap (fromResult @exprs) . fromColumns + toResult = toColumns . fmap (toResult @exprs) + + +instance AltTable NonEmptyTable where + (<|>:) = (<>) + + +instance Table Expr a => Semigroup (NonEmptyTable a) where + NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $ + happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs + + +-- | Construct a @NonEmptyTable@ from a non-empty list of expressions. +nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a +nonEmptyTable = + NonEmptyTable . + hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) . + fmap toColumns + + +-- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if +-- you have a 'NonEmptyTable' that you are storing in a table and need to +-- construct a 'TableSchema'. +nameNonEmptyTable + :: Table Name a + => a -- ^ The names of the columns of elements of the list. + -> NonEmptyTable a +nameNonEmptyTable = + NonEmptyTable . + hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) . + pure . + toColumns diff --git a/src/Rel8/Table/Opaleye.hs b/src/Rel8/Table/Opaleye.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Opaleye.hs @@ -0,0 +1,136 @@ +{-# language BlockArguments #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Opaleye + ( aggregator + , binaryspec + , distinctspec + , table + , tableFields + , unpackspec + , valuesspec + , castTable + ) +where + +-- base +import Prelude hiding ( undefined ) + +-- opaleye +import qualified Opaleye.Internal.Aggregate as Opaleye +import qualified Opaleye.Internal.Binary as Opaleye +import qualified Opaleye.Internal.Distinct as Opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.PackMap as Opaleye +import qualified Opaleye.Internal.Unpackspec as Opaleye +import qualified Opaleye.Internal.Values as Opaleye +import qualified Opaleye.Internal.Table as Opaleye + +-- profunctors +import Data.Profunctor ( dimap, lmap ) + +-- rel8 +import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates ) +import Rel8.Expr ( Expr, Col(..) ) +import Rel8.Expr.Opaleye + ( fromPrimExpr, toPrimExpr + , traversePrimExpr + , fromColumn, toColumn + , scastExpr + ) +import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate ) +import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects ) +import Rel8.Schema.Spec ( SSpec(..) ) +import Rel8.Schema.Table ( TableSchema(..) ) +import Rel8.Table ( Table, fromColumns, toColumns ) +import Rel8.Table.Undefined ( undefined ) + +-- semigroupoids +import Data.Functor.Apply ( WrappedApplicative(..) ) + + +aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs +aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates -> + fmap fromColumns $ unwrapApplicative $ htabulateA $ \field -> + WrapApplicative $ case hfield (toColumns aggregates) field of + A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> + E <$> inner f () + + +binaryspec :: Table Expr a => Opaleye.Binaryspec a a +binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) -> + fmap fromColumns $ unwrapApplicative $ htabulateA $ \field -> + WrapApplicative $ + case (hfield (toColumns as) field, hfield (toColumns bs) field) of + (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b) + + +distinctspec :: Table Expr a => Opaleye.Distinctspec a a +distinctspec = + Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f -> + fmap fromColumns . + unwrapApplicative . + htraverse + (\(E a) -> + WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) . + toColumns + + +table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs +table (TableSchema name schema columns) = + case schema of + Nothing -> Opaleye.Table name (tableFields columns) + Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns) + + +tableFields ::Selects names exprs + => names -> Opaleye.TableFields exprs exprs +tableFields (toColumns -> names) = dimap toColumns fromColumns $ + unwrapApplicative $ htabulateA $ \field -> WrapApplicative $ + case hfield names field of + name -> lmap (`hfield` field) (go name) + where + go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec) + go (N (Name name)) = + lmap (\(E a) -> toColumn $ toPrimExpr a) $ + E . fromPrimExpr . fromColumn <$> + Opaleye.requiredTableField name + + +unpackspec :: Table Expr a => Opaleye.Unpackspec a a +unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f -> + fmap fromColumns . + unwrapApplicative . + htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) . + toColumns +{-# INLINABLE unpackspec #-} + + +valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a +valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec + + +toPackMap :: Table Expr a + => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a +toPackMap as = Opaleye.PackMap $ \f () -> + fmap fromColumns $ + unwrapApplicative . + htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $ + toColumns as + + +-- | Transform a table by adding 'CAST' to all columns. This is most useful for +-- finalising a SELECT or RETURNING statement, guaranteed that the output +-- matches what is encoded in each columns TypeInformation. +castTable :: Table Expr a => a -> a +castTable (toColumns -> as) = fromColumns $ htabulate \i -> + case hfield hspecs i of + SSpec{info} -> + case hfield as i of + E expr -> + E (scastExpr info expr) diff --git a/src/Rel8/Table/Ord.hs b/src/Rel8/Table/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Ord.hs @@ -0,0 +1,183 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} +{-# language ViewPatterns #-} + +module Rel8.Table.Ord + ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest + ) +where + +-- base +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Kind ( Constraint, Type ) +import GHC.Generics ( Rep ) +import Prelude hiding ( seq ) + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Bool ( (||.), (&&.), false, true ) +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Expr.Ord ( (<.), (>.) ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Record ( Record ) +import Rel8.Generic.Table + ( GGTable, GGColumns, ggtable + , GAlgebra + ) +import Rel8.Kind.Algebra ( KnownAlgebra ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable + ( HTable, HConstrainTable + , htabulateA, hfield, hdicts + ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ) ) +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier ) +import Rel8.Table ( Columns, toColumns, TColumns ) +import Rel8.Table.Bool ( bool ) +import Rel8.Table.Eq ( EqTable ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type.Ord ( DBOrd ) + + +-- | The class of 'Table's that can be ordered. Ordering on tables is defined +-- by their lexicographic ordering of all columns, so this class means "all +-- columns in a 'Table' have an instance of 'DBOrd'". +type OrdTable :: Type -> Constraint +class EqTable a => OrdTable a where + ordTable :: Columns a (Dict (ConstrainDBType DBOrd)) + + default ordTable :: + ( KnownAlgebra (GAlgebra (Rep (Record a))) + , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a))) + , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a))) + ) + => Columns a (Dict (ConstrainDBType DBOrd)) + ordTable = + ggtable + @(GAlgebra (Rep (Record a))) + @TOrdTable + @TColumns + @(Rep (Record a)) + table + nullifier + where + table (_ :: proxy x) = ordTable @x + + +data TOrdTable :: Type -> Exp Constraint +type instance Eval (TOrdTable a) = OrdTable a + + +instance + ( HTable t + , f ~ Col Expr + , HConstrainTable t (ConstrainDBType DBEq) + , HConstrainTable t (ConstrainDBType DBOrd) + ) + => OrdTable (t f) + where + ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd) + + +instance Sql DBOrd a => OrdTable (Expr a) where + ordTable = HType Dict + + +instance (OrdTable a, OrdTable b) => OrdTable (a, b) + + +instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) + + +instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d) + + +instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) => + OrdTable (a, b, c, d, e) + + +instance + ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f + ) + => OrdTable (a, b, c, d, e, f) + + +instance + ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f + , OrdTable g + ) + => OrdTable (a, b, c, d, e, f, g) + + +-- | Test if one 'Table' sorts before another. Corresponds to comparing all +-- columns with '<'. +(<:) :: forall a. OrdTable a => a -> a -> Expr Bool +(toColumns -> as) <: (toColumns -> bs) = + foldr @[] go false $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (ordTable @a) field of + Dict -> Const [(a <. b, a ==. b)] + where + go (lt, eq) a = lt ||. (eq &&. a) +infix 4 <: + + +-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to +-- comparing all columns with '<='. +(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool +(toColumns -> as) <=: (toColumns -> bs) = + foldr @[] go true $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (ordTable @a) field of + Dict -> Const [(a <. b, a ==. b)] + where + go (lt, eq) a = lt ||. (eq &&. a) +infix 4 <=: + + +-- | Test if one 'Table' sorts after another. Corresponds to comparing all +-- columns with '>'. +(>:) :: forall a. OrdTable a => a -> a -> Expr Bool +(toColumns -> as) >: (toColumns -> bs) = + foldr @[] go false $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (ordTable @a) field of + Dict -> Const [(a >. b, a ==. b)] + where + go (gt, eq) a = gt ||. (eq &&. a) +infix 4 >: + + +-- | Test if one 'Table' sorts after another. Corresponds to comparing all +-- columns with '>='. +(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool +(toColumns -> as) >=: (toColumns -> bs) = + foldr @[] go true $ getConst $ htabulateA $ \field -> + case (hfield as field, hfield bs field) of + (E a, E b) -> case hfield (ordTable @a) field of + Dict -> Const [(a >. b, a ==. b)] + where + go (gt, eq) a = gt ||. (eq &&. a) +infix 4 >=: + + +-- | Given two 'Table's, return the table that sorts before the other. +least :: OrdTable a => a -> a -> a +least a b = bool a b (a <: b) + + +-- | Given two 'Table's, return the table that sorts after the other. +greatest :: OrdTable a => a -> a -> a +greatest a b = bool a b (a >: b) diff --git a/src/Rel8/Table/Order.hs b/src/Rel8/Table/Order.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Order.hs @@ -0,0 +1,53 @@ +{-# language DataKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} + +module Rel8.Table.Order + ( ascTable + , descTable + ) +where + +-- base +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Functor.Contravariant ( (>$<), contramap ) +import Prelude + +-- rel8 +import Rel8.Expr ( unE ) +import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast ) +import Rel8.Order ( Order ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.HTable (htabulateA, hfield, hspecs) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Spec ( SSpec( SSpec ) ) +import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity ) +import Rel8.Table ( Columns, toColumns ) +import Rel8.Table.Ord + + +-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending +-- orders (any nullable columns will be sorted with @NULLS FIRST@). +ascTable :: forall a. OrdTable a => Order a +ascTable = contramap toColumns $ getConst $ + htabulateA @(Columns a) $ \field -> case hfield hspecs field of + SSpec {} -> case hfield (ordTable @a) field of + dict@Dict -> case dbTypeDict dict of + Dict -> Const $ unE . (`hfield` field) >$< + case dbTypeNullity dict of + Null -> nullsFirst asc + NotNull -> asc + + +-- | Construct an 'Order' for a 'Table' by sorting all columns into descending +-- orders (any nullable columns will be sorted with @NULLS LAST@). +descTable :: forall a. OrdTable a => Order a +descTable = contramap toColumns $ getConst $ + htabulateA @(Columns a) $ \field -> case hfield hspecs field of + SSpec {} -> case hfield (ordTable @a) field of + dict@Dict -> case dbTypeDict dict of + Dict -> Const $ unE . (`hfield` field) >$< + case dbTypeNullity dict of + Null -> nullsLast desc + NotNull -> desc diff --git a/src/Rel8/Table/Recontextualize.hs b/src/Rel8/Table/Recontextualize.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Recontextualize.hs @@ -0,0 +1,90 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} + +module Rel8.Table.Recontextualize + ( Recontextualize + ) +where + +-- base +import Data.Functor.Identity ( Identity ) +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- rel8 +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.Context.Label ( Labelable ) +import Rel8.Schema.HTable ( HTable ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null ( Sql ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table ( Table, Congruent ) +import Rel8.Type ( DBType ) + + +-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are +-- related, and that @b@ is the same type as @a@, but after changing the +-- context from the initial context @from@, to the new context @to@. +type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint +class + ( Table from a + , Table to b + , Congruent a b + , Recontextualize from from a a + , Recontextualize to to b b + , Recontextualize to from b a + ) => Recontextualize from to a b + | a -> from + , b -> to + , a to -> b + , b from -> a + + +instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a) + + +instance HTable t => Recontextualize from to (t (Col from)) (t (Col to)) + + +instance + ( Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + , Labelable from + , Labelable to + ) + => Recontextualize from to (a1, a2) (b1, b2) + + +instance + ( Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + , Recontextualize from to a3 b3 + , Labelable from, Labelable to + ) + => Recontextualize from to (a1, a2, a3) (b1, b2, b3) + + +instance + ( Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + , Recontextualize from to a3 b3 + , Recontextualize from to a4 b4 + , Labelable from, Labelable to + ) + => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4) + + +instance + ( Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + , Recontextualize from to a3 b3 + , Recontextualize from to a4 b4 + , Recontextualize from to a5 b5 + , Labelable from, Labelable to + ) + => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) diff --git a/src/Rel8/Table/Rel8able.hs b/src/Rel8/Table/Rel8able.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Rel8able.hs @@ -0,0 +1,148 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +{-# options_ghc -fno-warn-orphans #-} + +module Rel8.Table.Rel8able + ( + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.Type.Equality ( (:~:)( Refl ) ) +import Prelude + +-- rel8 +import Rel8.Expr ( Expr ) +import qualified Rel8.Kind.Algebra as K +import Rel8.Kind.Context + ( SContext( SReify ) + , Reifiable, contextSing + , sLabelable, sReifiable + ) +import Rel8.Generic.Rel8able + ( Rel8able, Algebra + , GColumns, gfromColumns, gtoColumns + , greify, gunreify + ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.Context.Label ( Labelable ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.HTable ( HConstrainTable, hdicts ) +import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table + ( Table, Columns, Context, Congruent, fromColumns, toColumns + , Unreify, reify, unreify + ) +import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType ) +import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.HKD ( HKD ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type.Ord ( DBOrd ) + + +instance (Rel8able t, Labelable context, Reifiable context) => + Table context (t context) + where + type Columns (t context) = GColumns t + type Context (t context) = context + type Unreify (t context) = t (UnwrapReify context) + + fromColumns = gunreify . gfromColumns . hreify + toColumns = hunreify . gtoColumns . greify + + reify Refl = case contextSing @context of + SReify context -> case sLabelable context of + Dict -> case sReifiable context of + Dict -> greify + + unreify Refl = case contextSing @context of + SReify context -> case sLabelable context of + Dict -> case sReifiable context of + Dict -> gunreify + + +instance + ( Rel8able t + , Labelable from, Reifiable from + , Labelable to, Reifiable to + , Congruent (t from) (t to) + ) + => Recontextualize from to (t from) (t to) + + +instance + ( context ~ Expr + , Rel8able t + , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq) + ) + => EqTable (t context) + where + eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq) + + +instance + ( context ~ Expr + , Rel8able t + , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq) + , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd) + ) + => OrdTable (t context) + where + ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd) + + +type instance FromExprs (t Expr) = FromExprs' t + + +instance + ( x ~ t' Expr + , result ~ Result + , ToExprs' (Algebra t) t' t + ) + => ToExprs x (t result) + where + fromResult = fromResult' @(Algebra t) @t' + toResult = toResult' @(Algebra t) @t' + + +type FromExprs' :: K.Rel8able -> Type +type family FromExprs' t where + FromExprs' (ADT t) = t Result + FromExprs' (HKD a) = a + FromExprs' t = t Result + + +type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint +class (algebra ~ Algebra t, Rel8able t') => + ToExprs' algebra t' t | algebra t -> t' + where + fromResult' :: GColumns t' (Col Result) -> t Result + toResult' :: t Result -> GColumns t' (Col Result) + + +instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') => + ToExprs' 'K.Product t' t + where + fromResult' = fromColumns + toResult' = toColumns + + +instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) => + ToExprs' 'K.Sum t' t + where + fromResult' = fromADT . ADT + toResult' = (\(ADT a) -> a) . toADT diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Serialize.hs @@ -0,0 +1,248 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Table.Serialize + ( Serializable, lit, parse + , ToExprs(..), FromExprs + , TToExprs + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) +import GHC.Generics ( Generic, Rep, from, to ) +import Prelude + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Serialize ( slitExpr, sparseValue ) +import Rel8.FCF ( Eval, Exp ) +import Rel8.Generic.Record ( Record(..) ) +import Rel8.Generic.Table + ( GGToExprs, GGColumns, ggfromResult, ggtoResult + , GAlgebra + ) +import Rel8.Kind.Algebra ( KnownAlgebra ) +import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs ) +import Rel8.Schema.HTable.Identity ( HIdentity( HType ) ) +import Rel8.Schema.Null ( NotNull, Sql ) +import Rel8.Schema.Result ( Col( R ), Result ) +import Rel8.Schema.Spec ( SSpec(..), KnownSpec ) +import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns ) +import Rel8.Type ( DBType ) + +-- semigroupoids +import Data.Functor.Apply ( WrappedApplicative(..) ) + + +-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe +-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is +-- in the 'Result' context. +type ToExprs :: Type -> Type -> Constraint +class Table Expr exprs => ToExprs exprs a where + fromResult :: Columns exprs (Col Result) -> a + toResult :: a -> Columns exprs (Col Result) + + default fromResult :: + ( Generic (Record a) + , KnownAlgebra (GAlgebra (Rep (Record exprs))) + , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a))) + , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs))) + ) + => Columns exprs (Col Result) -> a + fromResult = + unrecord . + to . + ggfromResult + @(GAlgebra (Rep (Record exprs))) + @TToExprs + @TColumns + @(Rep (Record exprs)) + (\(_ :: proxy expr) -> fromResult @expr) + + default toResult :: + ( Generic (Record a) + , KnownAlgebra (GAlgebra (Rep (Record exprs))) + , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a))) + , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs))) + ) + => a -> Columns exprs (Col Result) + toResult = + ggtoResult + @(GAlgebra (Rep (Record exprs))) + @TToExprs + @TColumns + @(Rep (Record exprs)) + (\(_ :: proxy expr) -> toResult @expr) . + from . + Record + + +data TToExprs :: Type -> Type -> Exp Constraint +type instance Eval (TToExprs exprs a) = ToExprs exprs a + + +instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where + fromResult (HType (R a)) = a + toResult = HType . R + + +instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where + fromResult (HType (R a)) = a + toResult = HType . R + + +instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a) + where + fromResult (HType (R a)) = a + toResult = HType . R + + +instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a) + where + fromResult (HType (R a)) = a + toResult = HType . R + + +instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) => + ToExprs x (a, b) + + +instance + ( ToExprs exprs1 a + , ToExprs exprs2 b + , ToExprs exprs3 c + , x ~ (exprs1, exprs2, exprs3) + ) + => ToExprs x (a, b, c) + + +instance + ( ToExprs exprs1 a + , ToExprs exprs2 b + , ToExprs exprs3 c + , ToExprs exprs4 d + , x ~ (exprs1, exprs2, exprs3, exprs4) + ) + => ToExprs x (a, b, c, d) + + +instance + ( ToExprs exprs1 a + , ToExprs exprs2 b + , ToExprs exprs3 c + , ToExprs exprs4 d + , ToExprs exprs5 e + , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5) + ) + => ToExprs x (a, b, c, d, e) + + +instance + ( ToExprs exprs1 a + , ToExprs exprs2 b + , ToExprs exprs3 c + , ToExprs exprs4 d + , ToExprs exprs5 e + , ToExprs exprs6 f + , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6) + ) + => ToExprs x (a, b, c, d, e, f) + + +instance + ( ToExprs exprs1 a + , ToExprs exprs2 b + , ToExprs exprs3 c + , ToExprs exprs4 d + , ToExprs exprs5 e + , ToExprs exprs6 f + , ToExprs exprs7 g + , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7) + ) + => ToExprs x (a, b, c, d, e, f, g) + + +instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) => + ToExprs x (t result) + where + fromResult = id + toResult = id + + +instance (KnownSpec spec, x ~ Col Expr spec) => + ToExprs x (Col Result spec) + where + fromResult = fromColumns + toResult = toColumns + + +-- | The @FromExprs@ type function maps a type in the @Expr@ context to the +-- corresponding type in the @Result@ context. +type FromExprs :: Type -> Type +type family FromExprs a +type instance FromExprs (Expr a) = a +type instance FromExprs (Col Expr spec) = Col Result spec +type instance FromExprs (a, b) = (FromExprs a, FromExprs b) +type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c) +type instance FromExprs (a, b, c, d) = + (FromExprs a, FromExprs b, FromExprs c, FromExprs d) +type instance FromExprs (a, b, c, d, e) = + (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e) +type instance FromExprs (a, b, c, d, e, f) = + ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e + , FromExprs f + ) +type instance FromExprs (a, b, c, d, e, f, g) = + ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e + , FromExprs f, FromExprs g + ) +type instance FromExprs (t (Col Expr)) = t (Col Result) + + +-- | @Serializable@ witnesses the one-to-one correspondence between the type +-- @sql@, which contains SQL expressions, and the type @haskell@, which +-- contains the Haskell decoding of rows containing @sql@ SQL expressions. +type Serializable :: Type -> Type -> Constraint +class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a +instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a +instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a + + +-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is +-- capable of lifting single @Expr@s to full tables. +lit :: forall exprs a. Serializable exprs a => a -> exprs +lit = fromColumns . litHTable . toResult @exprs + + +parse :: forall exprs a. Serializable exprs a => Hasql.Row a +parse = fromResult @exprs <$> parseHTable + + +litHTable :: HTable t => t (Col Result) -> t (Col Expr) +litHTable as = htabulate $ \field -> + case hfield hspecs field of + SSpec {nullity, info} -> case hfield as field of + R value -> E (slitExpr nullity info value) + + +parseHTable :: HTable t => Hasql.Row (t (Col Result)) +parseHTable = unwrapApplicative $ htabulateA $ \field -> + WrapApplicative $ case hfield hspecs field of + SSpec {nullity, info} -> R <$> sparseValue nullity info diff --git a/src/Rel8/Table/Tag.hs b/src/Rel8/Table/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Tag.hs @@ -0,0 +1,97 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language InstanceSigs #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language UndecidableInstances #-} + +module Rel8.Table.Tag + ( Tag(..), Taggable + , fromAggregate + , fromExpr + , fromName + ) +where + +-- base +import Control.Applicative ( (<|>), empty ) +import Data.Kind ( Constraint, Type ) +import Data.Foldable ( fold ) +import Data.Monoid ( getFirst ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) +import Prelude + +-- rel8 +import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs ) +import Rel8.Expr ( Expr ) +import Rel8.Expr.Opaleye ( fromPrimExpr ) +import Rel8.Schema.Name ( Name( Name ) ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Type.Monoid ( DBMonoid ) + + +type Tag :: Symbol -> Type -> Type +data Tag label a = Tag + { expr :: Expr a + , aggregator :: Maybe Aggregator + , name :: Name a + } + + +type Taggable :: Type -> Constraint +class Taggable a where + tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a + tempty :: KnownSymbol label => Tag label a + + +instance Sql DBMonoid a => Taggable a where + tappend :: forall label. KnownSymbol label + => Tag label a -> Tag label a -> Tag label a + tappend a b = Tag + { expr = expr a <> expr b + , aggregator = aggregator a <|> aggregator b + , name = case (name a, symbolVal (Proxy @label)) of + (Name x, y) + | x == y -> name b + | otherwise -> name a + } + {-# INLINABLE tappend #-} + + tempty :: forall label. KnownSymbol label => Tag label a + tempty = Tag + { expr = mempty + , aggregator = empty + , name = Name (symbolVal (Proxy @label)) + } + {-# INLINABLE tempty #-} + + +instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where + (<>) = tappend + + +instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where + mempty = tempty + + +fromAggregate :: forall a label. (KnownSymbol label, Taggable a) + => Aggregate a -> Tag label a +fromAggregate = fold . getFirst . foldInputs go + where + go aggregator primExpr = pure $ (tempty @a @label) + { expr = fromPrimExpr primExpr + , aggregator + } + + +fromExpr :: forall label a. (KnownSymbol label, Taggable a) + => Expr a -> Tag label a +fromExpr expr = (tempty @a @label) {expr} + + +fromName :: forall a label. Taggable a => Name a -> Tag label a +fromName name = (tempty @a @"") {name} diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/These.hs @@ -0,0 +1,341 @@ +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +{-# options_ghc -fno-warn-orphans #-} + +module Rel8.Table.These + ( TheseTable(..) + , theseTable, thisTable, thatTable, thoseTable + , isThisTable, isThatTable, isThoseTable + , hasHereTable, hasThereTable + , justHereTable, justThereTable + , nameTheseTable + ) +where + +-- base +import Control.Applicative ( liftA2 ) +import Data.Bifunctor ( Bifunctor, bimap ) +import Data.Functor.Identity ( runIdentity ) +import Data.Kind ( Type ) +import Prelude hiding ( undefined ) + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Expr.Bool ( (&&.), not_ ) +import Rel8.Expr.Null ( isNonNull ) +import Rel8.Schema.Context.Label + ( Labelable + , HLabelable, hlabeler, hunlabeler + ) +import Rel8.Schema.Context.Nullify + ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag + , hencodeTag, hdecodeTag + , hnullifier, hunnullifier + ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) +import Rel8.Schema.HTable.These ( HTheseTable(..) ) +import Rel8.Schema.Name ( Name ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , reify, unreify + ) +import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Table.Maybe + ( MaybeTable(..) + , maybeTable, justTable, nothingTable + , isJustTable + , nameMaybeTable + ) +import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult ) +import Rel8.Table.Tag ( Tag(..) ) +import Rel8.Table.Undefined ( undefined ) +import Rel8.Type.Tag ( MaybeTag ) + +-- semigroupoids +import Data.Functor.Apply ( Apply, (<.>) ) +import Data.Functor.Bind ( Bind, (>>-) ) + +-- these +import Data.These ( These ) + + +-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the +-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using +-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be +-- eliminated/pattern matched using 'theseTable'. +-- +-- @TheseTable@ is operationally the same as Haskell's 'These' type, but +-- adapted to work with Rel8. +type TheseTable :: Type -> Type -> Type +data TheseTable a b = TheseTable + { here :: MaybeTable a + , there :: MaybeTable b + } + deriving stock Functor + + +instance Bifunctor TheseTable where + bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b) + + +instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where + fs <.> as = TheseTable + { here = here fs <> here as + , there = there fs <.> there as + } + + +instance (Table Expr a, Semigroup a) => Applicative (TheseTable a) + where + pure = thatTable + (<*>) = (<.>) + + +instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where + TheseTable here1 ma >>- f = case ma >>- f' of + mtb -> TheseTable + { here = maybeTable here1 ((here1 <>) . fst) mtb + , there = snd <$> mtb + } + where + f' a = case f a of + TheseTable here2 mb -> (here2,) <$> mb + + +instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where + (>>=) = (>>-) + + +instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) => + Semigroup (TheseTable a b) + where + a <> b = TheseTable + { here = here a <> here b + , there = there a <> there b + } + + +instance + ( Table context a, Table context b + , Labelable context, Nullifiable context, ConstrainTag context MaybeTag + ) => Table context (TheseTable a b) + where + type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b) + type Context (TheseTable a b) = Context a + + toColumns = toColumns2 toColumns toColumns + fromColumns = fromColumns2 fromColumns fromColumns + reify = liftA2 bimap reify reify + unreify = liftA2 bimap unreify unreify + + +instance + ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag + , Labelable to, Nullifiable to, ConstrainTag to MaybeTag + , Recontextualize from to a1 b1 + , Recontextualize from to a2 b2 + ) => + Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2) + + +instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where + eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b)) + + +instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where + ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b)) + + +type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b) + + +instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) => + ToExprs x (These a b) + where + fromResult = + bimap (fromResult @exprs1) (fromResult @exprs2) . + fromColumns + toResult = + toColumns . + bimap (toResult @exprs1) (toResult @exprs2) + + +toHereTag :: Tag "isJust" a -> Tag "hasHere" a +toHereTag Tag {..} = Tag {..} + + +toThereTag :: Tag "isJust" a -> Tag "hasThere" a +toThereTag Tag {..} = Tag {..} + + +-- | Test if a 'TheseTable' was constructed with 'thisTable'. +-- +-- Corresponds to 'Data.These.Combinators.isThis'. +isThisTable :: TheseTable a b -> Expr Bool +isThisTable a = hasHereTable a &&. not_ (hasThereTable a) + + +-- | Test if a 'TheseTable' was constructed with 'thatTable'. +-- +-- Corresponds to 'Data.These.Combinators.isThat'. +isThatTable :: TheseTable a b -> Expr Bool +isThatTable a = not_ (hasHereTable a) &&. hasThereTable a + + +-- | Test if a 'TheseTable' was constructed with 'thoseTable'. +-- +-- Corresponds to 'Data.These.Combinators.isThese'. +isThoseTable :: TheseTable a b -> Expr Bool +isThoseTable a = hasHereTable a &&. hasThereTable a + + +-- | Test if the @a@ side of @TheseTable a b@ is present. +-- +-- Corresponds to 'Data.These.Combinators.hasHere'. +hasHereTable :: TheseTable a b -> Expr Bool +hasHereTable TheseTable {here} = isJustTable here + + +-- | Test if the @b@ table of @TheseTable a b@ is present. +-- +-- Corresponds to 'Data.These.Combinators.hasThere'. +hasThereTable :: TheseTable a b -> Expr Bool +hasThereTable TheseTable {there} = isJustTable there + + +-- | Attempt to project out the @a@ table of a @TheseTable a b@. +-- +-- Corresponds to 'Data.These.Combinators.justHere'. +justHereTable :: TheseTable a b -> MaybeTable a +justHereTable = here + + +-- | Attempt to project out the @b@ table of a @TheseTable a b@. +-- +-- Corresponds to 'Data.These.Combinators.justThere'. +justThereTable :: TheseTable a b -> MaybeTable b +justThereTable = there + + +-- | Construct a @TheseTable@. Corresponds to 'This'. +thisTable :: Table Expr b => a -> TheseTable a b +thisTable a = TheseTable (justTable a) nothingTable + + +-- | Construct a @TheseTable@. Corresponds to 'That'. +thatTable :: Table Expr a => b -> TheseTable a b +thatTable b = TheseTable nothingTable (justTable b) + + +-- | Construct a @TheseTable@. Corresponds to 'These'. +thoseTable :: a -> b -> TheseTable a b +thoseTable a b = TheseTable (justTable a) (justTable b) + + +-- | Pattern match on a 'TheseTable'. Corresponds to 'these'. +theseTable :: Table Expr c + => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c +theseTable f g h TheseTable {here, there} = + maybeTable + (maybeTable undefined f here) + (\b -> maybeTable (g b) (`h` b) here) + there + + +-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you +-- have a 'TheseTable' that you are storing in a table and need to construct a +-- 'TableSchema'. +nameTheseTable :: () + => Name (Maybe MaybeTag) + -- ^ The name of the column to track the presence of the @a@ table. + -> Name (Maybe MaybeTag) + -- ^ The name of the column to track the presence of the @b@ table. + -> a + -- ^ Names of the columns in the @a@ table. + -> b + -- ^ Names of the columns in the @b@ table. + -> TheseTable a b +nameTheseTable here there a b = + TheseTable + { here = nameMaybeTable here a + , there = nameMaybeTable there b + } + + +toColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> (b -> u context) + -> TheseTable a b + -> HTheseTable t u context +toColumns2 f g TheseTable {here, there} = HTheseTable + { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here)) + , hhere = + hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here) + , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there)) + , hthere = + hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there) + } + + +fromColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> (u context -> b) + -> HTheseTable t u context + -> TheseTable a b +fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable + { here = + let + tag = hdecodeTag $ unHIdentity hhereTag + in + MaybeTable + { tag + , just = f $ + runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hhere + } + , there = + let + tag = hdecodeTag $ unHIdentity hthereTag + in + MaybeTable + { tag + , just = g $ + runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hthere + } + } diff --git a/src/Rel8/Table/Undefined.hs b/src/Rel8/Table/Undefined.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Undefined.hs @@ -0,0 +1,26 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language TypeFamilies #-} + +module Rel8.Table.Undefined + ( undefined + ) +where + +-- base +import Prelude hiding ( undefined ) + +-- rel8 +import Rel8.Expr ( Expr, Col( E ) ) +import Rel8.Expr.Null ( snull, unsafeUnnullify ) +import Rel8.Schema.HTable ( htabulate, hfield, hspecs ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Spec ( SSpec(..) ) +import Rel8.Table ( Table, fromColumns ) + + +undefined :: Table Expr a => a +undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of + SSpec {nullity, info} -> case nullity of + Null -> E (snull info) + NotNull -> E (unsafeUnnullify (snull info)) diff --git a/src/Rel8/Table/Unreify.hs b/src/Rel8/Table/Unreify.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Table/Unreify.hs @@ -0,0 +1,102 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +-- | This module implements some machinery for implementing methods of the +-- 'Table' class for a particular special (but important) class of polymorphic +-- @Table@ types. +-- +-- This special case is characterised by a @newtype@ wrapper around a bare +-- 'HTable' which is constructed by applying a type family to the polymorphic +-- type variable. +-- +-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@. +-- +-- The tricky part about implementing @Table@ for these types is 'reify' and +-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself +-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@ +-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a +-- @Table@) + +module Rel8.Table.Unreify + ( Unreifiable, Unreifiability(..), unreifiability + , Unreifies + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- rel8 +import Rel8.Aggregate ( Aggregate ) +import Rel8.Expr ( Expr ) +import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable ) +import Rel8.Schema.Dict ( Dict( Dict ) ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name ) +import Rel8.Schema.Reify ( Reify ) +import Rel8.Schema.Result ( Result ) +import Rel8.Table ( Table, Context, Congruent, Unreify ) + + +type Unreifies :: K.Context -> Type -> Constraint +type family Unreifies context a where + Unreifies (Reify context) a = Unreifier context a + Unreifies _ _ = () + + +type Unreifiable :: Type -> Constraint +class + ( Context a ~ Reify Aggregate => Unreifier Aggregate a + , Context a ~ Reify Expr => Unreifier Expr a + , Context a ~ Reify Name => Unreifier Name a + , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a) + ) + => Unreifiable a +instance + ( Context a ~ Reify Aggregate => Unreifier Aggregate a + , Context a ~ Reify Expr => Unreifier Expr a + , Context a ~ Reify Name => Unreifier Name a + , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a) + ) + => Unreifiable a + + +type Unreifier :: K.Context -> Type -> Constraint +class + ( Table context (Unreify a) + , Congruent a (Unreify a) + ) + => Unreifier context a +instance + ( Table context (Unreify a) + , Congruent a (Unreify a) + ) + => Unreifier context a + + +type Unreifiability :: K.Context -> Type -> Type +data Unreifiability context a where + UResult :: Unreifiability Result a + Unreifiability :: Unreifier context a + => SContext context -> Unreifiability context a + + +unreifiability :: (Context a ~ Reify context, Unreifiable a) + => SContext context -> Unreifiability context a +unreifiability = \case + SAggregate -> Unreifiability SAggregate + SExpr -> Unreifiability SExpr + SName -> Unreifiability SName + SResult -> UResult + SReify context -> case sReifiable context of + Dict -> Unreifiability (SReify context) diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type.hs @@ -0,0 +1,287 @@ +{-# language FlexibleInstances #-} +{-# language MonoLocalBinds #-} +{-# language MultiWayIf #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Type + ( DBType (typeInformation) + ) +where + +-- aeson +import Data.Aeson ( Value ) +import qualified Data.Aeson as Aeson + +-- base +import Data.Int ( Int16, Int32, Int64 ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) + +-- rel8 +import Rel8.Schema.Null ( NotNull, Sql, nullable ) +import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) +import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation ) + +-- scientific +import Data.Scientific ( Scientific ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy ( Text, unpack ) +import qualified Data.Text.Lazy as Text ( fromStrict, toStrict ) +import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 ) + +-- time +import Data.Time.Calendar ( Day ) +import Data.Time.Clock ( UTCTime ) +import Data.Time.LocalTime + ( CalendarDiffTime( CalendarDiffTime ) + , LocalTime + , TimeOfDay + ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) + +-- uuid +import Data.UUID ( UUID ) +import qualified Data.UUID as UUID + + +-- | Haskell types that can be represented as expressions in a database. There +-- should be an instance of @DBType@ for all column types in your database +-- schema (e.g., @int@, @timestamptz@, etc). +-- +-- Rel8 comes with stock instances for most default types in PostgreSQL, so you +-- should only need to derive instances of this class for custom database +-- types, such as types defined in PostgreSQL extensions, or custom domain +-- types. +type DBType :: Type -> Constraint +class NotNull a => DBType a where + typeInformation :: TypeInformation a + + +-- | Corresponds to @bool@ +instance DBType Bool where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.BoolLit + , decode = Hasql.bool + , typeName = "bool" + } + + +-- | Corresponds to @char@ +instance DBType Char where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure + , decode = Hasql.char + , typeName = "char" + } + + +-- | Corresponds to @int2@ +instance DBType Int16 where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int2 + , typeName = "int2" + } + + +-- | Corresponds to @int4@ +instance DBType Int32 where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int4 + , typeName = "int4" + } + + +-- | Corresponds to @int8@ +instance DBType Int64 where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int8 + , typeName = "int8" + } + + +-- | Corresponds to @float4@ +instance DBType Float where + typeInformation = TypeInformation + { encode = \x -> Opaleye.ConstExpr + if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.NumericLit $ realToFrac x + , decode = Hasql.float4 + , typeName = "float4" + } + + +-- | Corresponds to @float8@ +instance DBType Double where + typeInformation = TypeInformation + { encode = \x -> Opaleye.ConstExpr + if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.NumericLit $ realToFrac x + , decode = Hasql.float8 + , typeName = "float8" + } + + +-- | Corresponds to @numeric@ +instance DBType Scientific where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.NumericLit + , decode = Hasql.numeric + , typeName = "numeric" + } + + +-- | Corresponds to @timestamptz@ +instance DBType UTCTime where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%FT%T%QZ'" + , decode = Hasql.timestamptz + , typeName = "timestamptz" + } + + +-- | Corresponds to @date@ +instance DBType Day where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%F'" + , decode = Hasql.date + , typeName = "date" + } + + +-- | Corresponds to @timestamp@ +instance DBType LocalTime where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%FT%T%Q'" + , decode = Hasql.timestamp + , typeName = "timestamp" + } + + +-- | Corresponds to @time@ +instance DBType TimeOfDay where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%T%Q'" + , decode = Hasql.time + , typeName = "time" + } + + +-- | Corresponds to @interval@ +instance DBType CalendarDiffTime where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%bmon %0Es'" + , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval + , typeName = "interval" + } + + +-- | Corresponds to @text@ +instance DBType Text where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack + , decode = Hasql.text + , typeName = "text" + } + + +-- | Corresponds to @text@ +instance DBType Lazy.Text where + typeInformation = + mapTypeInformation Text.fromStrict Text.toStrict typeInformation + + +-- | Corresponds to @citext@ +instance DBType (CI Text) where + typeInformation = mapTypeInformation CI.mk CI.original typeInformation + { typeName = "citext" + } + + +-- | Corresponds to @citext@ +instance DBType (CI Lazy.Text) where + typeInformation = mapTypeInformation CI.mk CI.original typeInformation + { typeName = "citext" + } + + +-- | Corresponds to @bytea@ +instance DBType ByteString where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit + , decode = Hasql.bytea + , typeName = "bytea" + } + + +-- | Corresponds to @bytea@ +instance DBType Lazy.ByteString where + typeInformation = + mapTypeInformation ByteString.fromStrict ByteString.toStrict + typeInformation + + +-- | Corresponds to @uuid@ +instance DBType UUID where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString + , decode = Hasql.uuid + , typeName = "uuid" + } + + +-- | Corresponds to @jsonb@ +instance DBType Value where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . + Opaleye.quote . + Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode + , decode = Hasql.jsonb + , typeName = "jsonb" + } + + +instance Sql DBType a => DBType [a] where + typeInformation = listTypeInformation nullable typeInformation + + +instance Sql DBType a => DBType (NonEmpty a) where + typeInformation = nonEmptyTypeInformation nullable typeInformation diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Array.hs @@ -0,0 +1,100 @@ +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} + +module Rel8.Type.Array + ( array, encodeArrayElement, extractArrayElement + , listTypeInformation + , nonEmptyTypeInformation + ) +where + +-- base +import Data.Foldable ( toList ) +import Data.List.NonEmpty ( NonEmpty, nonEmpty ) +import Prelude hiding ( null, repeat, zipWith ) + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) ) +import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation ) + + +array :: Foldable f + => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr +array info = + Opaleye.CastExpr (arrayType info <> "[]") . + Opaleye.ArrayExpr . map (encodeArrayElement info) . toList +{-# INLINABLE array #-} + + +listTypeInformation :: () + => Nullity a + -> TypeInformation (Unnullify a) + -> TypeInformation [a] +listTypeInformation nullity info@TypeInformation {encode, decode} = + TypeInformation + { decode = case nullity of + Null -> + Hasql.listArray (decodeArrayElement info (Hasql.nullable decode)) + NotNull -> + Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode)) + , encode = case nullity of + Null -> + Opaleye.ArrayExpr . + fmap (encodeArrayElement info . maybe null encode) + NotNull -> + Opaleye.ArrayExpr . + fmap (encodeArrayElement info . encode) + , typeName = arrayType info <> "[]" + } + where + null = Opaleye.ConstExpr Opaleye.NullLit + + +nonEmptyTypeInformation :: () + => Nullity a + -> TypeInformation (Unnullify a) + -> TypeInformation (NonEmpty a) +nonEmptyTypeInformation nullity = + parseTypeInformation parse toList . listTypeInformation nullity + where + parse = maybe (Left message) Right . nonEmpty + message = "failed to decode NonEmptyList: got empty list" + + +isArray :: TypeInformation a -> Bool +isArray = \case + (reverse . typeName -> ']' : '[' : _) -> True + _ -> False + + +arrayType :: TypeInformation a -> String +arrayType info + | isArray info = "record" + | otherwise = typeName info + + +decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x +decodeArrayElement info + | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field + | otherwise = id + + +encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr +encodeArrayElement info + | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW") + | otherwise = id + + +extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr +extractArrayElement info + | isArray info = flip Opaleye.CompositeExpr "f1" + | otherwise = id diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Composite.hs @@ -0,0 +1,134 @@ +{-# language AllowAmbiguousTypes #-} +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} +{-# language ViewPatterns #-} + +module Rel8.Type.Composite + ( Composite( Composite ) + , DBComposite( compositeFields, compositeTypeName ) + , compose, decompose + ) +where + +-- base +import Data.Functor.Const ( Const( Const ), getConst ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr ( Col( E ), Expr ) +import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr ) +import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA ) +import Rel8.Schema.Name ( Col( N ), Name( Name ) ) +import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) +import Rel8.Schema.Result ( Col( R ), Result ) +import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) ) +import Rel8.Table ( Table, fromColumns, toColumns ) +import Rel8.Table.Eq ( EqTable ) +import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD ) +import Rel8.Table.Ord ( OrdTable ) +import Rel8.Table.Rel8able () +import Rel8.Table.Serialize ( lit ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Type.Ord ( DBOrd, DBMax, DBMin ) + +-- semigroupoids +import Data.Functor.Apply ( WrappedApplicative(..) ) + + +-- | A deriving-via helper type for column types that store a Haskell product +-- type in a single Postgres column using a Postgres composite type. +-- +-- Note that this must map to a specific extant type in your database's schema +-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this +-- Postgres type and the names of the individual fields (for projecting with +-- 'decompose'). +type Composite :: Type -> Type +newtype Composite a = Composite + { unComposite :: a + } + + +instance DBComposite a => DBType (Composite a) where + typeInformation = TypeInformation + { decode = Hasql.composite (Composite . fromHKD <$> decoder) + , encode = encoder . lit . toColumns . toHKD . unComposite + , typeName = compositeTypeName @a + } + + +instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a) + + +instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a) + + +instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a) + + +instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a) + + +-- | 'DBComposite' is used to associate composite type metadata with a Haskell +-- type. +type DBComposite :: Type -> Constraint +class (DBType a, HKDable a) => DBComposite a where + -- | The names of all fields in the composite type that @a@ maps to. + compositeFields :: HKD a Name + + -- | The name of the composite type that @a@ maps to. + compositeTypeName :: String + + +-- | Collapse a 'HKD' into a PostgreSQL composite type. +-- +-- 'HKD' values are represented in queries by having a column for each field in +-- the corresponding Haskell type. 'compose' collapses these columns into a +-- single column expression, by combining them into a PostgreSQL composite +-- type. +compose :: DBComposite a => HKD a Expr -> Expr a +compose = castExpr . fromPrimExpr . encoder + + +-- | Expand a composite type into a 'HKD'. +-- +-- 'decompose' is the inverse of 'compose'. +decompose :: forall a. DBComposite a => Expr a -> HKD a Expr +decompose (toPrimExpr -> a) = fromColumns $ htabulate \field -> + case hfield names field of + N (Name name) -> case hfield hspecs field of + SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name + where + names = toColumns (compositeFields @a) + + +decoder :: Table Result a => Hasql.Composite a +decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field -> + case hfield hspecs field of + SSpec {nullity, info} -> WrapApplicative $ R <$> + case nullity of + Null -> Hasql.field $ Hasql.nullable $ decode info + NotNull -> Hasql.field $ Hasql.nonNullable $ decode info + + +encoder :: Table Expr a => a -> Opaleye.PrimExpr +encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs + where + exprs = getConst $ htabulateA \field -> case hfield a field of + E (toPrimExpr -> expr) -> Const [expr] diff --git a/src/Rel8/Type/Enum.hs b/src/Rel8/Type/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Enum.hs @@ -0,0 +1,138 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language LambdaCase #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Enum + ( Enum( Enum ) + , DBEnum( enumValue, enumTypeName ) + , Enumable + ) +where + +-- base +import Control.Applicative ( (<|>) ) +import Control.Arrow ( (&&&) ) +import Data.Kind ( Constraint, Type ) +import Data.Proxy ( Proxy( Proxy ) ) +import GHC.Generics + ( Generic, Rep, from, to + , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ) + , D, C, Meta( MetaCons ) + ) +import GHC.TypeLits ( KnownSymbol, symbolVal ) +import Prelude hiding ( Enum ) + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Type.Ord ( DBOrd, DBMax, DBMin ) + +-- text +import Data.Text ( pack ) + + +-- | A deriving-via helper type for column types that store an \"enum\" type +-- (in Haskell terms, a sum type where all constructors are nullary) using a +-- Postgres @enum@ type. +-- +-- Note that this should map to a specific type in your database's schema +-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to +-- specify the name of this Postgres type and the names of the individual +-- values. If left unspecified, the names of the values of the Postgres +-- @enum@ are assumed to match exactly exactly the names of the constructors +-- of the Haskell type (up to and including case sensitivity). +type Enum :: Type -> Type +newtype Enum a = Enum + { unEnum :: a + } + + +instance DBEnum a => DBType (Enum a) where + typeInformation = TypeInformation + { decode = + Hasql.enum $ + flip lookup $ + map ((pack . enumValue &&& Enum) . to) $ + genumerate @(Rep a) + , encode = + Opaleye.ConstExpr . + Opaleye.StringLit . + enumValue @a . + unEnum + , typeName = enumTypeName @a + } + + +instance DBEnum a => DBEq (Enum a) + + +instance DBEnum a => DBOrd (Enum a) + + +instance DBEnum a => DBMax (Enum a) + + +instance DBEnum a => DBMin (Enum a) + + +-- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type. +type DBEnum :: Type -> Constraint +class (DBType a, Enumable a) => DBEnum a where + -- | Map Haskell values to the corresponding element of the @enum@ type. The + -- default implementation of this method will use the exact name of the + -- Haskell constructors. + enumValue :: a -> String + enumValue = gshow @(Rep a) . from + + -- | The name of the PostgreSQL @enum@ type that @a@ maps to. + enumTypeName :: String + + +-- | Types that are sum types, where each constructor is unary (that is, has no +-- fields). +class (Generic a, GEnumable (Rep a)) => Enumable a +instance (Generic a, GEnumable (Rep a)) => Enumable a + + +type GEnumable :: (Type -> Type) -> Constraint +class GEnumable rep where + genumerate :: [rep x] + gshow :: rep x -> String + + +instance GEnumable rep => GEnumable (M1 D meta rep) where + genumerate = M1 <$> genumerate + gshow (M1 rep) = gshow rep + + +instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where + genumerate = L1 <$> genumerate <|> R1 <$> genumerate + gshow = \case + L1 a -> gshow a + R1 a -> gshow a + + +instance + ( meta ~ 'MetaCons name _fixity _isRecord + , KnownSymbol name + ) + => GEnumable (M1 C meta U1) + where + genumerate = [M1 U1] + gshow (M1 U1) = symbolVal (Proxy @name) diff --git a/src/Rel8/Type/Eq.hs b/src/Rel8/Type/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Eq.hs @@ -0,0 +1,78 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MonoLocalBinds #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Eq + ( DBEq + ) +where + +-- aeson +import Data.Aeson ( Value ) + +-- base +import Data.List.NonEmpty ( NonEmpty ) +import Data.Int ( Int16, Int32, Int64 ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) + +-- rel8 +import Rel8.Schema.Null ( Sql ) +import Rel8.Type ( DBType ) + +-- scientific +import Data.Scientific ( Scientific ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy ( Text ) + +-- time +import Data.Time.Calendar ( Day ) +import Data.Time.Clock ( UTCTime ) +import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay ) + +-- uuid +import Data.UUID ( UUID ) + + +-- | Database types that can be compared for equality in queries. If a type is +-- an instance of 'DBEq', it means we can compare expressions for equality +-- using the SQL @=@ operator. +type DBEq :: Type -> Constraint +class DBType a => DBEq a + + +instance DBEq Bool +instance DBEq Char +instance DBEq Int16 +instance DBEq Int32 +instance DBEq Int64 +instance DBEq Float +instance DBEq Double +instance DBEq Scientific +instance DBEq UTCTime +instance DBEq Day +instance DBEq LocalTime +instance DBEq TimeOfDay +instance DBEq CalendarDiffTime +instance DBEq Text +instance DBEq Lazy.Text +instance DBEq (CI Text) +instance DBEq (CI Lazy.Text) +instance DBEq ByteString +instance DBEq Lazy.ByteString +instance DBEq UUID +instance DBEq Value +instance Sql DBEq a => DBEq [a] +instance Sql DBEq a => DBEq (NonEmpty a) diff --git a/src/Rel8/Type/Information.hs b/src/Rel8/Type/Information.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Information.hs @@ -0,0 +1,67 @@ +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Type.Information + ( TypeInformation(..) + , mapTypeInformation + , parseTypeInformation + ) +where + +-- base +import Data.Bifunctor ( first ) +import Data.Kind ( Type ) +import Prelude + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- text +import qualified Data.Text as Text + + +-- | @TypeInformation@ describes how to encode and decode a Haskell type to and +-- from database queries. The @typeName@ is the name of the type in the +-- database, which is used to accurately type literals. +type TypeInformation :: Type -> Type +data TypeInformation a = TypeInformation + { encode :: a -> Opaleye.PrimExpr + -- ^ How to encode a single Haskell value as a SQL expression. + , decode :: Hasql.Value a + -- ^ How to deserialize a single result back to Haskell. + , typeName :: String + -- ^ The name of the SQL type. + } + + +-- | Simultaneously map over how a type is both encoded and decoded, while +-- retaining the name of the type. This operation is useful if you want to +-- essentially @newtype@ another 'Rel8.DBType'. +-- +-- The mapping is required to be total. If you have a partial mapping, see +-- 'parseTypeInformation'. +mapTypeInformation :: () + => (a -> b) -> (b -> a) + -> TypeInformation a -> TypeInformation b +mapTypeInformation = parseTypeInformation . fmap pure + + +-- | Apply a parser to 'TypeInformation'. +-- +-- This can be used if the data stored in the database should only be subset of +-- a given 'TypeInformation'. The parser is applied when deserializing rows +-- returned - the encoder assumes that the input data is already in the +-- appropriate form. +parseTypeInformation :: () + => (a -> Either String b) -> (b -> a) + -> TypeInformation a -> TypeInformation b +parseTypeInformation to from TypeInformation {encode, decode, typeName} = + TypeInformation + { encode = encode . from + , decode = Hasql.refine (first Text.pack . to) decode + , typeName + } diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -0,0 +1,31 @@ +module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where + +-- aeson +import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON ) +import Data.Aeson.Types ( parseEither ) + +-- base +import Data.Bifunctor ( first ) +import Prelude + +-- hasql +import qualified Hasql.Decoders as Hasql + +-- rel8 +import Rel8.Type ( DBType(..) ) +import Rel8.Type.Information ( TypeInformation(..) ) + +-- text +import Data.Text ( pack ) + + +-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns. +newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a } + + +instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where + typeInformation = TypeInformation + { encode = encode typeInformation . toJSON . fromJSONBEncoded + , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb + , typeName = "jsonb" + } diff --git a/src/Rel8/Type/JSONEncoded.hs b/src/Rel8/Type/JSONEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/JSONEncoded.hs @@ -0,0 +1,25 @@ +module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where + +-- aeson +import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON ) +import Data.Aeson.Types ( parseEither ) + +-- base +import Prelude + +-- rel8 +import Rel8.Type ( DBType(..) ) +import Rel8.Type.Information ( parseTypeInformation ) + + +-- | A deriving-via helper type for column types that store a Haskell value +-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type +-- classes. +newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a } + + +instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where + typeInformation = parseTypeInformation f g typeInformation + where + f = fmap JSONEncoded . parseEither parseJSON + g = toJSON . fromJSONEncoded diff --git a/src/Rel8/Type/Monoid.hs b/src/Rel8/Type/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Monoid.hs @@ -0,0 +1,79 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Monoid + ( DBMonoid( memptyExpr ) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude hiding ( null ) + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr ) +import Rel8.Expr.Array ( sempty ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Semigroup ( DBSemigroup ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy ( Text ) + +-- time +import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) ) + + +-- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a +-- Rel8 concept, and exists to mirror the 'Monoid' class. +type DBMonoid :: Type -> Constraint +class DBSemigroup a => DBMonoid a where + -- The identity for '<>.' + memptyExpr :: Expr a + + +instance Sql DBType a => DBMonoid [a] where + memptyExpr = sempty typeInformation + + +instance DBMonoid CalendarDiffTime where + memptyExpr = litExpr (CalendarDiffTime 0 0) + + +instance DBMonoid Text where + memptyExpr = litExpr "" + + +instance DBMonoid Lazy.Text where + memptyExpr = litExpr "" + + +instance DBMonoid (CI Text) where + memptyExpr = litExpr "" + + +instance DBMonoid (CI Lazy.Text) where + memptyExpr = litExpr "" + + +instance DBMonoid ByteString where + memptyExpr = litExpr "" + + +instance DBMonoid Lazy.ByteString where + memptyExpr = litExpr "" diff --git a/src/Rel8/Type/Num.hs b/src/Rel8/Type/Num.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Num.hs @@ -0,0 +1,58 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Num + ( DBNum, DBIntegral, DBFractional, DBFloating + ) +where + +-- base +import Data.Int ( Int16, Int32, Int64 ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- rel8 +import Rel8.Type ( DBType ) + +-- scientific +import Data.Scientific ( Scientific ) + + +-- | The class of database types that support the @+@, @*@, @-@ operators, and +-- the @abs@, @negate@, @sign@ functions. +type DBNum :: Type -> Constraint +class DBType a => DBNum a +instance DBNum Int16 +instance DBNum Int32 +instance DBNum Int64 +instance DBNum Float +instance DBNum Double +instance DBNum Scientific + + +-- | The class of database types that can be coerced to from integral +-- expressions. This is a Rel8 concept, and allows us to provide +-- 'fromIntegral'. +type DBIntegral :: Type -> Constraint +class DBNum a => DBIntegral a +instance DBIntegral Int16 +instance DBIntegral Int32 +instance DBIntegral Int64 + + +-- | The class of database types that support the @/@ operator. +class DBNum a => DBFractional a +instance DBFractional Float +instance DBFractional Double +instance DBFractional Scientific + + +-- | The class of database types that support the @/@ operator. +class DBFractional a => DBFloating a +instance DBFloating Float +instance DBFloating Double diff --git a/src/Rel8/Type/Ord.hs b/src/Rel8/Type/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Ord.hs @@ -0,0 +1,124 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MonoLocalBinds #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Ord + ( DBOrd + , DBMax, DBMin + ) +where + +-- base +import Data.Int ( Int16, Int32, Int64 ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Prelude + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) + +-- rel8 +import Rel8.Schema.Null ( Sql ) +import Rel8.Type.Eq ( DBEq ) + +-- scientific +import Data.Scientific ( Scientific ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy ( Text ) + +-- time +import Data.Time.Calendar ( Day ) +import Data.Time.Clock ( UTCTime ) +import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay ) + +-- uuid +import Data.UUID ( UUID ) + + +-- | The class of database types that support the @<@, @<=@, @>@ and @>=@ +-- operators. +type DBOrd :: Type -> Constraint +class DBEq a => DBOrd a +instance DBOrd Bool +instance DBOrd Char +instance DBOrd Int16 +instance DBOrd Int32 +instance DBOrd Int64 +instance DBOrd Float +instance DBOrd Double +instance DBOrd Scientific +instance DBOrd UTCTime +instance DBOrd Day +instance DBOrd LocalTime +instance DBOrd TimeOfDay +instance DBOrd CalendarDiffTime +instance DBOrd Text +instance DBOrd Lazy.Text +instance DBOrd (CI Text) +instance DBOrd (CI Lazy.Text) +instance DBOrd ByteString +instance DBOrd Lazy.ByteString +instance DBOrd UUID +instance Sql DBOrd a => DBOrd [a] +instance Sql DBOrd a => DBOrd (NonEmpty a) + + +-- | The class of database types that support the @max@ aggregation function. +type DBMax :: Type -> Constraint +class DBOrd a => DBMax a +instance DBMax Bool +instance DBMax Char +instance DBMax Int16 +instance DBMax Int32 +instance DBMax Int64 +instance DBMax Float +instance DBMax Double +instance DBMax Scientific +instance DBMax UTCTime +instance DBMax Day +instance DBMax LocalTime +instance DBMax TimeOfDay +instance DBMax CalendarDiffTime +instance DBMax Text +instance DBMax Lazy.Text +instance DBMax (CI Text) +instance DBMax (CI Lazy.Text) +instance DBMax ByteString +instance DBMax Lazy.ByteString +instance Sql DBMax a => DBMax [a] +instance Sql DBMax a => DBMax (NonEmpty a) + + +-- | The class of database types that support the @min@ aggregation function. +type DBMin :: Type -> Constraint +class DBOrd a => DBMin a +instance DBMin Bool +instance DBMin Char +instance DBMin Int16 +instance DBMin Int32 +instance DBMin Int64 +instance DBMin Float +instance DBMin Double +instance DBMin Scientific +instance DBMin UTCTime +instance DBMin Day +instance DBMin LocalTime +instance DBMin TimeOfDay +instance DBMin CalendarDiffTime +instance DBMin Text +instance DBMin Lazy.Text +instance DBMin (CI Text) +instance DBMin (CI Lazy.Text) +instance DBMin ByteString +instance DBMin Lazy.ByteString +instance Sql DBMin a => DBMin [a] +instance Sql DBMin a => DBMin (NonEmpty a) diff --git a/src/Rel8/Type/ReadShow.hs b/src/Rel8/Type/ReadShow.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/ReadShow.hs @@ -0,0 +1,32 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language ViewPatterns #-} + +module Rel8.Type.ReadShow ( ReadShow(..) ) where + +-- base +import Data.Proxy ( Proxy( Proxy ) ) +import Data.Typeable ( Typeable, typeRep ) +import Prelude +import Text.Read ( readMaybe ) + +-- rel8 +import Rel8.Type ( DBType( typeInformation ) ) +import Rel8.Type.Information ( parseTypeInformation ) + +-- text +import qualified Data.Text as Text + + +-- | A deriving-via helper type for column types that store a Haskell value +-- using a Haskell's 'Read' and 'Show' type classes. +newtype ReadShow a = ReadShow { fromReadShow :: a } + + +instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where + typeInformation = parseTypeInformation parser printer typeInformation + where + parser (Text.unpack -> t) = case readMaybe t of + Just ok -> Right $ ReadShow ok + Nothing -> Left $ "Could not read " <> t <> " as a " <> show (typeRep (Proxy @a)) + printer = Text.pack . show . fromReadShow diff --git a/src/Rel8/Type/Semigroup.hs b/src/Rel8/Type/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Semigroup.hs @@ -0,0 +1,87 @@ +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Semigroup + ( DBSemigroup( (<>.)) + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) +import Prelude () + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr ) +import Rel8.Expr.Array ( sappend, sappend1 ) +import Rel8.Expr.Opaleye ( zipPrimExprsWith ) +import Rel8.Schema.Null ( Sql ) +import Rel8.Type ( DBType ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy ( Text ) + +-- time +import Data.Time.LocalTime ( CalendarDiffTime ) + + +-- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a +-- Rel8 concept, and exists to mirror the 'Semigroup' class. +type DBSemigroup :: Type -> Constraint +class DBType a => DBSemigroup a where + -- | An associative operation. + (<>.) :: Expr a -> Expr a -> Expr a + infixr 6 <>. + + +instance Sql DBType a => DBSemigroup [a] where + (<>.) = sappend + + +instance Sql DBType a => DBSemigroup (NonEmpty a) where + (<>.) = sappend1 + + +instance DBSemigroup CalendarDiffTime where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+)) + + +instance DBSemigroup Text where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBSemigroup Lazy.Text where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBSemigroup (CI Text) where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBSemigroup (CI Lazy.Text) where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBSemigroup ByteString where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBSemigroup Lazy.ByteString where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) diff --git a/src/Rel8/Type/String.hs b/src/Rel8/Type/String.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/String.hs @@ -0,0 +1,40 @@ +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.String + ( DBString + ) +where + +-- base +import Data.Kind ( Constraint, Type ) +import Prelude () + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString ) + +-- case-insensitive +import Data.CaseInsensitive ( CI ) + +-- rel8 +import Rel8.Type ( DBType ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy ( Text ) + + +-- | The class of data types that support the @string_agg()@ aggregation +-- function. +type DBString :: Type -> Constraint +class DBType a => DBString a +instance DBString Text +instance DBString Lazy.Text +instance DBString (CI Text) +instance DBString (CI Lazy.Text) +instance DBString ByteString +instance DBString Lazy.ByteString diff --git a/src/Rel8/Type/Sum.hs b/src/Rel8/Type/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Sum.hs @@ -0,0 +1,38 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language TypeFamilies #-} +{-# language StandaloneKindSignatures #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Sum + ( DBSum + ) +where + +-- base +import Data.Int ( Int16, Int32, Int64 ) +import Data.Kind ( Constraint, Type ) +import Prelude + +-- rel8 +import Rel8.Type ( DBType ) + +-- scientific +import Data.Scientific ( Scientific ) + +-- time +import Data.Time.LocalTime ( CalendarDiffTime ) + + +-- | The class of database types that support the @sum()@ aggregation function. +type DBSum :: Type -> Constraint +class DBType a => DBSum a +instance DBSum Int16 +instance DBSum Int32 +instance DBSum Int64 +instance DBSum Float +instance DBSum Double +instance DBSum Scientific +instance DBSum CalendarDiffTime diff --git a/src/Rel8/Type/Tag.hs b/src/Rel8/Type/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Tag.hs @@ -0,0 +1,97 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DerivingVia #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language StandaloneKindSignatures #-} + +module Rel8.Type.Tag + ( EitherTag( IsLeft, IsRight ), isLeft, isRight + , MaybeTag( IsJust ) + , Tag( Tag ) + ) +where + +-- base +import Data.Bool ( bool ) +import Data.Kind ( Type ) +import Data.Semigroup ( Min( Min ) ) +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import {-# SOURCE #-} Rel8.Expr ( Expr ) +import Rel8.Expr.Eq ( (==.) ) +import Rel8.Expr.Opaleye ( zipPrimExprsWith ) +import Rel8.Expr.Serialize ( litExpr ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation ) +import Rel8.Type.Monoid ( DBMonoid, memptyExpr ) +import Rel8.Type.Ord ( DBOrd ) +import Rel8.Type.Semigroup ( DBSemigroup, (<>.) ) + +-- text +import Data.Text ( Text ) + + +type EitherTag :: Type +data EitherTag = IsLeft | IsRight + deriving stock (Eq, Ord, Read, Show, Enum, Bounded) + deriving (Semigroup, Monoid) via (Min EitherTag) + deriving anyclass (DBEq, DBOrd) + + +instance DBType EitherTag where + typeInformation = mapTypeInformation to from typeInformation + where + to = bool IsLeft IsRight + from IsLeft = False + from IsRight = True + + +instance DBSemigroup EitherTag where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd) + + +instance DBMonoid EitherTag where + memptyExpr = litExpr mempty + + +isLeft :: Expr EitherTag -> Expr Bool +isLeft = (litExpr IsLeft ==.) + + +isRight :: Expr EitherTag -> Expr Bool +isRight = (litExpr IsRight ==.) + + +type MaybeTag :: Type +data MaybeTag = IsJust + deriving stock (Eq, Ord, Read, Show, Enum, Bounded) + deriving (Semigroup, Monoid) via (Min MaybeTag) + deriving anyclass (DBEq, DBOrd) + + +instance DBType MaybeTag where + typeInformation = parseTypeInformation to from typeInformation + where + to False = Left "MaybeTag can't be false" + to True = Right IsJust + from _ = True + + +instance DBSemigroup MaybeTag where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd) + + +instance DBMonoid MaybeTag where + memptyExpr = litExpr mempty + + +newtype Tag = Tag Text + deriving newtype + ( Eq, Ord, Read, Show + , DBType, DBEq, DBOrd + ) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,730 @@ +{-# language BlockArguments #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language DisambiguateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} + +{-# options_ghc -fno-warn-redundant-constraints #-} + +module Main + ( main + ) +where + +-- base +import Control.Applicative ( liftA2, liftA3 ) +import Control.Monad (void) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.Bifunctor ( bimap ) +import Data.Foldable ( for_ ) +import Data.Int ( Int32, Int64 ) +import Data.List ( nub, sort ) +import Data.Maybe ( catMaybes ) +import Data.String ( fromString ) +import Data.Word (Word32) +import GHC.Generics ( Generic ) + +-- bytestring +import qualified Data.ByteString.Lazy + +-- case-insensitive +import Data.CaseInsensitive (mk) + +-- containers +import qualified Data.Map.Strict as Map + +-- hasql +import Hasql.Connection ( Connection, acquire, release ) +import Hasql.Session ( sql, run ) + +-- hedgehog +import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +-- lifted-base +import Control.Exception.Lifted ( bracket, throwIO, bracket_ ) + +-- monad-control +import Control.Monad.Trans.Control ( MonadBaseControl ) + +-- rel8 +import Rel8 ( Result ) +import qualified Rel8 + +-- scientific +import Data.Scientific ( Scientific ) + +-- tasty +import Test.Tasty + +-- tasty-hedgehog +import Test.Tasty.Hedgehog ( testProperty ) + +-- text +import Data.Text (Text, pack) +import qualified Data.Text.Lazy + +-- time +import Data.Time + +-- tmp-postgres +import qualified Database.Postgres.Temp as TmpPostgres + +-- uuid +import qualified Data.UUID + + +main :: IO () +main = defaultMain tests + + +tests :: TestTree +tests = + withResource startTestDatabase stopTestDatabase \getTestDatabase -> + testGroup "rel8" + [ testSelectTestTable getTestDatabase + , testWhere_ getTestDatabase + , testFilter getTestDatabase + , testLimit getTestDatabase + , testUnion getTestDatabase + , testDistinct getTestDatabase + , testExists getTestDatabase + , testOptional getTestDatabase + , testAnd getTestDatabase + , testOr getTestDatabase + , testNot getTestDatabase + , testBool getTestDatabase + , testAp getTestDatabase + , testDBType getTestDatabase + , testDBEq getTestDatabase + , testTableEquality getTestDatabase + , testFromString getTestDatabase + , testCatMaybeTable getTestDatabase + , testCatMaybe getTestDatabase + , testMaybeTable getTestDatabase + , testNestedTables getTestDatabase + , testMaybeTableApplicative getTestDatabase + , testLogicalFixities getTestDatabase + , testUpdate getTestDatabase + , testDelete getTestDatabase + , testSelectNestedPairs getTestDatabase + , testSelectArray getTestDatabase + , testNestedMaybeTable getTestDatabase + ] + + where + + startTestDatabase = do + db <- TmpPostgres.start >>= either throwIO return + + bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do + flip run conn do + sql "CREATE EXTENSION citext" + sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )" + + return db + + stopTestDatabase = TmpPostgres.stop + + +databasePropertyTest + :: TestName + -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ()) + -> IO TmpPostgres.DB -> TestTree +databasePropertyTest testName f getTestDatabase = + withResource connect release $ \c -> + testProperty testName $ property do + connection <- liftIO c + f \g -> test $ rollingBack connection $ g connection + + where + + connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase + + +data TestTable f = TestTable + { testTableColumn1 :: Rel8.Column f Text + , testTableColumn2 :: Rel8.Column f Bool + } + deriving stock Generic + deriving anyclass Rel8.Rel8able + + +deriving stock instance Eq (TestTable Result) +deriving stock instance Ord (TestTable Result) +deriving stock instance Show (TestTable Result) + + +testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name) +testTableSchema = + Rel8.TableSchema + { name = "test_table" + , schema = Nothing + , columns = TestTable + { testTableColumn1 = "column1" + , testTableColumn2 = "column2" + } + } + + +testSelectTestTable :: IO TmpPostgres.DB -> TestTree +testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + void do + liftIO $ Rel8.insert connection + Rel8.Insert + { into = testTableSchema + , rows = map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NumberOfRowsAffected + } + + selected <- liftIO $ Rel8.select connection do + Rel8.each testTableSchema + + sort selected === sort rows + + cover 1 "Empty" $ null rows + cover 1 "Singleton" $ null $ drop 1 rows + cover 1 ">1 row" $ not $ null $ drop 1 rows + + +testWhere_ :: IO TmpPostgres.DB -> TestTree +testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable + + magicBool <- forAll Gen.bool + + let expected = filter (\t -> testTableColumn2 t == magicBool) rows + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + t <- Rel8.values $ Rel8.lit <$> rows + Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool + return t + + sort selected === sort expected + + cover 1 "No results" $ null expected + cover 1 "Some results" $ not $ null expected + cover 1 "All results" $ expected == rows + + +testFilter :: IO TmpPostgres.DB -> TestTree +testFilter = databasePropertyTest "filter" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable + + transaction \connection -> do + let expected = filter testTableColumn2 rows + + selected <- liftIO $ Rel8.select connection + $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows) + + sort selected === sort expected + + cover 1 "No results" $ null expected + cover 1 "Some results" $ not $ null expected + cover 1 "All results" $ expected == rows + + +testLimit :: IO TmpPostgres.DB -> TestTree +testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable + + n <- forAll $ Gen.integral (Range.linear 0 10) + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.limit n $ Rel8.values (Rel8.lit <$> rows) + + diff (length selected) (<=) (fromIntegral n) + + for_ selected \row -> + diff row elem rows + + cover 1 "n == 0" $ n == 0 + cover 1 "n < length rows" $ fromIntegral n < length rows + cover 1 "n == length rows" $ fromIntegral n == length rows + cover 1 "n >= length rows" $ fromIntegral n >= length rows + + +testUnion :: IO TmpPostgres.DB -> TestTree +testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do + left <- forAll $ Gen.list (Range.linear 0 10) genTestTable + right <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right) + + sort selected === sort (nub (left ++ right)) + + +testDistinct :: IO TmpPostgres.DB -> TestTree +testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection $ Rel8.distinct do + Rel8.values (Rel8.lit <$> rows) + + sort selected === nub (sort rows) + + cover 1 "Empty" $ null rows + cover 1 "Duplicates" $ not (null rows) && rows /= nub rows + cover 1 "No duplicates" $ not (null rows) && rows == nub rows + + +testExists :: IO TmpPostgres.DB -> TestTree +testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows + + case rows of + [] -> exists === [False] + _ -> exists === [True] + + +testOptional :: IO TmpPostgres.DB -> TestTree +testOptional = databasePropertyTest "Rel8.optional" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.optional $ Rel8.values (Rel8.lit <$> rows) + + case rows of + [] -> selected === [Nothing] + _ -> sort selected === fmap Just (sort rows) + + +testAnd :: IO TmpPostgres.DB -> TestTree +testAnd = databasePropertyTest "AND (&&.)" \transaction -> do + (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ + Rel8.lit x Rel8.&&. Rel8.lit y + + result === (x && y) + + +testOr :: IO TmpPostgres.DB -> TestTree +testOr = databasePropertyTest "OR (||.)" \transaction -> do + (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ + Rel8.lit x Rel8.||. Rel8.lit y + + result === (x || y) + + +testLogicalFixities :: IO TmpPostgres.DB -> TestTree +testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do + (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ + Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x + + result === (u || v && w == x) + + +testNot :: IO TmpPostgres.DB -> TestTree +testNot = databasePropertyTest "NOT (not_)" \transaction -> do + x <- forAll Gen.bool + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ + Rel8.not_ $ Rel8.lit x + + result === not x + + +testBool :: IO TmpPostgres.DB -> TestTree +testBool = databasePropertyTest "ifThenElse_" \transaction -> do + (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ + Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x) + + result === if x then y else z + + +testAp :: IO TmpPostgres.DB -> TestTree +testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do + (rows1, rows2) <- forAll $ + liftA2 (,) + (Gen.list (Range.linear 1 10) genTestTable) + (Gen.list (Range.linear 1 10) genTestTable) + + transaction \connection -> do + result <- liftIO $ Rel8.select connection $ do + liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2)) + + sort result === sort (liftA2 (,) rows1 rows2) + + +testDBType :: IO TmpPostgres.DB -> TestTree +testDBType getTestDatabase = testGroup "DBType instances" + [ dbTypeTest "Bool" Gen.bool + , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128) + , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "Day" genDay + , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded + , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded + , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128) + , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "LocalTime" genLocalTime + , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "TimeOfDay" genTimeOfDay + , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime + , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 + ] + + where + dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree + dbTypeTest name generator = testGroup name + [ databasePropertyTest name (t (==) generator) getTestDatabase + , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase + ] + + t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a) + => (a -> a -> Bool) + -> Gen a + -> ((Connection -> TestT IO ()) -> PropertyT IO b) + -> PropertyT IO b + t eq generator transaction = do + x <- forAll generator + + transaction \connection -> do + [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x) + diff res eq x + + genDay :: Gen Day + genDay = do + year <- Gen.integral (Range.linear 1970 3000) + month <- Gen.integral (Range.linear 1 12) + day <- Gen.integral (Range.linear 1 31) + Gen.just $ pure $ fromGregorianValid year month day + + genDiffTime :: Gen DiffTime + genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401) + + genTimeOfDay :: Gen TimeOfDay + genTimeOfDay = do + hour <- Gen.integral (Range.linear 0 23) + minute <- Gen.integral (Range.linear 0 59) + sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59) + Gen.just $ pure $ makeTimeOfDayValid hour minute sec + + genLocalTime = LocalTime <$> genDay <*> genTimeOfDay + + genWord32 :: Gen Word32 + genWord32 = Gen.integral Range.linearBounded + + +testDBEq :: IO TmpPostgres.DB -> TestTree +testDBEq getTestDatabase = testGroup "DBEq instances" + [ dbEqTest "Bool" Gen.bool + , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded + , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded + , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode + ] + + where + dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree + dbEqTest name generator = testGroup name + [ databasePropertyTest name (t generator) getTestDatabase + , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase + ] + + t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a) + => Gen a + -> ((Connection -> TestT IO ()) -> PropertyT IO ()) + -> PropertyT IO () + t generator transaction = do + (x, y) <- forAll (liftA2 (,) generator generator) + + transaction \connection -> do + [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y + res === (x == y) + + cover 1 "Equal" $ x == y + cover 1 "Not Equal" $ x /= y + + +testTableEquality :: IO TmpPostgres.DB -> TestTree +testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do + (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable + + transaction \connection -> do + [eq] <- liftIO $ Rel8.select connection do + pure $ Rel8.lit x Rel8.==: Rel8.lit y + + eq === (x == y) + + cover 1 "Equal" $ x == y + cover 1 "Not Equal" $ x /= y + + +testFromString :: IO TmpPostgres.DB -> TestTree +testFromString = databasePropertyTest "FromString" \transaction -> do + str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode + + transaction \connection -> do + [result] <- liftIO $ Rel8.select connection $ pure $ fromString str + result === pack str + + +testCatMaybeTable :: IO TmpPostgres.DB -> TestTree +testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + testTable <- Rel8.values $ Rel8.lit <$> rows + Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable) + + sort selected === sort (filter testTableColumn2 rows) + + +testCatMaybe :: IO TmpPostgres.DB -> TestTree +testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do + rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool + + transaction \connection -> do + selected <- evalM $ liftIO $ Rel8.select connection do + Rel8.catNull =<< Rel8.values (map Rel8.lit rows) + + sort selected === sort (catMaybes rows) + + +testMaybeTable :: IO TmpPostgres.DB -> TestTree +testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do + (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection $ + Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows)) + + case rows of + [] -> selected === [def] + _ -> sort selected === sort rows + + +data TwoTestTables f = + TwoTestTables + { testTable1 :: TestTable f + , testTable2 :: TestTable f + } + deriving stock Generic + deriving anyclass Rel8.Rel8able + + +deriving stock instance Eq (TwoTestTables Result) +deriving stock instance Ord (TwoTestTables Result) +deriving stock instance Show (TwoTestTables Result) + + +testNestedTables :: IO TmpPostgres.DB -> TestTree +testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do + rows <- forAll do + Gen.list (Range.linear 0 10) $ + liftA2 TwoTestTables genTestTable genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.values (Rel8.lit <$> rows) + + sort selected === sort rows + + +testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree +testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do + rows1 <- genRows + rows2 <- genRows + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1)) + bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2)) + pure $ liftA2 (,) as bs + + case (rows1, rows2) of + ([], []) -> selected === [Nothing] + ([], bs) -> selected === (Nothing <$ bs) + (as, []) -> selected === (Nothing <$ as) + (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs) + where + genRows :: PropertyT IO [TestTable Result] + genRows = forAll do + Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True) + +rollingBack + :: (MonadBaseControl IO m, MonadIO m) + => Connection -> m a -> m a +rollingBack connection = + bracket_ + (liftIO (run (sql "BEGIN") connection)) + (liftIO (run (sql "ROLLBACK") connection)) + + +genTestTable :: Gen (TestTable Result) +genTestTable = do + testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum + testTableColumn2 <- Gen.bool + return TestTable{..} + + +testUpdate :: IO TmpPostgres.DB -> TestTree +testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do + rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable + + transaction \connection -> do + void $ liftIO $ Rel8.insert connection + Rel8.Insert + { into = testTableSchema + , rows = map Rel8.lit $ Map.keys rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NumberOfRowsAffected + } + + void $ liftIO $ Rel8.update connection + Rel8.Update + { target = testTableSchema + , set = \r -> + let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows + in + foldl + ( \e (x, y) -> + Rel8.bool + e + y + ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&. + testTableColumn2 r Rel8.==. testTableColumn2 x + ) + ) + r + updates + , updateWhere = \_ -> Rel8.lit True + , returning = Rel8.NumberOfRowsAffected + } + + selected <- liftIO $ Rel8.select connection do + Rel8.each testTableSchema + + sort selected === sort (Map.elems rows) + + cover 1 "Empty" $ null rows + cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows + cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows + + +testDelete :: IO TmpPostgres.DB -> TestTree +testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable + + transaction \connection -> do + void $ liftIO $ Rel8.insert connection + Rel8.Insert + { into = testTableSchema + , rows = map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NumberOfRowsAffected + } + + deleted <- + liftIO $ Rel8.delete connection + Rel8.Delete + { from = testTableSchema + , deleteWhere = testTableColumn2 + , returning = Rel8.Projection id + } + + selected <- liftIO $ Rel8.select connection do + Rel8.each testTableSchema + + sort (deleted <> selected) === sort rows + + +newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) } + deriving stock Generic + deriving anyclass Rel8.Rel8able + +deriving stock instance Eq (HKNestedPair Result) +deriving stock instance Ord (HKNestedPair Result) +deriving stock instance Show (HKNestedPair Result) + + +testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree +testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.values $ map Rel8.lit rows + + sort selected === sort rows + + +testSelectArray :: IO TmpPostgres.DB -> TestTree +testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do + rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + Rel8.many $ Rel8.values (map Rel8.lit rows) + + selected === [foldMap pure rows] + + selected' <- liftIO $ Rel8.select connection $ Rel8.catListTable =<< do + Rel8.many $ Rel8.values (map Rel8.lit rows) + + selected' === rows + + +data NestedMaybeTable f = NestedMaybeTable + { nmt1 :: Rel8.Column f Bool + , nmt2 :: Rel8.HMaybe f (TestTable f) + } + deriving stock Generic + deriving anyclass Rel8.Rel8able + + +deriving stock instance Eq (NestedMaybeTable Result) +deriving stock instance Ord (NestedMaybeTable Result) +deriving stock instance Show (NestedMaybeTable Result) + + +testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree +testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do + let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) } + + transaction \connection -> do + selected <- liftIO $ Rel8.select connection do + x <- Rel8.values [Rel8.lit example] + pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x) + + selected === [True]