mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-05 21:29:35 +03:00
Explore anonymous querying with labels
This commit is contained in:
parent
7f4e764973
commit
995c4a25a0
9
Rel8.hs
9
Rel8.hs
@ -14,6 +14,7 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE UndecidableSuperClasses #-}
|
||||||
|
|
||||||
module Rel8
|
module Rel8
|
||||||
( -- $intro
|
( -- $intro
|
||||||
@ -31,7 +32,7 @@ module Rel8
|
|||||||
, Col(..)
|
, Col(..)
|
||||||
|
|
||||||
-- * Expressions
|
-- * Expressions
|
||||||
, Expr, coerceExpr, dbShow
|
, Expr(..), coerceExpr, dbShow
|
||||||
|
|
||||||
-- ** Equality
|
-- ** Equality
|
||||||
, DBEq, (==.), (?=.), in_, ilike
|
, DBEq, (==.), (?=.), in_, ilike
|
||||||
@ -92,6 +93,9 @@ module Rel8
|
|||||||
, dbFunction
|
, dbFunction
|
||||||
, nullaryFunction
|
, nullaryFunction
|
||||||
, dbBinOp
|
, dbBinOp
|
||||||
|
|
||||||
|
-- * Low-level details
|
||||||
|
, GenericBaseTable
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative (Const(..), liftA2)
|
import Control.Applicative (Const(..), liftA2)
|
||||||
@ -267,6 +271,9 @@ instance MapPrimExpr (Expr column) where
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- TODO Unsure if we want to assume this type of table
|
-- TODO Unsure if we want to assume this type of table
|
||||||
|
|
||||||
|
class (ADTRecord (table Expr),ADTRecord (table Schema),Constraints (table Schema) WitnessSchema,InferBaseTableAttrExpr (Rep (table Schema)) (Rep (table Expr)),Writer (Rep (table Schema)) (Rep (table Insert)),Generic (table Insert)) => GenericBaseTable table
|
||||||
|
instance (ADTRecord (table Expr),ADTRecord (table Schema),Constraints (table Schema) WitnessSchema,InferBaseTableAttrExpr (Rep (table Schema)) (Rep (table Expr)),Writer (Rep (table Schema)) (Rep (table Insert)),Generic (table Insert)) => GenericBaseTable table
|
||||||
|
|
||||||
-- | 'BaseTable' @name record@ specifies that there is a table named @name@, and
|
-- | 'BaseTable' @name record@ specifies that there is a table named @name@, and
|
||||||
-- the record type @record@ specifies the columns of that table.
|
-- the record type @record@ specifies the columns of that table.
|
||||||
class (KnownSymbol name, Table (table Expr) (table QueryResult)) =>
|
class (KnownSymbol name, Table (table Expr) (table QueryResult)) =>
|
||||||
|
63
Rel8/Anonymous.hs
Normal file
63
Rel8/Anonymous.hs
Normal file
@ -0,0 +1,63 @@
|
|||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE LiberalTypeSynonyms #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
|
|
||||||
|
module Rel8.Anonymous where
|
||||||
|
|
||||||
|
import Data.Profunctor
|
||||||
|
import Data.Proxy
|
||||||
|
import Data.Tagged
|
||||||
|
import Database.PostgreSQL.Simple.FromField (FromField)
|
||||||
|
import Database.PostgreSQL.Simple.FromRow (field)
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Labels
|
||||||
|
import Labels.Internal ((:=))
|
||||||
|
import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
|
||||||
|
import qualified Opaleye.Internal.PackMap as O
|
||||||
|
import qualified Opaleye.Internal.Table as O
|
||||||
|
import qualified Opaleye.Internal.TableMaker as O
|
||||||
|
import qualified Opaleye.Table as O hiding (required)
|
||||||
|
import Rel8
|
||||||
|
|
||||||
|
newtype Row a = Row { getRow :: a }
|
||||||
|
deriving (Has k v)
|
||||||
|
|
||||||
|
instance (KnownSymbol c1, FromField v1) => Table (Row (c1 := Expr v1)) (Row (c1 := v1)) where
|
||||||
|
rowParser = Row <$> fmap (Proxy :=) field
|
||||||
|
columnCount = Tagged 1
|
||||||
|
traversePrimExprs f (Row (p := (Expr a))) = Row . (p :=) . Expr <$> f a
|
||||||
|
|
||||||
|
instance (KnownSymbol c1,KnownSymbol c2,FromField v1,FromField v2) => Table (Row (c1 := Expr v1,c2 := Expr v2)) (Row (c1 := v1,c2 := v2)) where
|
||||||
|
rowParser = Row <$> ((,) <$> fmap (Proxy :=) field <*> fmap (Proxy :=) field)
|
||||||
|
columnCount = Tagged 2
|
||||||
|
traversePrimExprs f (Row (p := (Expr a),p2 := (Expr b))) =
|
||||||
|
Row <$> ((,) <$> ((p :=) . Expr <$> f a) <*> ((p2 :=) . Expr <$> f b))
|
||||||
|
|
||||||
|
class AnonymousTable a where
|
||||||
|
makeColumns :: proxy a -> a
|
||||||
|
|
||||||
|
instance (KnownSymbol c1, FromField v1, e1 ~ Expr v1) => AnonymousTable (c1 := e1) where
|
||||||
|
makeColumns _ = (Proxy := Expr (O.BaseTableAttrExpr (symbolVal (Proxy @c1))))
|
||||||
|
|
||||||
|
instance (KnownSymbol c1, FromField v1, KnownSymbol c2, FromField v2, e1 ~ Expr v1, e2 ~ Expr v2) => AnonymousTable (c1 := e1, c2 := e2) where
|
||||||
|
makeColumns _ = (Proxy := Expr (O.BaseTableAttrExpr (symbolVal (Proxy @c1))), Proxy := Expr (O.BaseTableAttrExpr (symbolVal (Proxy @c1))))
|
||||||
|
|
||||||
|
selectFrom :: forall columns haskell.
|
||||||
|
(AnonymousTable columns,Table (Row columns) (Row haskell))
|
||||||
|
=> String -> Query (Row columns)
|
||||||
|
selectFrom n =
|
||||||
|
O.queryTableExplicit
|
||||||
|
(O.ColumnMaker (lmap Row (O.PackMap traversePrimExprs)))
|
||||||
|
(O.Table n
|
||||||
|
(O.TableProperties (O.Writer (pure ()))
|
||||||
|
(O.View (makeColumns (Proxy @columns)))))
|
26
anon-queries.hs
Normal file
26
anon-queries.hs
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
{-# LANGUAGE Arrows, DataKinds, PartialTypeSignatures, TypeApplications, TypeOperators, OverloadedLabels #-}
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
import Labels
|
||||||
|
import Rel8
|
||||||
|
import Rel8.Anonymous
|
||||||
|
import qualified Streaming.Prelude as S
|
||||||
|
import Data.Int
|
||||||
|
|
||||||
|
users :: Query (Row ("userId" := Expr Int32, "userName" := Expr String))
|
||||||
|
users = selectFrom "users"
|
||||||
|
|
||||||
|
comments :: Query (Row ("userId" := Expr Int32, "comment" := Expr String))
|
||||||
|
comments = selectFrom "comments"
|
||||||
|
|
||||||
|
-- formattedComments :: QueryArr (Expr String, Expr String) -- Inferred
|
||||||
|
formattedComments = proc _ -> do
|
||||||
|
user <- users -< ()
|
||||||
|
comment <- comments -< ()
|
||||||
|
where_ -< get #userId user ==. get #userId comment
|
||||||
|
returnA -< (get #userName user, get #comment comment)
|
||||||
|
|
||||||
|
getComments :: IO _
|
||||||
|
getComments = S.toList_ $ select testConn formattedComments
|
||||||
|
|
||||||
|
testConn = undefined
|
@ -1,6 +1,6 @@
|
|||||||
{ mkDerivation, base, one-liner, opaleye, postgresql-simple
|
{ mkDerivation, base, one-liner, opaleye, postgresql-simple
|
||||||
, product-profunctors, profunctors, scientific, stdenv, streaming
|
, product-profunctors, profunctors, scientific, stdenv, streaming
|
||||||
, tagged, text, exceptions, free
|
, tagged, text, exceptions, free, labels
|
||||||
}:
|
}:
|
||||||
mkDerivation {
|
mkDerivation {
|
||||||
pname = "rel8";
|
pname = "rel8";
|
||||||
@ -9,6 +9,7 @@ mkDerivation {
|
|||||||
libraryHaskellDepends = [
|
libraryHaskellDepends = [
|
||||||
base one-liner opaleye postgresql-simple product-profunctors
|
base one-liner opaleye postgresql-simple product-profunctors
|
||||||
profunctors scientific streaming tagged text exceptions free
|
profunctors scientific streaming tagged text exceptions free
|
||||||
|
labels
|
||||||
];
|
];
|
||||||
license = stdenv.lib.licenses.bsd3;
|
license = stdenv.lib.licenses.bsd3;
|
||||||
}
|
}
|
||||||
|
@ -17,6 +17,7 @@ cabal-version: >=1.10
|
|||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules: Rel8
|
exposed-modules: Rel8
|
||||||
|
Rel8.Anonymous
|
||||||
Rel8.Text
|
Rel8.Text
|
||||||
Control.Monad.Rel8
|
Control.Monad.Rel8
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
@ -41,6 +42,7 @@ library
|
|||||||
, aeson
|
, aeson
|
||||||
, vector
|
, vector
|
||||||
, contravariant
|
, contravariant
|
||||||
|
, labels
|
||||||
-- hs-source-dirs:
|
-- hs-source-dirs:
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
Loading…
Reference in New Issue
Block a user