diff --git a/rel8-internal/src/Rel8/Internal/Generic/Rel8able.hs b/rel8-internal/src/Rel8/Internal/Generic/Rel8able.hs index 0a36d1a5..04cddf91 100644 --- a/rel8-internal/src/Rel8/Internal/Generic/Rel8able.hs +++ b/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 diff --git a/rel8-internal/src/Rel8/Internal/Schema/HTable/Label.hs b/rel8-internal/src/Rel8/Internal/Schema/HTable/Label.hs index 701120f7..2cb24317 100644 --- a/rel8-internal/src/Rel8/Internal/Schema/HTable/Label.hs +++ b/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 diff --git a/rel8/rel8.cabal b/rel8/rel8.cabal index 54d15473..6b460a14 100644 --- a/rel8/rel8.cabal +++ b/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 diff --git a/rel8/src/Rel8/TH.hs b/rel8/src/Rel8/TH.hs new file mode 100644 index 00000000..0749c679 --- /dev/null +++ b/rel8/src/Rel8/TH.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.TH + ( deriveRel8able + , deriveRel8ables + ) where + +import Control.Monad (zipWithM) +import Data.Foldable (toList) +import Data.Foldable1 (foldr1) +import Data.List (unsnoc) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import qualified Data.Map.Strict as M +import Data.Proxy (Proxy (Proxy)) +import Data.Type.Equality (type (==)) +import Language.Haskell.TH (Q) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Datatype (ConstructorVariant (RecordConstructor), DatatypeInfo (..), constructorFields, constructorVariant, datatypeCons, reifyDatatype) +import qualified Language.Haskell.TH.Datatype as TH.Datatype +import qualified Language.Haskell.TH.Syntax as TH +import Rel8.Internal.Column (Column) +import Rel8.Internal.Expr (Expr) +import Rel8.Internal.Generic.Rel8able (Rel8able (..), Serialize, deserialize, serialize) +import Rel8.Internal.Kind.Context (SContext (..)) +import Rel8.Internal.Schema.HTable.Identity (HIdentity) +import Rel8.Internal.Schema.HTable.Label (HLabel (..)) +import Rel8.Internal.Schema.HTable.Product (HProduct (HProduct)) +import Rel8.Internal.Schema.Kind (Context) +import Rel8.Internal.Schema.Result (Result) +import Rel8.Internal.Table (Columns, Transpose, fromColumns, toColumns) +import Rel8.Internal.Table.Serialize (ToExprs) +import Prelude hiding (foldr1) + +-- | Represent a valid datatype +data ParsedDatatype + = ParsedDatatype + { name :: TH.Name + , conName :: TH.Name + , fBinder :: TH.Name + , fields :: NonEmpty ParsedField + } + deriving (Show) + +-- | Represent a valid field +data ParsedField + = ParsedField + { fieldSelector :: Maybe TH.Name + , fieldType :: TH.Type + , fieldColumnType :: TH.Type + , fieldFreshName :: TH.Name + } + 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 +-- type Context = Type -> Type +parseFBinder (TH.SigT x (TH.ArrowT `TH.AppT` TH.StarT `TH.AppT` TH.StarT)) = parseFBinder x +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 lots of UndecidableInstance errors + -- ie, rewrite Expr \phi to HIdentity \phi + (TH.ConT exprName' `TH.AppT` x) | exprName' == ''Expr -> [t|HIdentity $(pure x)|] -- + _ -> [t|Columns $(pure ft)|] + pure $ ParsedField{fieldSelector = fieldSelector, fieldType = ft, fieldColumnType = columnType, fieldFreshName = n} + +-- | Like foldr1, but we create a mostly balanced binary tree. +-- This makes a big difference for compile times, since we want the depth of the HProduct tree to be minimal. +-- Each layer adds a lot of overhead. +foldr1Tree :: (a -> a -> a ) -> NonEmpty a -> a +foldr1Tree f xs0 = go (toList xs0) size0 + where + size0 = length xs0 + go [] _ = error "impossible" + go [x] _ = x + go [x,y] _ = f x y + go xs size = f (go left half) (go right (size - half)) + where + -- Invariants: + -- half > 0, since size is >2, this will always be the case + -- size - half > 0 + half = size `div` 2 + (left, right) = splitAt half xs + +generateGColumns :: ParsedDatatype -> Q TH.Type +generateGColumns ParsedDatatype{..} = + foldr1Tree (\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|] + +-- | Generate an expression to construct a column value +generateColumnsE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp +generateColumnsE ParsedDatatype{..} g = + foldr1Tree (\x y -> TH.conE 'HProduct `TH.appE` x `TH.appE` y) $ fmap generateColumnE fields + where + generateColumnE ParsedField{..} = + labelled fieldSelector $ + g (pure fieldType) $ + TH.varE fieldFreshName + labelled Nothing x = x + labelled (Just _) x = TH.conE 'HLabel `TH.appE` x + +-- | Generate a pattern to destruct a column +generateColumnsP :: ParsedDatatype -> TH.Pat +generateColumnsP ParsedDatatype{..} = + foldr1Tree (\x y -> TH.ConP 'HProduct [] [x, y]) $ fmap generateColumnP fields + where + generateColumnP ParsedField{..} = + labelled fieldSelector $ + TH.VarP fieldFreshName + labelled Nothing x = x + labelled (Just _) x = TH.ConP 'HLabel [] [x] + +-- | Generate an expression to create the constructor +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{..} = + g (pure fieldType) $ TH.varE fieldFreshName + +-- | Generate a pattern to destruct the datatype +generateConstructorP :: ParsedDatatype -> Q TH.Pat +generateConstructorP parsedDatatype = + pure $ TH.ConP (conName parsedDatatype) [] . toList . fmap (TH.VarP . fieldFreshName) $ fields parsedDatatype + + +-- 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 + +-- | Derive a 'Rel8able' instance using TemplateHaskell. +-- Using TH can be signficantly faster than using Generics. +-- Currently, this doesn't support all of the features of the Generics deriving machinery. +-- +-- You might have to enable @UndecidableInstances@ for instances to compile. +-- +-- >>> data Foo f = Foo +-- >>> { fooId :: Column f Word64 +-- >>> , fooName :: Column f Text +-- >>> } +-- >>> +-- >>> deriveRel8able ''Foo +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 = generateConstructorP parsedDatatype + let columnsE = generateColumnsE parsedDatatype + let columnsP = pure $ generateColumnsP parsedDatatype + contextName <- TH.newName "context" + [d| + -- We already derive ToExprs for Rel8able instances but we assumed they are Generically derived. + -- So, we need to allow this one to overlap, but this is fine since this instance is always more specific. + 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|])) + |] + +-- | Like 'deriveRel8able' but for a list of datatypes. +-- This is helpful as all of the instances live in a single splice. +-- Each TH splice creates a new decleration group, so they cannot see instances later in the file. +-- By deriving the instances in the same splice, we can ensure that they see each other. +-- This is necessary when deriving cyclic instances, but also reduces the amount of splice sorting required. +-- There is also a small performance overhead to each TH splice. +deriveRel8ables :: [TH.Name] -> Q [TH.Dec] +deriveRel8ables xs = concat <$> traverse deriveRel8able xs + +-- | 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 diff --git a/rel8/src/Rel8/Tabulate.hs b/rel8/src/Rel8/Tabulate.hs index 77962513..3a5c3ce6 100644 --- a/rel8/src/Rel8/Tabulate.hs +++ b/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_ ) diff --git a/rel8/tests/Rel8/TH/Rel8able/Test.hs b/rel8/tests/Rel8/TH/Rel8able/Test.hs new file mode 100644 index 00000000..d5eb22c6 --- /dev/null +++ b/rel8/tests/Rel8/TH/Rel8able/Test.hs @@ -0,0 +1,137 @@ +{-# 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 #-} + +module Rel8.TH.Rel8able.Test where + +-- base +import Data.Fixed ( Fixed ( MkFixed ), E2 ) +import Prelude + +-- rel8 +import Rel8 ( + Column, + HEither, + HList, + HMaybe, + HNonEmpty, + HThese, + ) +import Rel8.TH + +-- text +import Data.Text ( Text ) + +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 + +data TableNumeric f = TableNumeric + { foo :: Column f (Fixed E2) + } + +deriveRel8able ''TableNumeric + + +data TableChar f = TableChar + { foo :: Column f Char + } +deriveRel8able ''TableChar + + +newtype IdRecord a f = IdRecord { recordId :: Column f a } + +-- Our TH deriving code currently doesn't support type args other than f +-- deriveRel8able ''IdRecord