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

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

notes

@@ -0,0 +1,52 @@
+standing for ‘rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                    "foo" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Bool))
+                (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                    "bars"
+                    (rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                        (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                            "_1" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))
+                        (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                            "_2" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))))
+                Expr
+rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                        (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                           "foo" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Bool))
+                        (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                           "bars"
+                           (rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                              (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                 "_1" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))
+                              (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                 "_2" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))))
+                        Expr
+    • Found type wildcard ‘_’
+        standing for ‘rel8-1.7.0.0:Rel8.Kind.Context.SContext Identity
+                      -> rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                           (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                              "foo" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Bool))
+                           (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                              "bars"
+                              (rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                                 (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                    "_1" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))
+                                 (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                    "_2"
+                                    (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))))
+                           Identity
+                      -> TablePair Identity’
+    • Found type wildcard ‘_’
+        standing for ‘rel8-1.7.0.0:Rel8.Kind.Context.SContext Identity
+                      -> rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                           (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                              "foo" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Bool))
+                           (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                              "bars"
+                              (rel8-1.7.0.0:Rel8.Schema.HTable.Product.HProduct
+                                 (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                    "_1" (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))
+                                 (rel8-1.7.0.0:Rel8.Schema.HTable.Label.HLabel
+                                    "_2"
+                                    (rel8-1.7.0.0:Rel8.Schema.HTable.Identity.HIdentity Text))))
+                           Identity
+                      -> TablePair Identity’

rel8.cabal

@@ -39,6 +39,8 @@ library
     , scientific
     , semialign
     , semigroupoids
+    , template-haskell
+    , th-abstraction
     , text
     , these
     , time
@@ -72,6 +74,8 @@ library
     Rel8.Expr.Time
     Rel8.Table.Verify
     Rel8.Tabulate
+    Rel8.TH
+    Rel8.Generic.Rel8able
 
   other-modules:
     Rel8.Aggregate
@@ -118,7 +122,6 @@ library
     Rel8.Generic.Construction.Record
     Rel8.Generic.Map
     Rel8.Generic.Record
-    Rel8.Generic.Rel8able
     Rel8.Generic.Table
     Rel8.Generic.Table.ADT
     Rel8.Generic.Table.Record

result

@@ -0,0 +1 @@
+/nix/store/z7sskjfby4bwgamzqyx51nlzchzdszmb-ghc-shell-for-packages

src/Rel8/Generic/Rel8able.hs

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

src/Rel8/Schema/HTable/Label.hs

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

src/Rel8/TH.hs

