From 2a4b9fa166e6ef6f4e92dab9f42c9c112d020b18 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Fri, 26 Jun 2026 18:56:48 +0100 Subject: [PATCH] Add `Rel8.TH.deriveRel8able` Co-authored-by: Oliver Charles --- .ghci | 1 + bare_shell.nix | 4 + cabal.project | 2 + rel8.cabal | 6 +- src/Rel8/Generic/Rel8able.hs | 7 +- src/Rel8/Schema/HTable/Label.hs | 2 +- src/Rel8/TH.hs | 233 ++++++++++++++++++++++++++++++++ tests/Rel8/Deriving/TH.hs | 198 +++++++++++++++++++++++++++ 8 files changed, 447 insertions(+), 6 deletions(-) create mode 100644 .ghci create mode 100644 bare_shell.nix create mode 100644 src/Rel8/TH.hs create mode 100644 tests/Rel8/Deriving/TH.hs diff --git a/.ghci b/.ghci new file mode 100644 index 00000000..a48e262f --- /dev/null +++ b/.ghci @@ -0,0 +1 @@ +:set -XDeriveAnyClass -XDeriveGeneric -XTemplateHaskell diff --git a/bare_shell.nix b/bare_shell.nix new file mode 100644 index 00000000..e6efd0cf --- /dev/null +++ b/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];} diff --git a/cabal.project b/cabal.project index 9c5314c1..21e0d893 100644 --- a/cabal.project +++ b/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 diff --git a/rel8.cabal b/rel8.cabal index 8f053e3a..76a63cd8 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -40,6 +40,8 @@ library , scientific , semialign , semigroupoids + , template-haskell + , th-abstraction , text , these , time @@ -74,6 +76,8 @@ library Rel8.Range Rel8.Table.Verify Rel8.Tabulate + Rel8.TH + Rel8.Generic.Rel8able other-modules: Rel8.Aggregate @@ -124,7 +128,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 @@ -282,6 +285,7 @@ test-suite tests other-modules: Rel8.Generic.Rel8able.Test + Rel8.Deriving.TH main-is: Main.hs hs-source-dirs: tests diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index 365c17cb..0a614104 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/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 + , TSerialize, Serialize, serialize, deserialize + , GColumns ) where diff --git a/src/Rel8/Schema/HTable/Label.hs b/src/Rel8/Schema/HTable/Label.hs index 43c1843f..1eac6848 100644 --- a/src/Rel8/Schema/HTable/Label.hs +++ b/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 diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs new file mode 100644 index 00000000..5947099a --- /dev/null +++ b/src/Rel8/TH.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +module Rel8.TH (deriveRel8able, parseDatatype) where + +import Prelude +import Rel8.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.Generic.Rel8able ( Rel8able(..), Serialize, serialize, deserialize) +import Rel8.Schema.Result (Result) +import Rel8.Schema.HTable.Identity (HIdentity(HIdentity)) +import Rel8.Schema.HTable.Product (HProduct(HProduct)) +import Data.Functor.Identity (Identity(Identity), runIdentity) +import Rel8.Kind.Context (SContext(..)) +import Rel8.Column ( Column ) +import Rel8.Expr ( Expr ) +import Rel8.Table (Columns, toColumns, fromColumns, Transpose) +import Rel8.Schema.Kind (Context) +import Data.List (unsnoc) +import Rel8.Schema.HTable.Label (HLabel(..)) +import Data.Proxy (Proxy(Proxy)) +import qualified Data.Map.Strict as M +import Data.Type.Equality (type (==)) + + +-- 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 + | TableField -- 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 + +-- TODO: Replace 'Column f a' with a, to avoid UndecidableInstances when using Table fields +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} + | otherwise + = do + 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)) |] + pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = TableField, 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 -> (Q TH.Exp -> Q TH.Exp) -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q 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) + 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]) $ map generateColumnP fields + where + generateColumnP ParsedField{..} = + labelled fieldSelector $ + case fieldVariant of + ColumnField -> TH.ConP 'HIdentity [] [TH.VarP fieldFreshName] + TableField -> TH.VarP fieldFreshName + labelled Nothing x = x + labelled (Just _) x = TH.ConP 'HLabel [] [x] + +generateConstructorE :: ParsedDatatype -> (Q TH.Exp -> Q TH.Exp) -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp +generateConstructorE parsedDatatype f g = + foldl' TH.appE (TH.conE (conName parsedDatatype)) . map generateFieldE $ fields parsedDatatype + where + generateFieldE ParsedField{..} = + case fieldVariant of + ColumnField -> f . TH.varE $ fieldFreshName + 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) [] . map (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 ) x = + case $( TH.varE contextName ) of + SResult -> case x of $columnsP -> $(constructorE (\x -> [| runIdentity $x |] ) (\ft x -> [| deserialize' (Proxy :: Proxy $ft) $x |])) + SExpr -> case x of $columnsP -> $(constructorE id (\_ x -> [| fromColumns $x |] )) + SField -> case x of $columnsP -> $(constructorE id (\_ x -> [| fromColumns $x |] )) + SName -> case x of $columnsP -> $(constructorE id (\_ x -> [| fromColumns $x |] )) + + gtoColumns $(TH.varP contextName) $constructorP = + case $( TH.varE contextName ) of + SExpr -> $(columnsE id (\_ x -> [| toColumns $x |])) + SField -> $(columnsE id (\_ x -> [| toColumns $x |])) + SName -> $(columnsE id (\_ x -> [| toColumns $x |])) + SResult -> $(columnsE (\x -> [| Identity $x |] ) (\ft x -> [| serialize' (Proxy :: Proxy $ft) $x |])) + + gfromResult $columnsP = + $( constructorE (\x -> [|runIdentity $x |]) (\ft x -> [| deserialize' (Proxy :: Proxy $ft) $x |] )) + + gtoResult $constructorP = + $( columnsE (\x -> [| Identity $x |]) (\ft x -> [| serialize' (Proxy :: Proxy $ft) $x |] )) + + |] diff --git a/tests/Rel8/Deriving/TH.hs b/tests/Rel8/Deriving/TH.hs new file mode 100644 index 00000000..4bb8f25c --- /dev/null +++ b/tests/Rel8/Deriving/TH.hs @@ -0,0 +1,198 @@ +{-# language ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language StandaloneDeriving #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language RecordWildCards #-} +{-# language UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +-- Maybe we want to drop this +module Rel8.Deriving.TH where +-- aeson +import Data.Aeson ( Value(..) ) +import qualified Data.Aeson.KeyMap as Aeson + +-- base +import Data.Fixed ( Fixed ( MkFixed ), E2 ) +import Data.Int ( Int16, Int32, Int64 ) +import Data.Functor.Identity ( Identity(..) ) +import qualified Data.List.NonEmpty as NonEmpty +import GHC.Generics ( Generic ) +import Prelude +import Control.Applicative ( liftA3 ) + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as LB + +-- case-insensitive +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + +-- containers +import qualified Data.Map as Map + +-- hedgehog +import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +-- rel8 +import Rel8 ( + Column, + DBType, + Expr, + HADT, + HEither, + HKD, + HList, + HMaybe, + HNonEmpty, + HThese, + KRel8able, + Lift, + Name, + QualifiedName, + Rel8able, + Result, + TableSchema (TableSchema), + ToExprs, + namesFromLabels, + namesFromLabelsWith, + ) +import qualified Rel8 + +-- scientific +import Data.Scientific ( Scientific, fromFloatDigits ) + +-- time +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime, secondsToNominalDiffTime) +import Data.Time.LocalTime + ( CalendarDiffTime (CalendarDiffTime) + , LocalTime(..) + , TimeOfDay(..) + ) + +-- text +import Data.Text ( Text ) +import qualified Data.Text.Lazy as LT + +-- these +import Data.These + +-- uuid +import Data.UUID ( UUID ) +import qualified Data.UUID as UUID + +-- vector +import qualified Data.Vector as Vector + +import Rel8.TH + +data TableTest f = TableTest + { foo :: Column f Bool + , bar :: Column f (Maybe Bool) + } + +deriveRel8able ''TableTest + +data TablePair f = TablePair + { foo :: Column f Bool + , bars :: (Column f Text, Column f Text) + } + +deriveRel8able ''TablePair + +data TableDuplicate f = TableDuplicate + { foo :: TablePair f + , bar :: TablePair f + } + +deriveRel8able ''TableDuplicate + +data TableMaybe f = TableMaybe + { foo :: Column f [Maybe Bool] + , bars :: HMaybe f (TablePair f, TablePair f) + } + +deriveRel8able ''TableMaybe + +data TableEither f = TableEither + { foo :: Column f Bool + , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char) + } + +deriveRel8able ''TableEither + +data TableThese f = TableThese + { foo :: Column f Bool + , bars :: HThese f (TableMaybe f) (TableEither f) + } + +deriveRel8able ''TableThese + + +data TableList f = TableList + { foo :: Column f Bool + , bars :: HList f (TableThese f) + } + +deriveRel8able ''TableList + + +data TableNonEmpty f = TableNonEmpty + { foo :: Column f Bool + , bars :: HNonEmpty f (TableList f, TableMaybe f) + } + +deriveRel8able ''TableNonEmpty + +data TableNest f = TableNest + { foo :: Column f Bool + , bars :: HList f (HMaybe f (TablePair f)) + } + +deriveRel8able ''TableNest + + +data TableTestB f = TableTestB + { foo :: f Bool + , bar :: f (Maybe Bool) + } + +--deriveRel8able ''TableTestB + +data NestedTableTestB f = NestedTableTestB + { foo :: f Bool + , bar :: f (Maybe Bool) + , baz :: Column f Char + , nest :: TableTestB f + } + +--deriveRel8able ''NestedTableTestB + +newtype IdRecord a f = IdRecord { recordId :: Column f a } + +--deriveRel8able ''IdRecord + +data TableNumeric f = TableNumeric + { foo :: Column f (Fixed E2) + } + +deriveRel8able ''TableNumeric + + +data TableChar f = TableChar + { foo :: Column f Char + } +deriveRel8able ''TableChar