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, diff --git a/rel8.cabal b/rel8.cabal index f6edc528..4c5e4619 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -34,6 +34,8 @@ library , scientific , semialign , semigroupoids + , template-haskell + , th-abstraction , text , these , time @@ -55,6 +57,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..f8fe2fb4 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -16,11 +16,9 @@ {-# language UndecidableInstances #-} module Rel8.Generic.Rel8able - ( KRel8able, 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 new file mode 100644 index 00000000..74d17a31 --- /dev/null +++ b/src/Rel8/TH.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +module Rel8.TH (deriveRel8able) where + +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', 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{ 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 diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 29d9ccfd..d27c663a 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,16 +32,18 @@ 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 { foo :: Column f Bool , bars :: (Column f Text, Column f Text) } - deriving stock Generic - deriving anyclass Rel8able + + +deriveRel8able ''TablePair data TableMaybe f = TableMaybe