@@ -0,0 +1,254 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Rel8.TH (deriveRel8able, parseDatatype) where
+
+import Prelude
+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, ConstructorInfo (ConstructorInfo), DatatypeInfo (..), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName, datatypeVars)
+import qualified Language.Haskell.TH.Datatype as TH.Datatype
+import Rel8.Generic.Rel8able ( Rel8able(..) ,serialize, deserialize)
+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.Column.Maybe ( HMaybe )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
+import Rel8.Expr ( Expr )
+import Rel8.Table (Table, Columns, toColumns, fromColumns, fromResult, toResult, FromExprs)
+import Rel8.Schema.Kind (Context)
+import Data.List (unsnoc)
+import Debug.Trace
+import Rel8.Schema.HTable.Label (HLabel(..))
+import Data.Data (constrFields)
+import Data.Aeson (parseIndexedJSON)
+import Data.Proxy
+import qualified Data.Map.Strict as M
+
+
+-- 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 :: [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 =
+  ColumnField
+  | Rel8ableField -- TODO rename to table field
+  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
+  let columnName = ''Column
+  fields <-
+    mapM (uncurry $ parseField columnName fBinder) $
+      zip (constructorFields constructor) fieldSelectors
+  -- TODO: check that we have at least one field, fail otherwise
+  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
+
+typeApps :: TH.Type -> [TH.Type]
+typeApps x = go x []
+ where
+   go (TH.AppT x y) args = go x (y:args)
+   go x args = x:args
+
+unTypeApps :: TH.Type -> [TH.Type] -> TH.Type
+unTypeApps = foldl' TH.AppT
+
+parseField :: TH.Name -> TH.Name -> TH.Type -> Maybe TH.Name -> Q ParsedField
+parseField columnName fBinder fieldType fieldSelector
+  | (TH.ConT columnCandidate `TH.AppT` TH.VarT fBinderCandidate `TH.AppT` subType) <- fieldType
+  , columnCandidate == columnName
+  , fBinderCandidate == fBinder
+     = do
+        n <- TH.newName "x"
+        pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  ColumnField, fieldType = subType, fieldColumnType = TH.ConT ''HIdentity `TH.AppT` subType, fieldFreshName = n}
+  -- | (TH.ConT hmaybeCandidate `TH.AppT` TH.VarT fBinderCandidate `TH.AppT` subType) <- fieldType
+  -- , hmaybeCandidate == ''HMaybe
+  -- , fBinderCandidate == fBinder
+  --    = do
+  --       n <- TH.newName "x"
+  --       innerType <- [t| Columns $(pure subType)|]
+  --       let columnType = TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ TH.ConT ''HMaybeTable `TH.AppT` innerType
+  --       pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n}
+  -- | subType:(TH.VarT name):other_apps  <- typeApps fieldType
+  -- , name == fBinder
+  --    = do
+  --       traceShowM (subType:(TH.VarT name):other_apps)
+  --       n <- TH.newName "x"
+  --       columnType <- [t|Columns ($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)])$ unTypeApps subType ((TH.ConT ''Expr):other_apps))) |]
+  --       traceM $ TH.pprint columnType
+  --       pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n}
+  | otherwise
+     = do
+        traceShowM fieldType
+        n <- TH.newName "x"
+        columnType <- [t|Columns ($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ fieldType)) |]
+        ft2 <- [t|($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ fieldType)) |]
+        traceM $ TH.pprint columnType
+        pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  Rel8ableField, fieldType = ft2, fieldColumnType = columnType, fieldFreshName = n}
+  | otherwise = prettyFail $ "Field of unexpected type: "  ++ show fieldType ++ show (typeApps fieldType)
+
+generateGColumns :: ParsedDatatype -> Q TH.Type
+generateGColumns ParsedDatatype{..} =
+  foldr1 (\x y -> [t|HProduct $x $y|]) $ map generateGColumn fields
+  where
+    generateGColumn ParsedField{..} =
+      [t| $(pure fieldColumnType)|]
+      >>= labelled fieldSelector
+    labelled Nothing x = pure x
+    labelled (Just (TH.Name (TH.OccName fieldSelector) _)) x = [t|HLabel $(TH.litT $ TH.strTyLit fieldSelector) $(pure x)|]
+
+generateColumnsE :: ParsedDatatype -> (TH.Exp -> TH.Exp) -> (TH.Type -> TH.Exp -> TH.Exp) ->  TH.Exp
+generateColumnsE ParsedDatatype{..} f g =
+  foldr1 (\x y -> TH.ConE 'HProduct `TH.AppE` x `TH.AppE` y) $ map generateColumnE fields
+  where
+    generateColumnE ParsedField{..} =
+      labelled fieldSelector $
+      case fieldVariant of
+        ColumnField -> TH.ConE 'HIdentity `TH.AppE` (f $ TH.VarE fieldFreshName)
+        Rel8ableField -> (g 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]) $ map generateColumnP fields
+  where
+    generateColumnP ParsedField{..} =
+      labelled fieldSelector $
+      case fieldVariant of
+        ColumnField ->  TH.ConP 'HIdentity [] [TH.VarP fieldFreshName]
+        Rel8ableField -> TH.VarP fieldFreshName
+    labelled Nothing x = x
+    labelled (Just _) x = TH.ConP 'HLabel [] [x]
+
+generateConstructorE :: ParsedDatatype -> (TH.Exp -> TH.Exp) -> (TH.Type -> TH.Exp -> TH.Exp) -> Q TH.Exp
+generateConstructorE parsedDatatype f g =
+  pure $ foldl' TH.AppE (TH.ConE (conName parsedDatatype)) . map generateFieldE $ fields parsedDatatype
+  where
+    generateFieldE ParsedField{..} =
+      case fieldVariant of
+        ColumnField -> f . TH.VarE $ fieldFreshName
+        Rel8ableField -> g fieldType $ (TH.VarE fieldFreshName --`TH.SigE` (fieldColumnType `TH.AppT` TH.WildCardT)
+                                       )
+
+fromResult' :: forall context a. (Table context a) => Proxy a -> Columns a Result -> FromExprs a
+fromResult' _ x = fromResult @_ @a x
+
+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) [] . map (TH.VarP . fieldFreshName) $ fields parsedDatatype
+  let columnsE f g = pure $ generateColumnsE parsedDatatype f g
+  let columnsP = pure $ generateColumnsP parsedDatatype
+  contextName <- TH.newName "context"
+  [d|
+   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 :: SContext context -> GColumns $(TH.conT name) context -> $(TH.conT name) context
+          gfromColumns $( TH.varP contextName ) x =
+            case $( TH.varE contextName ) of
+              SResult    -> case x of $columnsP -> $(constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x) (\ft x -> TH.VarE 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x))
+              SExpr      -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+              SField     -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+              SName      -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+
+          gtoColumns $(TH.varP contextName) $( constructorP ) =
+            case $( TH.varE contextName ) of
+              SExpr      -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x))
+              SField     -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x))
+              SName      -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x))
+              SResult    -> $(columnsE (\x -> TH.ConE 'Identity `TH.AppE` x) (\ft x -> TH.VarE 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x))
+
+          gfromResult $columnsP = 
+              -- TODO: get rid of type application. Use a signature that references the generic value instead
+              $( constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x)  (\ft x -> TH.VarE 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x))
+
+          gtoResult $constructorP =
+              -- TODO: get rid of type application. Use a signature that references the generic value instead
+              $( columnsE (\x -> TH.ConE 'Identity `TH.AppE` x)  (\ft x -> TH.VarE 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x))
+
+   |]

src/Rel8Test.hs

@@ -0,0 +1,7 @@
+-- |
+{-# language DuplicateRecordFields #-}
+
+module Rel8Test where
+import Rel8 (text)
+
+foo = text