Derive Rel8able using TemplateHaskell

.ghci

@@ -0,0 +1 @@
+:set -XDeriveAnyClass -XDeriveGeneric -XTemplateHaskell

bare_shell.nix

@@ -0,0 +1,4 @@
+let pkgs = (builtins.getFlake "nixpkgs").legacyPackages.x86_64-linux;
+in
+  pkgs.mkShell { buildInputs = with pkgs; [ghc cabal-install postgresql postgresql.dev zlib
+  pkg-config];}

cabal.project

@@ -9,3 +9,5 @@ source-repository-package
 
 allow-newer: base16:base, base16:deepseq, base16:text
 allow-newer: *:base, *:template-haskell, *:ghc-prim
+
+tests: true

rel8-internal/src/Rel8/Internal/Generic/Rel8able.hs

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

rel8-internal/src/Rel8/Internal/Schema/HTable/Label.hs

@@ -7,7 +7,7 @@
 {-# language TypeFamilies #-}
 
 module Rel8.Internal.Schema.HTable.Label
-  ( HLabel, hlabel, hrelabel, hunlabel
+  ( HLabel(..), hlabel, hrelabel, hunlabel
   , hproject
   )
 where

rel8/rel8.cabal

@@ -28,6 +28,9 @@ library
     , product-profunctors
     , semigroupoids
     , time
+    , containers
+    , template-haskell
+    , th-abstraction
 
   default-language:
     Haskell2010
@@ -45,6 +48,7 @@ library
 
   hs-source-dirs:
     src
+
   exposed-modules:
     Rel8
     Rel8.Array
@@ -55,6 +59,7 @@ library
     Rel8.Expr.Time
     Rel8.Range
     Rel8.Tabulate
+    Rel8.TH
 
 test-suite tests
   type:             exitcode-stdio-1.0
@@ -84,6 +89,7 @@ test-suite tests
 
   other-modules:
     Rel8.Generic.Rel8able.Test
+    Rel8.TH.Rel8able.Test
 
   main-is:          Main.hs
   hs-source-dirs:   tests

rel8/src/Rel8/TH.hs

@@ -0,0 +1,242 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
+module Rel8.TH (deriveRel8able, parseDatatype) where
+
+import Prelude hiding (foldr1)
+import Rel8.Internal.Table.Serialize ( ToExprs )
+import Language.Haskell.TH (Q)
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Language.Haskell.TH.Datatype (reifyDatatype, DatatypeInfo (..), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant)
+import qualified Language.Haskell.TH.Datatype as TH.Datatype
+import Rel8.Internal.Generic.Rel8able ( Rel8able(..), Serialize, serialize, deserialize)
+import Rel8.Internal.Schema.Result (Result)
+import Rel8.Internal.Schema.HTable.Product (HProduct(HProduct))
+import Rel8.Internal.Kind.Context (SContext(..))
+import Rel8.Internal.Column ( Column )
+import Rel8.Internal.Expr ( Expr )
+import Rel8.Internal.Table (Columns, toColumns, fromColumns, Transpose)
+import Rel8.Internal.Schema.Kind (Context)
+import Data.List (unsnoc)
+import Rel8.Internal.Schema.HTable.Label (HLabel(..))
+import Data.Proxy (Proxy(Proxy))
+import qualified Data.Map.Strict as M
+import Data.Type.Equality (type (==))
+import Control.Monad (zipWithM)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Foldable1 (foldr1)
+import Data.Foldable (toList)
+import Rel8.Internal.Schema.HTable.Identity (HIdentity)
+
+
+-- We derive a Rel8able instance using TH.
+-- At it's core a Rel8able instance is a bijection between a datatype and the the SQL columns corresponding to its fields.
+-- We only support datatypes with one constructor.
+-- The datatype must have exactly one type arg and it is the index for our HKD stuff.
+-- Question: Can we support multiple type args?
+---
+-- We have three types of fields:
+-- 1) Column f Text : Directly using Column, easy. This is just a special case of (3)
+-- 2) OtherType f : They embed another Rel8able type
+-- 3) TabledType : They embed a type with a table instance.
+--     eg, we might see something like (Column f Text, Column f Bool). (,) has a Table instance,
+--     so we know how to map this type to SQL columns.
+--
+-- We represent a vector of SQL columns with basically:
+-- HLabel "field label" (HIdentity Text) `HProduct` HLabel "another field" (HIdentity Bool) ...
+-- Nothing too complicated here. I'm not sure if we are allowed to leave the HLabels out or if that will cause everything to explode.
+-- This H* stuff is also used to thread around contexts if you look at the definitions of these things
+
+data ParsedDatatype =
+  ParsedDatatype
+  { name :: TH.Name
+  , conName :: TH.Name
+  , fBinder :: TH.Name
+  , fields :: NonEmpty ParsedField
+  }
+  deriving (Show)
+
+data ParsedField =
+  ParsedField
+  { fieldSelector :: Maybe TH.Name
+  , fieldVariant :: ParsedFieldVariant
+  , fieldType :: TH.Type
+  , fieldColumnType :: TH.Type
+  , fieldFreshName :: TH.Name
+  }
+  deriving (Show)
+
+data ParsedFieldVariant = TableField
+  deriving (Show)
+
+-- | 'fail' but indicate that the failure is coming from our code
+prettyFail :: String -> Q a
+prettyFail str = fail $ "deriveRel8able: " ++ str
+
+parseDatatype :: DatatypeInfo -> Q ParsedDatatype
+parseDatatype datatypeInfo = do
+  constructor <-
+    -- Check that it only has one constructor
+    case datatypeCons datatypeInfo of
+      [cons] -> pure cons
+      _ -> prettyFail "exepecting a datatype with exactly 1 constructor"
+  let conName = TH.Datatype.constructorName constructor
+  let name = datatypeName datatypeInfo
+  fBinder <- case unsnoc $ datatypeInstTypes datatypeInfo of
+    Just (_, candidate) -> parseFBinder candidate
+    Nothing -> prettyFail "expecting the datatype to have a context type parameter like `data Foo f = ...`"
+  let fieldSelectors = case constructorVariant constructor of
+        -- Only record constructors have field names
+        RecordConstructor names -> map Just names
+        _ -> repeat Nothing
+  fieldList <- zipWithM (parseField fBinder) (constructorFields constructor) fieldSelectors
+  fields <- maybe (prettyFail "Expected at least one field") pure $ nonEmpty fieldList
+  pure ParsedDatatype{..}
+
+parseFBinder :: TH.Type -> Q TH.Name
+parseFBinder (TH.SigT x (TH.ConT kind))
+  | kind == ''Context = parseFBinder x
+  | otherwise = prettyFail $ "expected kind encountered for the context type argument: " ++ show kind
+parseFBinder (TH.VarT name) = pure name
+parseFBinder typ = prettyFail $ "unexpected type encountered while looking for the context type argument to the datatype: " ++ show typ
+
+parseField :: TH.Name -> TH.Type -> Maybe TH.Name -> Q ParsedField
+parseField fBinder fieldType fieldSelector = do
+  n <- TH.newName "x"
+  let ft = TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ resolveColumnF fBinder fieldType
+  columnType <- case ft of
+    -- Without special casing this, we get an UndecidableInstance error, since
+    (TH.ConT exprName' `TH.AppT` x) | exprName' == ''Expr -> [t|HIdentity $(pure x)|]--
+    _ -> [t|Columns $(pure ft) |]
+  pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  TableField, fieldType = ft, fieldColumnType = columnType, fieldFreshName = n}
+
+generateGColumns :: ParsedDatatype -> Q TH.Type
+generateGColumns ParsedDatatype{..} =
+  foldr1 (\x y -> [t|HProduct $x $y|]) $ fmap generateGColumn fields
+  where
+    generateGColumn ParsedField{..} =
+      labelled fieldSelector [t| $(pure fieldColumnType)|]
+    labelled Nothing x = x
+    labelled (Just (TH.Name (TH.OccName fieldSelector) _)) x = [t|HLabel $(TH.litT $ TH.strTyLit fieldSelector) $x|]
+
+generateColumnsE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp
+generateColumnsE ParsedDatatype{..} g =
+  foldr1 (\x y -> TH.conE 'HProduct `TH.appE` x `TH.appE` y) $ fmap generateColumnE fields
+  where
+    generateColumnE ParsedField{..} =
+      labelled fieldSelector $
+      case fieldVariant of
+        TableField -> g (pure fieldType) $ TH.varE fieldFreshName
+    labelled Nothing x = x
+    labelled (Just _) x = TH.conE 'HLabel `TH.appE`x
+
+generateColumnsP :: ParsedDatatype -> TH.Pat
+generateColumnsP ParsedDatatype{..} =
+  foldr1 (\x y -> TH.ConP 'HProduct [] [x, y]) $ fmap generateColumnP fields
+  where
+    generateColumnP ParsedField{..} =
+      labelled fieldSelector $
+      case fieldVariant of
+        TableField -> TH.VarP fieldFreshName
+    labelled Nothing x = x
+    labelled (Just _) x = TH.ConP 'HLabel [] [x]
+
+generateConstructorE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp
+generateConstructorE parsedDatatype g =
+  foldl' TH.appE (TH.conE (conName parsedDatatype)) . fmap generateFieldE $ fields parsedDatatype
+  where
+    generateFieldE ParsedField{..} =
+      case fieldVariant of
+        TableField -> g (pure fieldType) $ TH.varE fieldFreshName
+
+-- These two functions exist solely so we can write the splices without using TypeApplications, which require an extra language extension in client code, and are required here to appease the type checker.
+-- Otherwise it gets confused.
+deserialize' :: forall transposition expr a. Proxy expr -> (Serialize transposition expr a, transposition ~ (a == Transpose Result expr)) => Columns expr Result -> a
+deserialize' _ = deserialize @_ @expr
+
+serialize' :: forall transposition expr a. Proxy expr -> (Serialize transposition expr a, transposition ~ (a == Transpose Result expr)) => a -> Columns expr Result
+serialize' _ = serialize @_ @expr
+
+deriveRel8able :: TH.Name -> Q [TH.Dec]
+deriveRel8able name = do
+  datatypeInfo <- reifyDatatype name
+  parsedDatatype <- parseDatatype datatypeInfo
+  let gColumns = generateGColumns parsedDatatype
+  let constructorE = generateConstructorE parsedDatatype
+  let constructorP = pure $ TH.ConP (conName parsedDatatype) [] . toList . fmap (TH.VarP . fieldFreshName) $ fields parsedDatatype
+  let columnsE = generateColumnsE parsedDatatype
+  let columnsP = pure $ generateColumnsP parsedDatatype
+  contextName <- TH.newName "context"
+  [d|
+   instance {-# OVERLAPPING #-} (x ~ $(TH.conT name) Expr, result ~ Result) => ToExprs x ($(TH.conT name) result)
+   instance Rel8able $(TH.conT name) where
+          -- Really the Generic code substitutes Expr for f and then does stuff. Maybe we want to move closer to that?
+          type GColumns $( TH.conT name) =
+            $gColumns
+
+          type GFromExprs $( TH.conT name ) =
+            $( TH.conT name ) Result
+
+          -- the rest of the definition is just a few functions to go back and forth between Columns and the datatype
+          gfromColumns $( TH.varP contextName ) v =
+            case $( TH.varE contextName ) of
+              SResult    -> case v of $columnsP -> $(constructorE (\ft x -> [| deserialize' (Proxy :: Proxy $ft) $x |]))
+              SExpr      -> case v of $columnsP -> $(constructorE (\_ x -> [| fromColumns $x |] ))
+              SField     -> case v of $columnsP -> $(constructorE (\_ x -> [| fromColumns $x |] ))
+              SName      -> case v of $columnsP -> $(constructorE (\_ x -> [| fromColumns $x |] ))
+
+          gtoColumns $(TH.varP contextName) $constructorP =
+            case $( TH.varE contextName ) of
+              SExpr      -> $(columnsE (\_ x -> [| toColumns $x |]))
+              SField     -> $(columnsE (\_ x -> [| toColumns $x |]))
+              SName      -> $(columnsE (\_ x -> [| toColumns $x |]))
+              SResult    -> $(columnsE (\ft x -> [| serialize' (Proxy :: Proxy $ft) $x |]))
+
+          gfromResult $columnsP =
+              $( constructorE (\ft x -> [| deserialize' (Proxy :: Proxy $ft) $x |] ))
+
+          gtoResult $constructorP =
+              $( columnsE (\ft x -> [| serialize' (Proxy :: Proxy $ft) $x |] ))
+
+   |]
+
+-- | Walk 'TH.Type' and replace all occurences of @Column f x@ with @Expr x@.
+resolveColumnF :: TH.Name -> TH.Type -> TH.Type
+resolveColumnF fBinder (TH.ForallT tvs context t) =
+  TH.ForallT tvs context (resolveColumnF fBinder t)
+resolveColumnF fBinder (TH.AppT f x)
+  | TH.ConT columnName `TH.AppT` (TH.VarT fBinder') <- f
+  , columnName == ''Column
+  , fBinder == fBinder' = TH.AppT (TH.ConT ''Expr) (resolveColumnF fBinder x)
+  | otherwise = TH.AppT (resolveColumnF fBinder f) (resolveColumnF fBinder x)
+resolveColumnF fBinder (TH.SigT t k)      = TH.SigT (resolveColumnF fBinder t) (resolveColumnF fBinder k) -- k could be Kind
+resolveColumnF fBinder (TH.InfixT l c r)  = TH.InfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)
+resolveColumnF fBinder (TH.UInfixT l c r) = TH.UInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)
+resolveColumnF fBinder (TH.ParensT t)     = TH.ParensT (resolveColumnF fBinder t)
+#if MIN_VERSION_template_haskell(2,15,0)
+resolveColumnF fBinder (TH.AppKindT t k)  = TH.AppKindT (resolveColumnF fBinder t) (resolveColumnF fBinder k)
+resolveColumnF fBinder (TH.ImplicitParamT n t)
+  = TH.ImplicitParamT n (resolveColumnF fBinder t)
+#endif
+#if MIN_VERSION_template_haskell(2,16,0)
+resolveColumnF fBinder (TH.ForallVisT tvs t) =
+  TH.ForallVisT tvs (resolveColumnF fBinder t)
+#endif
+#if MIN_VERSION_template_haskell(2,19,0)
+resolveColumnF fBinder (TH.PromotedInfixT l c r)
+  = TH.PromotedInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)
+resolveColumnF fBinder (TH.PromotedUInfixT l c r)
+  = TH.PromotedUInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)
+#endif
+resolveColumnF _ t = t

rel8/src/Rel8/Tabulate.hs

@@ -53,7 +53,7 @@ module Rel8.Tabulate
 where
 
 -- base
-import Control.Applicative ( (<|>), empty, liftA2 )
+import Control.Applicative ( (<|>), empty )
 import Control.Monad ( liftM2 )
 import Data.Bifunctor ( Bifunctor, bimap, first, second )
 import Data.Foldable ( traverse_ )