Explore anonymous querying with labels

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)) =>

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)))))

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

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;
 }

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