diff --git a/Rel8.hs b/Rel8.hs index 77c81d0..672bef2 100644 --- a/Rel8.hs +++ b/Rel8.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Rel8 ( -- $intro @@ -31,7 +32,7 @@ module Rel8 , Col(..) -- * Expressions - , Expr, coerceExpr, dbShow + , Expr(..), coerceExpr, dbShow -- ** Equality , DBEq, (==.), (?=.), in_, ilike @@ -92,6 +93,9 @@ module Rel8 , dbFunction , nullaryFunction , dbBinOp + + -- * Low-level details + , GenericBaseTable ) where 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 +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 -- the record type @record@ specifies the columns of that table. class (KnownSymbol name, Table (table Expr) (table QueryResult)) => diff --git a/Rel8/Anonymous.hs b/Rel8/Anonymous.hs new file mode 100644 index 0000000..8a467ae --- /dev/null +++ b/Rel8/Anonymous.hs @@ -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))))) diff --git a/anon-queries.hs b/anon-queries.hs new file mode 100644 index 0000000..4a05504 --- /dev/null +++ b/anon-queries.hs @@ -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 diff --git a/default.nix b/default.nix index 431d120..63bfa25 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ { mkDerivation, base, one-liner, opaleye, postgresql-simple , product-profunctors, profunctors, scientific, stdenv, streaming -, tagged, text, exceptions, free +, tagged, text, exceptions, free, labels }: mkDerivation { pname = "rel8"; @@ -9,6 +9,7 @@ mkDerivation { libraryHaskellDepends = [ base one-liner opaleye postgresql-simple product-profunctors profunctors scientific streaming tagged text exceptions free + labels ]; license = stdenv.lib.licenses.bsd3; } diff --git a/rel8.cabal b/rel8.cabal index 0eda423..b5a4cdb 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -17,6 +17,7 @@ cabal-version: >=1.10 library exposed-modules: Rel8 + Rel8.Anonymous Rel8.Text Control.Monad.Rel8 -- other-modules: @@ -41,6 +42,7 @@ library , aeson , vector , contravariant + , labels -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall \ No newline at end of file