Add Rel8.TH.deriveRel8able

docs/tutorial.rst

@@ -22,7 +22,7 @@ imports throughout this guide::
   {-# language TypeApplications #-}
   {-# language TypeFamilies #-}
 
-  import Prelude
+  import Prelude hiding (filter)
   import Rel8
 
 The Example Schema
@@ -104,9 +104,9 @@ And similarly, the ``project`` table::
     deriving stock (Generic)
     deriving anyclass (Rel8able)
 
-To show query results in this documentation, we'll also need ``Show`` instances:
-Unfortunately these definitions look a bit scary, but they are essentially just
-``deriving (Show)``::
+To show query results in this documentation, we'll also need ``Show``
+instances: Unfortunately these definitions look a bit scary, but they are
+essentially just ``deriving (Show)``::
 
   deriving stock instance f ~ Result => Show (Author f)
   deriving stock instance f ~ Result => Show (Project f)
@@ -164,11 +164,11 @@ can use ``namesFromLabelsWith``, which takes a transformation function.
 .. note::
 
   You might be wondering why this information isn't in the definitions of
-  ``Author`` and ``Project`` above. Rel8 decouples ``TableSchema`` from the data
-  types themselves, as not all tables you define will necessarily have a schema.
-  For example, Rel8 allows you to define helper types to simplify the types of
-  queries - these tables only exist at query time, but there is no corresponding
-  base table. We'll see more on this idea later!
+  ``Author`` and ``Project`` above. Rel8 decouples ``TableSchema`` from the
+  data types themselves, as not all tables you define will necessarily have a
+  schema.  For example, Rel8 allows you to define helper types to simplify the
+  types of queries - these tables only exist at query time, but there is no
+  corresponding base table. We'll see more on this idea later!
 
 With these table definitions, we can now start writing some queries!
 
@@ -187,13 +187,14 @@ required knowledge.
 
 To start, we'll look at one of the simplest queries possible - a basic ``SELECT
 * FROM`` statement. To select all rows from a table, we use ``each``, and
-supply a ``TableSchema``. So to select all ``project`` rows, we can write::
+  supply a ``TableSchema``. So to select all ``project`` rows, we can write::
 
   >>> :t each projectSchema
   each projectSchema :: Query (Project Expr)
 
 Notice that ``each`` gives us a ``Query`` that yields ``Project Expr`` rows. To
-see what this means, let's have a look at a single field of a ``Project Expr``::
+see what this means, let's have a look at a single field of a ``Project
+Expr``::
 
   >>> let aProjectExpr = undefined :: Project Expr
   >>> :t projectAuthorId aProjectExpr
@@ -220,8 +221,8 @@ Haskell values. Studying ``projectAuthorId`` again, we have::
   >>> :t projectAuthorId aProjectResult
   projectAuthorId aProjectResult :: AuthorId
 
-Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no
-wrappping type at all.
+Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no wrappping
+type at all.
 
 Putting this all together, we can run our first query::
 
@@ -276,9 +277,9 @@ returned rows. We could write::
     where_ $ projectAuthorId project ==. authorId author
     return (project, author)
 
-but doing this every time you need a join can obscure the meaning of the
-query you're writing. A good practice is to introduce specialised functions
-for the particular joins in your database. In our case, this would be::
+but doing this every time you need a join can obscure the meaning of the query
+you're writing. A good practice is to introduce specialised functions for the
+particular joins in your database. In our case, this would be::
 
   projectsForAuthor :: Author Expr -> Query (Project Expr)
   projectsForAuthor a = each projectSchema >>= filter \p ->
@@ -347,8 +348,8 @@ structures. Earlier we saw an example of returning authors with their projects,
 but the query didn't do a great job of describing the one-to-many relationship
 between authors and their projects.
 
-Let's look again at a query that returns authors and their projects, and
-focus on the /type/ of that query::
+Let's look again at a query that returns authors and their projects, and focus
+on the /type/ of that query::
 
   projectsForAuthor a = each projectSchema >>= filter \p ->
     projectAuthorId p ==. authorId a
@@ -363,7 +364,6 @@ focus on the /type/ of that query::
   select conn authorsAndProjects
     :: MonadIO m => m [(Author Result, Project Result)]
 
-
 Our query gives us a single list of pairs of authors and projects. However,
 with our domain knowledge of the schema, this isn't a great type - what we'd
 rather have is a list of pairs of authors and /lists/ of projects. That is,

rel8.cabal

@@ -34,6 +34,8 @@ library
     , scientific
     , semialign
     , semigroupoids
+    , template-haskell
+    , th-abstraction
     , text
     , these
     , time
@@ -55,6 +57,7 @@ library
     Rel8.Expr.Text
     Rel8.Expr.Time
     Rel8.Tabulate
+    Rel8.TH
 
   other-modules:
     Rel8.Aggregate

src/Rel8/Generic/Rel8able.hs

@@ -16,11 +16,9 @@
 {-# language UndecidableInstances #-}
 
 module Rel8.Generic.Rel8able
-  ( KRel8able, Rel8able
+  ( KRel8able, Rel8able(..)
   , Algebra
   , GRep
-  , GColumns, gfromColumns, gtoColumns
-  , GFromExprs, gfromResult, gtoResult
   , TSerialize, serialize, deserialize
   )
 where

src/Rel8/TH.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+module Rel8.TH (deriveRel8able) where
+
+import Prelude ((.), pure, (<$>), ($), fail, map, id, (==), (<>), show, last, error, otherwise)
+import Language.Haskell.TH (Name, Q, Dec, conT, Type (AppT, ConT, VarT, TupleT), newName, conP, varP, nameBase, conE, varE, appsE, TyVarBndr(..), varT, tupleT)
+import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName, datatypeVars)
+import Rel8.Generic.Rel8able ( Rel8able(..) )
+import Rel8.Schema.Result (Result)
+import Data.Foldable (foldl', toList )
+import Rel8.Schema.HTable.Identity (HIdentity(HIdentity))
+import Rel8.Schema.HTable.Product (HProduct(HProduct))
+import Data.Traversable (for)
+import Data.Functor.Identity (Identity(Identity), runIdentity)
+import Rel8.Kind.Context (SContext(..))
+import Data.Functor ( (<&>) )
+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
+import Rel8.Column ( Column )
+import Rel8.Expr ( Expr )
+import Rel8.Table ( Columns )
+
+deriveRel8able :: Name -> Q [Dec]
+deriveRel8able name = do
+  DatatypeInfo{ datatypeVars = (last -> fBinder), datatypeCons = [ ConstructorInfo{ constructorName, constructorFields = f1:fs, constructorVariant = RecordConstructor (fieldName1:fieldNames) } ]} <- reifyDatatype name
+
+  let f = case fBinder of
+            PlainTV a _    -> a
+            KindedTV a _ _ -> a
+
+  contextName <- newName "context"
+  name1 <- newName $ nameBase fieldName1
+  names <- for fieldNames $ newName . nameBase
+
+  let allNames = name1 :| names
+
+  let
+    unpackP =
+      foldl'
+        (\e n -> [p| HProduct $e (HIdentity $( varP n )) |])
+        [p| HIdentity $( varP name1 ) |]
+        names
+
+    unmk (x :| xs) =
+      foldl'
+        (\e n -> [| HProduct $e (HIdentity $n) |])
+        [| HIdentity $x |]
+        xs
+
+    mk xs = appsE (conE constructorName : toList xs)
+
+  id
+    [d| instance Rel8able $( conT name ) where
+          type GColumns $( conT name) =
+            $(
+              foldl'
+                (\t x -> [t| HProduct $t $(unColumn f x) |])
+                (unColumn f f1)
+                fs
+            )
+
+          type GFromExprs $( conT name ) =
+            $( conT name ) Result
+
+          gfromColumns $( varP contextName ) $unpackP =
+            case $( varE contextName ) of
+              SAggregate -> $( mk $ varE <$> allNames )
+              SExpr      -> $( mk $ varE <$> allNames )
+              SField     -> $( mk $ varE <$> allNames )
+              SName      -> $( mk $ varE <$> allNames )
+              SResult    -> $( mk $ allNames <&> \x -> [| runIdentity $( varE x ) |] )
+
+          gtoColumns $(varP contextName) $( conP constructorName (map varP (name1:names)) ) =
+            case $( varE contextName ) of
+              SAggregate -> $( unmk $ varE <$> allNames )
+              SExpr      -> $( unmk $ varE <$> allNames )
+              SField     -> $( unmk $ varE <$> allNames )
+              SName      -> $( unmk $ varE <$> allNames )
+              SResult    -> $( unmk $ allNames <&> \x -> [| Identity $( varE x ) |] )
+
+          gfromResult $unpackP =
+            $( mk $ allNames <&> \x -> [| runIdentity $( varE x ) |] )
+
+          gtoResult $( conP constructorName (map varP (name1:names)) ) =
+            $( unmk $ allNames <&> \x -> [| Identity $( varE x ) |] )
+    |]
+
+
+unColumn :: Name -> Type -> Q Type
+unColumn _ (AppT (AppT (ConT _Column) _f) t) | _Column == ''Column = [t| HIdentity $(pure t) |]
+unColumn f t = [t| Columns $(instantiate t) |]
+  where
+    instantiate = \case
+      VarT v | v == f    -> [t| Expr |]
+             | otherwise -> varT v
+
+      AppT x y -> [t| $(instantiate x) $(instantiate y) |]
+
+      TupleT n -> tupleT n
+
+      ConT n -> conT n
+
+      other -> error $ show other

tests/Rel8/Generic/Rel8able/Test.hs

@@ -5,6 +5,7 @@
 {-# language DuplicateRecordFields #-}
 {-# language FlexibleInstances #-}
 {-# language MultiParamTypeClasses #-}
+{-# language TemplateHaskell #-}
 {-# language TypeFamilies #-}
 {-# language UndecidableInstances #-}
 
@@ -21,6 +22,7 @@ import Prelude
 
 -- rel8
 import Rel8
+import Rel8.TH ( deriveRel8able )
 
 -- text
 import Data.Text ( Text )
@@ -30,16 +32,18 @@ data TableTest f = TableTest
   { foo :: Column f Bool
   , bar :: Column f (Maybe Bool)
   }
-  deriving stock Generic
-  deriving anyclass Rel8able
+
+
+deriveRel8able ''TableTest
 
 
 data TablePair f = TablePair
   { foo :: Column f Bool
   , bars :: (Column f Text, Column f Text)
   }
-  deriving stock Generic
-  deriving anyclass Rel8able
+
+
+deriveRel8able ''TablePair
 
 
 data TableMaybe f = TableMaybe