From 6367bf81a3de5191817eb2b177082548614ab11b Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Wed, 18 Jan 2017 13:54:01 +0000 Subject: [PATCH] Genesis --- ChangeLog.md | 5 + LICENSE | 30 ++++ OpaleyeStub.hs | 114 +++++++++++++ Rel8.hs | 408 +++++++++++++++++++++++++++++++++++++++++++++++ Setup.hs | 2 + oneliner-test.hs | 42 +++++ rel8.cabal | 25 +++ 7 files changed, 626 insertions(+) create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 OpaleyeStub.hs create mode 100644 Rel8.hs create mode 100644 Setup.hs create mode 100644 oneliner-test.hs create mode 100644 rel8.cabal diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..5e183ce --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for rel8 + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..bb74040 --- /dev/null +++ b/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. diff --git a/OpaleyeStub.hs b/OpaleyeStub.hs new file mode 100644 index 0000000..fa74d56 --- /dev/null +++ b/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 diff --git a/Rel8.hs b/Rel8.hs new file mode 100644 index 0000000..c26558a --- /dev/null +++ b/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 + +-} diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/oneliner-test.hs b/oneliner-test.hs new file mode 100644 index 0000000..146d73a --- /dev/null +++ b/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 diff --git a/rel8.cabal b/rel8.cabal new file mode 100644 index 0000000..bd69cad --- /dev/null +++ b/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 \ No newline at end of file