From f869d5e8688c67c00728b9576452627be1de5fc7 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Fri, 18 Jun 2021 20:59:10 +0100 Subject: [PATCH 1/7] Doc tweaks --- docs/tutorial.rst | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/docs/tutorial.rst b/docs/tutorial.rst index 433077b3..60c83e9b 100644 --- a/docs/tutorial.rst +++ b/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, From 38349621a692d119a1156a1b8e5e2e80e89735b3 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Fri, 5 Nov 2021 09:53:45 +0000 Subject: [PATCH 2/7] Add `Rel8.TH.deriveRel8able` --- rel8.cabal | 3 ++ src/Rel8/Generic/Rel8able.hs | 2 +- src/Rel8/TH.hs | 52 +++++++++++++++++++++++++++++ tests/Rel8/Generic/Rel8able/Test.hs | 7 ++-- 4 files changed, 61 insertions(+), 3 deletions(-) create mode 100644 src/Rel8/TH.hs diff --git a/rel8.cabal b/rel8.cabal index 42b5a537..9b5aca06 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -34,6 +34,8 @@ library , scientific , semialign , semigroupoids + , template-haskell + , th-abstraction , text , these , time @@ -54,6 +56,7 @@ library Rel8.Expr.Text Rel8.Expr.Time Rel8.Tabulate + Rel8.TH other-modules: Rel8.Aggregate diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index f00ff883..08ae026f 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -16,7 +16,7 @@ {-# language UndecidableInstances #-} module Rel8.Generic.Rel8able - ( KRel8able, Rel8able + ( KRel8able, Rel8able(..) , Algebra , GRep , GColumns, gfromColumns, gtoColumns diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs new file mode 100644 index 00000000..c3e1ec19 --- /dev/null +++ b/src/Rel8/TH.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +module Rel8.TH (deriveRel8able) where + +import Prelude (show, (.), pure, (<$>), Maybe (Nothing), ($), fail) +import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, reportWarning, Type (AppT), newName, conP, varP, mkName, nameBase) +import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant) +import Rel8.Generic.Rel8able ( Rel8able(..) ) +import Rel8.Schema.Result (Result) +import Data.Foldable (for_, foldr) +import Rel8.Schema.HTable.Identity (HIdentity) +import Rel8.Schema.HTable.Product (HProduct) +import Language.Haskell.TH.Syntax (showName) +import Data.Traversable (for) + +deriveRel8able :: Name -> Q [Dec] +deriveRel8able name = do + DatatypeInfo{ datatypeCons = [ ConstructorInfo{ constructorFields = f1:fs, constructorVariant = RecordConstructor (fieldName1:fieldNames) } ]} <- reifyDatatype name + + for_ (f1:fs) (reportWarning . show) + + pure <$> instanceD (cxt []) (appT (conT ''Rel8able) (conT name)) + [ tySynInstD $ tySynEqn Nothing (appT (conT ''GColumns) (conT name)) $ + foldr + (appT . appT (conT ''HProduct) . appT (conT ''HIdentity) . unColumn) + (appT (conT ''HIdentity) (unColumn f1)) + fs + + , tySynInstD $ tySynEqn Nothing (appT (conT ''GFromExprs) (conT name)) $ + appT (conT name) (conT ''Result) + + , funD 'gfromColumns $ pure $ + clause [] (normalB [|undefined|]) [] + + , funD 'gtoColumns $ pure $ + clause [] (normalB [|undefined|]) [] + + , funD 'gfromResult $ pure do + name1 <- newName $ nameBase fieldName1 + names <- for fieldNames $ newName . nameBase + clause [varP name1] (normalB [|undefined|]) [] + + , funD 'gtoResult $ pure $ + clause [] (normalB [|undefined|]) [] + ] + + +unColumn :: Type -> Q Type +unColumn (AppT (AppT _Column _f) t) = pure t +unColumn _ = fail "Not a 'Column f' application" \ No newline at end of file diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 29d9ccfd..7b1068da 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/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,8 +32,9 @@ 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 From a515d54356f8be048e8a5771437597dd77baa40f Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Sat, 6 Nov 2021 09:02:17 +0000 Subject: [PATCH 3/7] WIP --- src/Rel8/TH.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs index c3e1ec19..8f951955 100644 --- a/src/Rel8/TH.hs +++ b/src/Rel8/TH.hs @@ -40,7 +40,7 @@ deriveRel8able name = do , funD 'gfromResult $ pure do name1 <- newName $ nameBase fieldName1 names <- for fieldNames $ newName . nameBase - clause [varP name1] (normalB [|undefined|]) [] + clause [varP name1] (normalB [| undefined |]) [] , funD 'gtoResult $ pure $ clause [] (normalB [|undefined|]) [] From 01573d3143d40107eef39b7b70ad0c34ee42ce51 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Sat, 6 Nov 2021 13:58:39 +0000 Subject: [PATCH 4/7] WIP --- src/Rel8/TH.hs | 42 +++++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs index 8f951955..7ee70e27 100644 --- a/src/Rel8/TH.hs +++ b/src/Rel8/TH.hs @@ -2,29 +2,28 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} module Rel8.TH (deriveRel8able) where -import Prelude (show, (.), pure, (<$>), Maybe (Nothing), ($), fail) -import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, reportWarning, Type (AppT), newName, conP, varP, mkName, nameBase) -import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant) +import Prelude ((.), pure, (<$>), Maybe (Nothing), ($), fail, map) +import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, Type (AppT), newName, conP, varP, nameBase, conE, appE, varE, appsE) +import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName) import Rel8.Generic.Rel8able ( Rel8able(..) ) import Rel8.Schema.Result (Result) -import Data.Foldable (for_, foldr) -import Rel8.Schema.HTable.Identity (HIdentity) -import Rel8.Schema.HTable.Product (HProduct) -import Language.Haskell.TH.Syntax (showName) +import Data.Foldable (foldl') +import Rel8.Schema.HTable.Identity (HIdentity(HIdentity)) +import Rel8.Schema.HTable.Product (HProduct(HProduct)) import Data.Traversable (for) +import Data.Functor.Identity (Identity(Identity)) deriveRel8able :: Name -> Q [Dec] deriveRel8able name = do - DatatypeInfo{ datatypeCons = [ ConstructorInfo{ constructorFields = f1:fs, constructorVariant = RecordConstructor (fieldName1:fieldNames) } ]} <- reifyDatatype name - - for_ (f1:fs) (reportWarning . show) + DatatypeInfo{ datatypeCons = [ ConstructorInfo{ constructorName, constructorFields = f1:fs, constructorVariant = RecordConstructor (fieldName1:fieldNames) } ]} <- reifyDatatype name pure <$> instanceD (cxt []) (appT (conT ''Rel8able) (conT name)) [ tySynInstD $ tySynEqn Nothing (appT (conT ''GColumns) (conT name)) $ - foldr - (appT . appT (conT ''HProduct) . appT (conT ''HIdentity) . unColumn) + foldl' + (\e x -> appT (appT (conT ''HProduct) e) (appT (conT ''HIdentity) (unColumn x))) (appT (conT ''HIdentity) (unColumn f1)) fs @@ -40,10 +39,23 @@ deriveRel8able name = do , funD 'gfromResult $ pure do name1 <- newName $ nameBase fieldName1 names <- for fieldNames $ newName . nameBase - clause [varP name1] (normalB [| undefined |]) [] + clause + [foldl' (\pat n -> conP 'HProduct [pat, conP 'HIdentity [conP 'Identity [varP n]]]) + (conP 'HIdentity [conP 'Identity [varP name1]]) + names] + (normalB (appsE (conE constructorName : (varE <$> (name1:names))))) + [] - , funD 'gtoResult $ pure $ - clause [] (normalB [|undefined|]) [] + , funD 'gtoResult $ pure do + name1 <- newName $ nameBase fieldName1 + names <- for fieldNames $ newName . nameBase + clause + [conP constructorName (map varP (name1:names))] + (normalB $ + foldl' (\e n -> appE (appE (conE 'HProduct) e) (appE (conE 'HIdentity) (appE (conE 'Identity) (varE n)))) + (appE (conE 'HIdentity) (appE (conE 'Identity) (varE name1))) + names + ) [] ] From b1e836a79081fd13878b0edcbb7da05357d5fe6e Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Sun, 7 Nov 2021 13:22:22 +0000 Subject: [PATCH 5/7] Works with Column-only types --- src/Rel8/Generic/Rel8able.hs | 2 -- src/Rel8/TH.hs | 58 +++++++++++++++++++++++++++++++----- 2 files changed, 51 insertions(+), 9 deletions(-) diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index 08ae026f..f8fe2fb4 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -19,8 +19,6 @@ module Rel8.Generic.Rel8able ( KRel8able, Rel8able(..) , Algebra , GRep - , GColumns, gfromColumns, gtoColumns - , GFromExprs, gfromResult, gtoResult , TSerialize, serialize, deserialize ) where diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs index 7ee70e27..54332198 100644 --- a/src/Rel8/TH.hs +++ b/src/Rel8/TH.hs @@ -5,8 +5,8 @@ {-# LANGUAGE ViewPatterns #-} module Rel8.TH (deriveRel8able) where -import Prelude ((.), pure, (<$>), Maybe (Nothing), ($), fail, map) -import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, Type (AppT), newName, conP, varP, nameBase, conE, appE, varE, appsE) +import Prelude ((.), pure, (<$>), Maybe (Nothing), ($), fail, map, uncurry, id) +import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, Type (AppT), newName, conP, varP, nameBase, conE, appE, varE, appsE, caseE, match) import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName) import Rel8.Generic.Rel8able ( Rel8able(..) ) import Rel8.Schema.Result (Result) @@ -14,7 +14,8 @@ import Data.Foldable (foldl') import Rel8.Schema.HTable.Identity (HIdentity(HIdentity)) import Rel8.Schema.HTable.Product (HProduct(HProduct)) import Data.Traversable (for) -import Data.Functor.Identity (Identity(Identity)) +import Data.Functor.Identity (Identity(Identity), runIdentity) +import Rel8.Kind.Context (SContext(..)) deriveRel8able :: Name -> Q [Dec] deriveRel8able name = do @@ -30,11 +31,54 @@ deriveRel8able name = do , tySynInstD $ tySynEqn Nothing (appT (conT ''GFromExprs) (conT name)) $ appT (conT name) (conT ''Result) - , funD 'gfromColumns $ pure $ - clause [] (normalB [|undefined|]) [] + , funD 'gfromColumns $ pure do + contextName <- newName "context" + name1 <- newName $ nameBase fieldName1 + names <- for fieldNames $ newName . nameBase + let columns = + foldl' (\pat n -> conP 'HProduct [pat, conP 'HIdentity [varP n]]) + (conP 'HIdentity [varP name1]) + names + + cases = + caseE (varE contextName) $ + uncurry (mkCase (name1:names)) <$> + [ ('SAggregate, id) + , ('SExpr, id) + , ('SField, id) + , ('SName, id) + , ('SResult, appE (varE 'runIdentity)) + ] + where + mkCase ns context unpack = + match (conP context []) (normalB (appsE (conE constructorName:map (unpack . varE) ns))) [] + + clause [varP contextName, columns] (normalB cases) [] + + , funD 'gtoColumns $ pure do + name1 <- newName $ nameBase fieldName1 + names <- for fieldNames $ newName . nameBase + contextName <- newName "context" + + let mkColumns wrap = + foldl' (\e n -> appsE [conE 'HProduct, e, appsE [conE 'HIdentity, wrap (varE n)]]) + (appsE [conE 'HIdentity, wrap (varE name1)]) + names + + cases = + caseE (varE contextName) $ + uncurry mkCase <$> + [ ('SAggregate, id) + , ('SExpr, id) + , ('SField, id) + , ('SName, id) + , ('SResult, appE (conE 'Identity)) + ] + where + mkCase context pack = + match (conP context []) (normalB (mkColumns pack)) [] - , funD 'gtoColumns $ pure $ - clause [] (normalB [|undefined|]) [] + clause [varP contextName, conP constructorName (map varP (name1:names))] (normalB cases) [] , funD 'gfromResult $ pure do name1 <- newName $ nameBase fieldName1 From 444698159485a0ef24edcec74fafc3e9ce1635c6 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Wed, 17 Nov 2021 10:37:08 +0000 Subject: [PATCH 6/7] WIP --- tests/Rel8/Generic/Rel8able/Test.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 7b1068da..d27c663a 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -41,8 +41,9 @@ 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 From 23e8c721c53071bcc90f212ceb9b33cd87229096 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Mon, 31 Jan 2022 13:03:13 +0000 Subject: [PATCH 7/7] Simplifications using quoting and splicing --- src/Rel8/TH.hs | 180 ++++++++++++++++++++++++------------------------- 1 file changed, 89 insertions(+), 91 deletions(-) diff --git a/src/Rel8/TH.hs b/src/Rel8/TH.hs index 54332198..74d17a31 100644 --- a/src/Rel8/TH.hs +++ b/src/Rel8/TH.hs @@ -3,106 +3,104 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} module Rel8.TH (deriveRel8able) where -import Prelude ((.), pure, (<$>), Maybe (Nothing), ($), fail, map, uncurry, id) -import Language.Haskell.TH (Name, Q, Dec, instanceD, cxt, appT, conT, funD, clause, normalB, tySynEqn, tySynInstD, Type (AppT), newName, conP, varP, nameBase, conE, appE, varE, appsE, caseE, match) -import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (DatatypeInfo), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName) +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') +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{ datatypeCons = [ ConstructorInfo{ constructorName, constructorFields = f1:fs, constructorVariant = RecordConstructor (fieldName1:fieldNames) } ]} <- reifyDatatype name - - pure <$> instanceD (cxt []) (appT (conT ''Rel8able) (conT name)) - [ tySynInstD $ tySynEqn Nothing (appT (conT ''GColumns) (conT name)) $ - foldl' - (\e x -> appT (appT (conT ''HProduct) e) (appT (conT ''HIdentity) (unColumn x))) - (appT (conT ''HIdentity) (unColumn f1)) - fs - - , tySynInstD $ tySynEqn Nothing (appT (conT ''GFromExprs) (conT name)) $ - appT (conT name) (conT ''Result) - - , funD 'gfromColumns $ pure do - contextName <- newName "context" - name1 <- newName $ nameBase fieldName1 - names <- for fieldNames $ newName . nameBase - let columns = - foldl' (\pat n -> conP 'HProduct [pat, conP 'HIdentity [varP n]]) - (conP 'HIdentity [varP name1]) - names - - cases = - caseE (varE contextName) $ - uncurry (mkCase (name1:names)) <$> - [ ('SAggregate, id) - , ('SExpr, id) - , ('SField, id) - , ('SName, id) - , ('SResult, appE (varE 'runIdentity)) - ] - where - mkCase ns context unpack = - match (conP context []) (normalB (appsE (conE constructorName:map (unpack . varE) ns))) [] - - clause [varP contextName, columns] (normalB cases) [] - - , funD 'gtoColumns $ pure do - name1 <- newName $ nameBase fieldName1 - names <- for fieldNames $ newName . nameBase - contextName <- newName "context" - - let mkColumns wrap = - foldl' (\e n -> appsE [conE 'HProduct, e, appsE [conE 'HIdentity, wrap (varE n)]]) - (appsE [conE 'HIdentity, wrap (varE name1)]) - names - - cases = - caseE (varE contextName) $ - uncurry mkCase <$> - [ ('SAggregate, id) - , ('SExpr, id) - , ('SField, id) - , ('SName, id) - , ('SResult, appE (conE 'Identity)) - ] - where - mkCase context pack = - match (conP context []) (normalB (mkColumns pack)) [] - - clause [varP contextName, conP constructorName (map varP (name1:names))] (normalB cases) [] - - , funD 'gfromResult $ pure do - name1 <- newName $ nameBase fieldName1 - names <- for fieldNames $ newName . nameBase - clause - [foldl' (\pat n -> conP 'HProduct [pat, conP 'HIdentity [conP 'Identity [varP n]]]) - (conP 'HIdentity [conP 'Identity [varP name1]]) - names] - (normalB (appsE (conE constructorName : (varE <$> (name1:names))))) - [] - - , funD 'gtoResult $ pure do - name1 <- newName $ nameBase fieldName1 - names <- for fieldNames $ newName . nameBase - clause - [conP constructorName (map varP (name1:names))] - (normalB $ - foldl' (\e n -> appE (appE (conE 'HProduct) e) (appE (conE 'HIdentity) (appE (conE 'Identity) (varE n)))) - (appE (conE 'HIdentity) (appE (conE 'Identity) (varE name1))) - names - ) [] - ] - - -unColumn :: Type -> Q Type -unColumn (AppT (AppT _Column _f) t) = pure t -unColumn _ = fail "Not a 'Column f' application" \ No newline at end of file + 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