Genesis

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for rel8
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2017, Ollie 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:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of Ollie Charles nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"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 COPYRIGHT
+OWNER 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.

OpaleyeStub.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE RankNTypes #-}
+module OpaleyeStub where
+
+import Control.Arrow
+import Control.Category
+import Data.Profunctor
+import Data.Profunctor.Product
+
+-- import qualified Opaleye.Internal.Column as O
+-- import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
+-- import qualified Opaleye.Internal.Join as O
+-- import qualified Opaleye.Internal.PGTypes as O
+-- import qualified Opaleye.Internal.PackMap as O
+-- import qualified Opaleye.Internal.QueryArr as O
+-- import qualified Opaleye.Internal.RunQuery as O
+-- import qualified Opaleye.Internal.Table as O
+-- import qualified Opaleye.Internal.TableMaker as O
+-- import qualified Opaleye.Internal.Unpackspec as O
+-- import qualified Opaleye.Join as O
+-- import qualified Opaleye.RunQuery as O
+-- import qualified Opaleye.Table as O
+
+data PackMap a b s t =
+  PackMap (forall f. Applicative f =>
+                       (a -> f b) -> s -> f t)
+
+newtype Unpackspec columns columns' =
+  Unpackspec (PackMap PrimExpr PrimExpr columns columns')
+
+instance Functor (Unpackspec columns)
+instance Profunctor Unpackspec
+instance ProductProfunctor Unpackspec
+
+data Literal
+  = BoolLit Bool
+  | IntegerLit Integer
+  | NullLit
+
+data PrimExpr
+  = ConstExpr Literal
+  | BaseTableAttrExpr String
+
+newtype Column pgType = Column PrimExpr
+
+newtype NullMaker a b = NullMaker (a -> b)
+
+data QueryArr a b
+
+instance Functor (QueryArr a)
+instance Applicative (QueryArr a)
+instance Arrow QueryArr
+instance Category QueryArr
+
+type Query = QueryArr ()
+
+data QueryRunner columns haskells =
+  QueryRunner (Unpackspec columns ())
+              (columns -> RowParser haskells)
+              (columns -> Bool)
+
+data RowParser a
+
+instance Functor RowParser
+instance Applicative RowParser
+instance Monad RowParser
+
+data TableProperties writerColumns viewColumns = TableProperties
+   { tablePropertiesWriter :: Writer writerColumns viewColumns
+   , tablePropertiesView   :: View viewColumns }
+
+data View columns = View columns
+
+newtype Writer columns dummy =
+  Writer (forall f. Functor f =>
+          PackMap (f PrimExpr, String) () (f columns) ())
+
+data Table writerColumns viewColumns
+  = Table String (TableProperties writerColumns viewColumns)
+  | TableWithSchema String String (TableProperties writerColumns viewColumns)
+
+
+queryTableExplicit :: ColumnMaker tablecolumns columns
+                   -> Table a tablecolumns
+                   -> Query columns
+queryTableExplicit = undefined
+
+newtype ColumnMaker columns columns' =
+  ColumnMaker (PackMap PrimExpr PrimExpr columns columns')
+
+runQueryExplicit :: QueryRunner columns haskells
+                 -> Connection
+                 -> Query columns
+                 -> IO [haskells]
+runQueryExplicit = undefined
+
+data Connection
+
+leftJoinExplicit :: Unpackspec columnsL columnsL
+                 -> Unpackspec columnsR columnsR
+                 -> NullMaker columnsR nullableColumnsR
+                 -> Query columnsL -> Query columnsR
+                 -> ((columnsL, columnsR) -> Column PGBool)
+                 -> Query (columnsL, nullableColumnsR)
+leftJoinExplicit = undefined
+
+data PGBool
+
+class FromField a
+instance FromField Bool
+instance FromField Int
+instance FromField a => FromField (Maybe a)
+
+field :: FromField a => RowParser a
+field = undefined

Rel8.hs

@@ -0,0 +1,408 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Rel8
+  ( -- $intro
+
+    -- * Defining Tables
+    Column(..)
+  , HasDefault(..)
+  , Nullable(..)
+  , PGType(..)
+  , C
+  , BaseTable(..)
+
+    -- * Tables
+  , Table(..)
+  , leftJoin
+  , MaybeRow(..)
+  , Col
+
+    -- * Expressions
+  , Expr
+
+    -- * Literals
+  , Lit(..)
+
+    -- ** Operators
+  , (^/=^)
+
+    -- ** Null
+  , toNullable
+  , (?)
+
+    -- * Querying Tables
+  , select
+  , QueryResult
+
+    -- * Re-exported symbols
+  , Connection, Stream, Of, Generic
+
+    -- * Lower level details
+  , AsHaskell
+  ) where
+
+import Data.Tagged (Tagged(..))
+import Control.Applicative ((<$), liftA2)
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Data.Maybe (fromMaybe)
+import Data.Profunctor (dimap)
+import Data.Profunctor.Product ((***!))
+import Data.Proxy (Proxy(..))
+-- import Database.PostgreSQL.Simple (Connection)
+-- import Database.PostgreSQL.Simple.FromField (FromField)
+-- import Database.PostgreSQL.Simple.FromRow (RowParser, field)
+import GHC.Generics
+       (Generic, Rep, K1(..), M1(..), (:*:)(..), from, to)
+import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
+import Generics.OneLiner
+       (ADTRecord, Constraints, For(..), createA, gtraverse, op0)
+import Streaming (Of, Stream)
+import Streaming.Prelude (each)
+
+
+import qualified OpaleyeStub as O
+import OpaleyeStub (Connection, RowParser, field, FromField)
+
+--------------------------------------------------------------------------------
+-- | Indicate whether or not a column has a default value.
+data HasDefault
+  = HasDefault
+  | NoDefault
+
+--------------------------------------------------------------------------------
+-- | Indicate whether or not a column can take default values.
+data Nullable
+  = Nullable
+  | NotNullable
+
+--------------------------------------------------------------------------------
+{-| All metadata about a column in a table.
+
+    'Column' is used to specify information about individual columns in base
+    tables. While it is defined as a record, you construct 'Column's at the
+    type level where record syntax is unfortunately not available.
+
+    === __Example__
+
+    @
+    data Employee f =
+      Employee { employeeName :: C f ('Column "employee_name" 'NoDefault 'NotNullable 'PGText) }
+    @
+-}
+data Column schema = Column
+  { _columnName :: Symbol
+  , _columnHasDefault :: HasDefault
+  , _columnNullable :: Nullable
+  , _columnType :: schema
+  }
+
+--------------------------------------------------------------------------------
+-- | Database-side PostgreSQL expressions of a given type.
+newtype Expr schema = Expr O.PrimExpr
+
+--------------------------------------------------------------------------------
+-- | Map a schema definition into a set of expressions that would select those
+-- columns.
+class InferBaseTableAttrExpr schema expr where
+  baseTableAttrExpr :: schema a -> expr a
+
+instance (InferBaseTableAttrExpr schema expr) =>
+         InferBaseTableAttrExpr (M1 i c schema) (M1 i c expr) where
+  baseTableAttrExpr (M1 s) = M1 (baseTableAttrExpr s)
+
+instance ( InferBaseTableAttrExpr fSchema fExpr
+         , InferBaseTableAttrExpr gSchema gExpr
+         ) =>
+         InferBaseTableAttrExpr (fSchema :*: gSchema) (fExpr :*: gExpr) where
+  baseTableAttrExpr (l :*: r) = baseTableAttrExpr l :*: baseTableAttrExpr r
+
+instance InferBaseTableAttrExpr (K1 i (Tagged name String)) (K1 i (Expr a)) where
+  baseTableAttrExpr (K1 (Tagged name)) = K1 (Expr (O.BaseTableAttrExpr name))
+
+--------------------------------------------------------------------------------
+-- | Witness the schema definition for table columns.
+class WitnessSchema a where
+  schema :: a
+
+instance KnownSymbol name =>
+         WitnessSchema (Tagged name String) where
+  schema = Tagged (symbolVal (Proxy :: Proxy name))
+
+data Schema a
+
+--------------------------------------------------------------------------------
+class ToPrimExpr a where
+  toPrimExpr :: a -> O.PrimExpr
+
+instance ToPrimExpr (Expr column) where
+  toPrimExpr (Expr a) = a
+
+--------------------------------------------------------------------------------
+-- TODO Unsure if we want to assume this type of table
+
+class BaseTable (table :: (Column a -> *) -> *) where
+  tableName :: proxy table -> String
+  queryTable :: O.Query (table Expr)
+  default queryTable :: ( ADTRecord (table Expr)
+                        , ADTRecord (table Schema)
+                        , Constraints (table Expr) ToPrimExpr
+                        , Constraints (table Schema) WitnessSchema
+                        , InferBaseTableAttrExpr (Rep (table Schema)) (Rep (table Expr))) =>
+    O.Query (table Expr)
+  queryTable =
+    O.queryTableExplicit
+      (O.ColumnMaker
+         (O.PackMap
+            (\f ->
+               gtraverse (For :: For ToPrimExpr) (\s -> s <$ f (toPrimExpr s)))))
+      (O.Table
+         (tableName (Proxy :: Proxy table))
+         (O.TableProperties
+            (O.Writer (O.PackMap (\_ _ -> pure ())))
+            (O.View
+               (to
+                  (baseTableAttrExpr
+                     (from
+                        (
+                           (op0 (For :: For WitnessSchema) schema :: table Schema))))))))
+
+--------------------------------------------------------------------------------
+class Table expr haskell | expr -> haskell, haskell -> expr where
+  rowParser :: expr -> RowParser haskell
+  default rowParser :: ( ADTRecord haskell
+                       , Constraints haskell FromField
+                       , Generic haskell) =>
+    expr -> RowParser haskell
+  rowParser _ = head (createA (For :: For FromField) [field])
+
+  unpackColumns :: O.Unpackspec expr expr
+  default unpackColumns :: ( Generic expr
+                           , Constraints expr ToPrimExpr
+                           , ADTRecord expr) =>
+    O.Unpackspec expr expr
+  unpackColumns =
+    O.Unpackspec
+      (O.PackMap
+         (\f ->
+            gtraverse (For :: For ToPrimExpr) (\s -> s <$ f (toPrimExpr s))))
+
+--------------------------------------------------------------------------------
+type family C (f :: Column a -> *) (c :: Column a) :: * where
+  C Expr ('Column _name _def 'Nullable t) = Expr ('Null t)
+  C Expr ('Column _name _def 'NotNullable t) = Expr t
+
+  C QueryResult ('Column _name _def 'Nullable t) = AsHaskell ('Null t)
+  C QueryResult ('Column _name _def 'NotNullable t) = AsHaskell t
+
+  C Schema ('Column name _def _null _t) = Tagged name String
+
+--------------------------------------------------------------------------------
+-- TODO We really want this to be open, but that breaks the instance of
+-- res ~ AsHaskell a => Table (Expr a) (Col res)
+
+-- This is because knowing `Col res` *must* let you know `Expr a`, but if
+-- `AsHaskell` were open (and hence not necessarily injective), we can't work out
+-- what `a` would be. Bummer.
+type family AsHaskell (t :: k) :: *
+type instance AsHaskell 'PGInteger = Int
+type instance AsHaskell 'PGBoolean = Bool
+type instance AsHaskell ('Null a) = Maybe (AsHaskell a)
+
+--------------------------------------------------------------------------------
+data PGType
+  = PGInteger
+  | PGBoolean
+  | PGText
+  | PGReal
+
+--------------------------------------------------------------------------------
+data QueryResult column
+
+--------------------------------------------------------------------------------
+select
+  :: (MonadIO m, Table rows results)
+  => Connection -> O.Query rows -> Stream (Of results) m ()
+select connection query = do
+  results <-
+    liftIO $
+    O.runQueryExplicit
+      (O.QueryRunner
+         (void unpackColumns)
+         rowParser
+         (\_columns -> True) -- TODO Will we support 0-column queries?
+       )
+      connection
+      query
+  each results
+
+--------------------------------------------------------------------------------
+instance (Table lExpr lHaskell, Table rExpr rHaskell) =>
+         Table (lExpr, rExpr) (lHaskell, rHaskell) where
+  unpackColumns =
+    (unpackColumns :: O.Unpackspec lExpr lExpr) ***!
+    (unpackColumns :: O.Unpackspec rExpr rExpr)
+
+  rowParser (l, r) = liftA2 (,) (rowParser l) (rowParser r)
+
+--------------------------------------------------------------------------------
+data MaybeRow row = MaybeRow (Expr 'PGBoolean) row
+
+instance (Table expr haskell) =>
+         Table (MaybeRow expr) (Maybe haskell) where
+  unpackColumns =
+    dimap
+      (\(MaybeRow tag row) -> (tag, row))
+      (\(prim, expr) -> MaybeRow (Expr prim) expr)
+      (O.Unpackspec (O.PackMap (\f (Expr tag) -> f tag)) ***! unpackColumns)
+
+  rowParser (MaybeRow _ r) = do
+    isNull <- field
+    if fromMaybe True isNull
+      then return Nothing
+      else fmap Just (rowParser r)
+
+data Null a = Null a
+
+(?) :: MaybeRow a -> (a -> Expr b) -> Expr ('Null b)
+MaybeRow _ row ? f = case f row of Expr a -> Expr a
+
+--------------------------------------------------------------------------------
+leftJoin
+  :: (Table lExpr lHaskell, Table rExpr rHaskell)
+  => (lExpr -> rExpr -> Expr 'PGBoolean)
+  -> O.Query lExpr
+  -> O.Query rExpr
+  -> O.Query (lExpr,MaybeRow rExpr)
+leftJoin condition l r =
+  O.leftJoinExplicit
+    unpackColumns
+    (unpackColumns ***! unpackColumns)
+    (O.NullMaker (\(tag, t) -> MaybeRow tag t))
+    l
+    (liftA2 (,) (pure (lit False)) r)
+    (\(a, (_, b)) ->
+       case condition a b of
+         Expr e -> O.Column e)
+
+--------------------------------------------------------------------------------
+class haskell ~ AsHaskell expr =>
+      Lit haskell expr | haskell -> expr, expr -> haskell where
+  lit :: haskell -> Expr expr
+
+instance Lit Bool 'PGBoolean where
+  lit = Expr . O.ConstExpr . O.BoolLit
+
+instance Lit Int 'PGInteger where
+  lit = Expr . O.ConstExpr . O.IntegerLit . fromIntegral
+
+instance (AsHaskell a ~ b, Lit b a) =>
+         Lit (Maybe b) ('Null a) where
+  lit Nothing = Expr (O.ConstExpr O.NullLit)
+  lit (Just a) =
+    case lit a of
+      Expr e -> Expr e
+
+--------------------------------------------------------------------------------
+newtype Col a = Col a
+
+instance (FromField haskell, Lit haskell a) =>
+         Table (Expr a) (Col haskell) where
+  unpackColumns =
+    O.Unpackspec (O.PackMap (\f (Expr prim) -> fmap Expr (f prim)))
+  rowParser _ = fmap Col field
+
+--------------------------------------------------------------------------------
+(^/=^) :: Expr a -> Expr a -> Expr 'PGBoolean
+a ^/=^ b = undefined
+
+toNullable :: Expr a -> Expr ('Null a)
+toNullable (Expr a) = Expr a
+
+{- $intro
+
+   Welcome to @rel8@!
+
+   @rel8@ is a library that builds open the fantastic @opaleye@ to query
+   databases. 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, it should never
+     be a requirement that the user must provide a type signature to allow a
+     program to compile.
+
+   With that said, let's dive in and see an example of a program using @rel8@.
+
+   === Required language extensions and imports
+
+   @
+   { -# LANGUAGE
+         Arrows, DataKinds, DeriveGeneric, FlexibleInstances,
+         MultiParamTypeClasses #- }
+
+   import Control.Applicative
+   import Control.Arrow
+   import Rel8
+   @
+
+   To use @rel8@, you will need a few language extensions:
+
+   * @Arrows@ is necessary to use @proc@ notation. As with @opaleye@, @rel8@
+     uses arrows to guarantee queries are valid.
+
+   * @DataKinds@ is used to promote values to the type level when defining
+     table/column metadata.
+
+   * @DeriveGeneric@ is used to automatically derive functions from schema
+     information.
+
+   The others are used to provide the type system extensions needed by @rel8@.
+
+   === Defining base tables
+
+   In order to query a database of existing tables, we need to let @rel8@ know
+   about these tables, and the schema for each table. This is done by defining
+   a Haskell /record/ for each table in the database. These records should be
+   parameterised by a type variable @f@, and each column is a field in this
+   record, of type @C f ('Column ...)@. Let's see how that looks with some
+   example tables:
+
+   @
+   data Part f =
+     Part { partId     :: 'C' f (''Column' \"PID\" ''HasDefault' ''NotNullable' ''PGInteger')
+          , partName   :: 'C' f (''Column' \"PName\" ''NoDefault' ''NotNullable' ''PGText')
+          , partColor  :: 'C' f (''Column' \"Color\" ''NoDefault' ''NotNullable' ''PGInteger')
+          , partWeight :: 'C' f (''Column' \"Weight\" ''NoDefault' ''NotNullable' ''PGReal')
+          , partCity   :: 'C' f (''Column' \"City\" ''NoDefault' ''NotNullable' ''PGText')
+          } deriving (Generic)
+
+   instance 'BaseTable' Part where tableName = "Part"
+   @
+
+   The @Part@ table has 5 columns, each defined with the @C f ('Column ...)@
+   pattern. For each column, we are specifying:
+
+   1. The column name
+   2. Whether or not this column has a default value when inserting new rows.
+      In this case @partId@ does, as this is an auto-incremented primary key
+      managed by the database.
+   3. Whether or not the column can take @null@ values.
+   4. The type of the column.
+
+   === Querying tables
+
+   With tables defined, we are now ready to write some queries. All base
+
+-}

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

oneliner-test.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE
+      Arrows, DataKinds, DeriveGeneric, FlexibleInstances,
+      MultiParamTypeClasses #-}
+
+import Control.Arrow
+import Control.Applicative
+import Rel8
+import OpaleyeStub (Connection)
+
+data TestTable f = TestTable
+  { testColumnA :: C f ('Column "a" 'NoDefault 'NotNullable 'PGInteger)
+  , testColumnB :: C f ('Column "b" 'HasDefault 'Nullable 'PGInteger)
+  } deriving (Generic)
+
+instance BaseTable TestTable where
+  tableName _ = "test_table"
+
+instance Table (TestTable Expr) (TestTable QueryResult)
+
+testQuery :: Stream (Of (TestTable QueryResult, TestTable QueryResult)) IO ()
+testQuery = select testConn $
+  proc _ -> do
+    (l,r) <- liftA2 (,) queryTable queryTable -< ()
+    returnA -< (l,r)
+
+test1Col :: Stream (Of (Col Int)) IO ()
+test1Col = select testConn $
+  proc _ -> do
+    t <- queryTable -< ()
+    returnA -< testColumnA t
+
+testLeftJoin :: Stream (Of (TestTable QueryResult, Col (Maybe Int))) IO ()
+testLeftJoin =
+  select testConn $
+  fmap (\(l,r) -> (l, r ? testColumnA)) $
+  leftJoin
+    (\l r -> toNullable (testColumnA l) ^/=^ testColumnB r)
+    queryTable
+    queryTable
+
+testConn :: Connection
+testConn = undefined

rel8.cabal

@@ -0,0 +1,25 @@
+-- Initial rel8.cabal generated by cabal init.  For further documentation, 
+-- see http://haskell.org/cabal/users-guide/
+
+name:                rel8
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Ollie Charles
+maintainer:          ollie@ocharles.org.uk
+-- copyright:           
+category:            Database
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Rel8, OpaleyeStub
+  -- other-modules:       
+  other-extensions:    Arrows, ConstraintKinds, DataKinds, DefaultSignatures, DeriveGeneric, FlexibleContexts, FlexibleInstances, FunctionalDependencies, KindSignatures, PolyKinds, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances, RankNTypes
+  build-depends:       base >=4.10 && <4.11, tagged >=0.8 && <0.9, profunctors >=5.2 && <5.3, product-profunctors >=0.7 && <0.8, one-liner >=0.6 && <0.7, streaming >=0.1 && <0.2
+  -- hs-source-dirs:      
+  default-language:    Haskell2010
+  ghc-options:         -Wall