mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-18 04:10:25 +03:00
Drop haskell -> expr functional dep & drop Col
This commit is contained in:
parent
29f1fdd458
commit
0d71e38529
1
Rel8.hs
1
Rel8.hs
@ -60,7 +60,6 @@ module Rel8
|
|||||||
, bool
|
, bool
|
||||||
, MaybeTable, isTableNull, maybeTable
|
, MaybeTable, isTableNull, maybeTable
|
||||||
, TheseTable, theseTable
|
, TheseTable, theseTable
|
||||||
, Col(..)
|
|
||||||
|
|
||||||
-- * Expressions
|
-- * Expressions
|
||||||
, Expr, coerceExpr, dbShow, case_
|
, Expr, coerceExpr, dbShow, case_
|
||||||
|
@ -193,10 +193,10 @@ delete
|
|||||||
delete conn f =
|
delete conn f =
|
||||||
O.runDelete conn tableDefinition (exprToColumn . toNullable . f)
|
O.runDelete conn tableDefinition (exprToColumn . toNullable . f)
|
||||||
|
|
||||||
queryRunner :: Table a b => O.QueryRunner a b
|
queryRunner :: forall a b. Table a b => O.QueryRunner a b
|
||||||
queryRunner =
|
queryRunner =
|
||||||
O.QueryRunner (void unpackColumns)
|
O.QueryRunner (void unpackColumns)
|
||||||
(const rowParser)
|
(const (rowParser @a))
|
||||||
(lengthOf (expressions . traverse))
|
(lengthOf (expressions . traverse))
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DefaultSignatures #-}
|
{-# LANGUAGE DefaultSignatures #-}
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
{-# LANGUAGE DeriveTraversable #-}
|
||||||
@ -19,7 +20,6 @@ import Data.Proxy
|
|||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Lens (Iso', from, iso, view)
|
import Control.Lens (Iso', from, iso, view)
|
||||||
import Data.Aeson (FromJSON, ToJSON)
|
|
||||||
import Data.Bifunctor ( Bifunctor, bimap )
|
import Data.Bifunctor ( Bifunctor, bimap )
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
@ -72,7 +72,7 @@ type family MkRowF a :: * -> * where
|
|||||||
-- You should not need to define your own instances of 'Table' in idiomatic
|
-- You should not need to define your own instances of 'Table' in idiomatic
|
||||||
-- @rel8@ usage - beyond simplying deriving an instance and using generics.
|
-- @rel8@ usage - beyond simplying deriving an instance and using generics.
|
||||||
class (Representable (RowF expr), Traversable (RowF expr)) =>
|
class (Representable (RowF expr), Traversable (RowF expr)) =>
|
||||||
Table expr haskell | expr -> haskell, haskell -> expr where
|
Table expr haskell | expr -> haskell where
|
||||||
|
|
||||||
-- | Every 'Table' is isomorphic to a 'Functor' with finite cardinality
|
-- | Every 'Table' is isomorphic to a 'Functor' with finite cardinality
|
||||||
-- (a 'Representable' functor). This type witnesses what that functor
|
-- (a 'Representable' functor). This type witnesses what that functor
|
||||||
@ -97,7 +97,7 @@ class (Representable (RowF expr), Traversable (RowF expr)) =>
|
|||||||
rowParser
|
rowParser
|
||||||
:: (Generic haskell, GTable (Rep expr) (Rep haskell))
|
:: (Generic haskell, GTable (Rep expr) (Rep haskell))
|
||||||
=> RowParser haskell
|
=> RowParser haskell
|
||||||
rowParser = fmap to growParser
|
rowParser = fmap to (growParser @(Rep expr))
|
||||||
|
|
||||||
default
|
default
|
||||||
expressions
|
expressions
|
||||||
@ -110,17 +110,17 @@ class (Representable (RowF expr), Traversable (RowF expr)) =>
|
|||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
class GTable expr haskell | expr -> haskell, haskell -> expr where
|
class GTable expr haskell | expr -> haskell where
|
||||||
growParser :: RowParser (haskell a)
|
growParser :: RowParser (haskell a)
|
||||||
gexpressions :: Iso' (expr a) (MkRowF expr O.PrimExpr)
|
gexpressions :: Iso' (expr a) (MkRowF expr O.PrimExpr)
|
||||||
|
|
||||||
instance GTable expr haskell => GTable (M1 i c expr) (M1 i c haskell) where
|
instance GTable expr haskell => GTable (M1 i c expr) (M1 i c haskell) where
|
||||||
growParser = M1 <$> growParser
|
growParser = M1 <$> growParser @expr
|
||||||
gexpressions = _M1 . gexpressions
|
gexpressions = _M1 . gexpressions
|
||||||
|
|
||||||
instance (GTable le lh, GTable re rh) =>
|
instance (GTable le lh, GTable re rh) =>
|
||||||
GTable (le :*: re) (lh :*: rh) where
|
GTable (le :*: re) (lh :*: rh) where
|
||||||
growParser = liftA2 (:*:) growParser growParser
|
growParser = liftA2 (:*:) (growParser @le) (growParser @re)
|
||||||
gexpressions =
|
gexpressions =
|
||||||
iso
|
iso
|
||||||
(\(l :*: r) -> Pair (view gexpressions l) (view gexpressions r))
|
(\(l :*: r) -> Pair (view gexpressions l) (view gexpressions r))
|
||||||
@ -129,7 +129,7 @@ instance (GTable le lh, GTable re rh) =>
|
|||||||
|
|
||||||
instance {-# OVERLAPPABLE #-}
|
instance {-# OVERLAPPABLE #-}
|
||||||
Table expr haskell => GTable (K1 i expr) (K1 i haskell) where
|
Table expr haskell => GTable (K1 i expr) (K1 i haskell) where
|
||||||
growParser = K1 <$> rowParser
|
growParser = K1 <$> rowParser @expr
|
||||||
gexpressions = _K1 . expressions
|
gexpressions = _K1 . expressions
|
||||||
|
|
||||||
instance DBType a =>
|
instance DBType a =>
|
||||||
@ -185,7 +185,7 @@ instance (Table expr haskell) => Table (MaybeTable expr) (Maybe haskell) where
|
|||||||
if fromMaybe True isNull'
|
if fromMaybe True isNull'
|
||||||
then Nothing <$
|
then Nothing <$
|
||||||
sequence_ (pureRep @(RowF expr) (fieldWith (\_ _ -> pure ())))
|
sequence_ (pureRep @(RowF expr) (fieldWith (\_ _ -> pure ())))
|
||||||
else fmap Just rowParser
|
else fmap Just (rowParser @expr)
|
||||||
|
|
||||||
-- | Project an expression out of a 'MaybeTable', preserving the fact that this
|
-- | Project an expression out of a 'MaybeTable', preserving the fact that this
|
||||||
-- column might be @null@. Like field selection.
|
-- column might be @null@. Like field selection.
|
||||||
@ -249,8 +249,8 @@ instance (Table exprA a, Table exprB b) => Table (TheseTable exprA exprB) (These
|
|||||||
TheseTable (view (from expressions) a) (view (from expressions) b)
|
TheseTable (view (from expressions) a) (view (from expressions) b)
|
||||||
|
|
||||||
rowParser = do
|
rowParser = do
|
||||||
ma <- rowParser
|
ma <- rowParser @(MaybeTable exprA)
|
||||||
mb <- rowParser
|
mb <- rowParser @(MaybeTable exprB)
|
||||||
case (ma, mb) of
|
case (ma, mb) of
|
||||||
(Just a, Just b) -> pure $ These a b
|
(Just a, Just b) -> pure $ These a b
|
||||||
(Just a, _) -> pure $ This a
|
(Just a, _) -> pure $ This a
|
||||||
@ -291,41 +291,11 @@ nullable a f b =
|
|||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
{- | A one column 'Table' of type @a@. This type is required for queries that
|
-- | Single 'Expr'essions are tables.
|
||||||
return only one column (for reasons of preserving type inference). It can
|
instance DBType a => Table (Expr a) a where
|
||||||
also be used to build "anonymous" tables, by joining multiple tables with
|
|
||||||
tupling.
|
|
||||||
|
|
||||||
=== Example: Querying a single column
|
|
||||||
|
|
||||||
@
|
|
||||||
data TestTable f = TestTable { col :: Col f "col" 'NoDefault Int}
|
|
||||||
|
|
||||||
oneCol :: Stream (Of (Col Int))
|
|
||||||
oneCol = select connection $ testColumn <$> queryTable
|
|
||||||
@
|
|
||||||
|
|
||||||
=== Example: Building tables out of single columns
|
|
||||||
|
|
||||||
@
|
|
||||||
data T1 f = TestTable { col1 :: Col f "col" 'NoDefault Int}
|
|
||||||
data T2 f = TestTable { col2 :: Col f "col" 'NoDefault Bool}
|
|
||||||
|
|
||||||
q :: Stream (Of (Col Int, Col Bool))
|
|
||||||
q = select connection $ proc () -> do
|
|
||||||
t1 <- queryTable -< ()
|
|
||||||
t2 <- queryTable -< ()
|
|
||||||
returnA -< (col1 t1, col2 t2)
|
|
||||||
@
|
|
||||||
-}
|
|
||||||
newtype Col a = Col { unCol :: a }
|
|
||||||
deriving (Show, ToJSON, FromJSON, Read, Eq, Ord)
|
|
||||||
|
|
||||||
-- | Single 'Expr'essions are tables, but the result will be wrapped in 'Col'.
|
|
||||||
instance DBType a => Table (Expr a) (Col a) where
|
|
||||||
type RowF (Expr a) = Identity
|
type RowF (Expr a) = Identity
|
||||||
expressions = dimap (\(Expr a) -> return a) (fmap (Expr . runIdentity))
|
expressions = dimap (\(Expr a) -> return a) (fmap (Expr . runIdentity))
|
||||||
rowParser = fmap Col field
|
rowParser = field
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
traversePrimExprs
|
traversePrimExprs
|
||||||
|
Loading…
Reference in New Issue
Block a user