wip

Change-Id: Ia839a09ef05f9db520764067b4a8183f6a6a6964

Author: TeofilC

.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

@@ -1,3 +1,5 @@
 packages: .
 constraints: ansi-wl-pprint < 1.0.0
 allow-newer: base16:base, base16:deepseq, base16:text
+
+tests: true

diff

@@ -0,0 +1,62 @@
+
+commit b384871b242cef11e717f2671e0128f75887e3b0
+Author: remeike <[email protected]>
+Date:   Mon Aug 5 09:07:59 2024 -0400
+
+    Fix regex match operator (#336)
+
+commit e214b75565439461302342083a9bca59894cf34f
+Author: Shane <[email protected]>
+Date:   Tue Jul 30 18:08:25 2024 +0100
+
+    Remove `Table Expr b` constraint from `materialize` (#334)
+    
+    Not only is this not necessary, it can actually act as a barrier to optimisation. The reason I added it was because it seemed like a cheap way to stop someone writing `query' <- materialize query id` — if you return the materialized query from `materialized`, it won't work. Really we would need some sort of `runST` type trick here to do this properly, but that would be too invasive a change.
+
+commit 149ec23c6f32ff677940ca39d6598cfc3a9593bb
+Author: Shane <[email protected]>
+Date:   Mon Jul 15 11:54:22 2024 +0100
+
+    Add `aggregate{Just,Left,Right,This,That,Those,Here,There}Table{,1}` aggregators (#333)
+    
+    These provide another way to do aggregation of `MaybeTable`, `EitherTable` and `TheseTable`s than the existing `aggregate{Maybe,Either,These}Table`.
+
+commit dbda2da7bc94da0b4118be1ff689aab67f2f56ed
+Author: Teo Camarasu <[email protected]>
+Date:   Tue Jul 2 16:41:09 2024 +0100
+
+    docs: fix haddock link (#332)
+    
+    Previously this linked to Prelude.fromIntegral, but we mean Rel8.Num.fromIntegral
+
+commit 6b0721b4ca53f228775501bbe7e56722aec27a47
+Author: Shane <[email protected]>
+Date:   Mon Jul 1 12:56:48 2024 +0100
+
+    Expose `listOf` and `nonEmptyOf` (#330)
+    
+    It was an oversight that these were ever not exported.
+
+commit d8ca92fe85ceec0ff4cf55c9156678bd55a23fc1
+Author: Teo Camarasu <[email protected]>
+Date:   Thu Jun 20 17:28:57 2024 +0100
+
+    Fix code block format (#329)
+    
+    Without the indentation, this doesn't parse properly
+
+commit 21b17334864a2abbeac3f953710f9f0e6ac95f10
+Author: Teo Camarasu <[email protected]>
+Date:   Wed May 29 15:56:49 2024 +0100
+
+    docs: remove empty 'where' clause (#327)
+    
+    This hanging where statement seems like a typo or the ghost of a proper where long gone
+
+commit 6ec03667c472b102f9e447c682cc00c680f1a152
+Author: abigailalice <[email protected]>
+Date:   Wed Apr 3 07:57:50 2024 -0700
+
+    Fix some markup in haddocks (#318)
+    
+    Fixes #315.

result

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

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

@@ -4,11 +4,17 @@
 {-# 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)
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+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(..) )
 import Rel8.Schema.Result (Result)
 import Data.Foldable (foldl', toList )
@@ -21,84 +27,191 @@ 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
-              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
-              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) |]
+import Rel8.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)
+
+
+-- 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
+  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
+
+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}
+  | (subType `TH.AppT` TH.VarT name ) <- fieldType
+  , name == fBinder
+     -- actually might want [t|Columns ($(pure subType) Expr)|]?
+     = do
+        n <- TH.newName "x"
+        columnType <- [t|Columns ($(pure subType) Expr)|]
+        pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant =  Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n}
+  | otherwise = prettyFail $ "Field of unexpected type: "  ++ show fieldType
+
+generateGColumns :: ParsedDatatype -> Q TH.Type
+generateGColumns ParsedDatatype{..} =
+  foldr1 (\x y -> [t|HProduct $x $y|]) $ map generateGColumn fields
   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
+    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
 
-      other -> error $ show other
+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 $( TH.varP contextName ) $(columnsP)=
+            case $( TH.varE contextName ) of
+              SResult    -> $(constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x) (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+              SExpr      -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+              SField     -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x))
+              SName      -> $(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) (\_ x -> TH.VarE 'toColumns `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 'fromResult `TH.AppTypeE` TH.ConT ''Result `TH.AppTypeE` (ft `TH.AppT` TH.ConT ''Result) `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 'toResult `TH.AppTypeE` TH.ConT ''Result `TH.AppTypeE` (ft `TH.AppT` TH.ConT ''Result) `TH.AppE` x)))
+   |]

src/Rel8Test.hs

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