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..9e9543a5 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 diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index 365c17cb..b677c1df 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 + , 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..43291190 --- /dev/null +++ b/src/Rel8/TH.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +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, ConstructorInfo (ConstructorInfo), DatatypeInfo (..), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName, datatypeVars) +import qualified Language.Haskell.TH.Datatype as TH.Datatype +import Rel8.Generic.Rel8able ( Rel8able(..) ,serialize, deserialize) +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.Column.Maybe ( HMaybe ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable ) +import Rel8.Expr ( Expr ) +import Rel8.Table (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) +import Data.Proxy +import qualified Data.Map.Strict as M + + +-- 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 -- 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 + +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} + -- | (TH.ConT hmaybeCandidate `TH.AppT` TH.VarT fBinderCandidate `TH.AppT` subType) <- fieldType + -- , hmaybeCandidate == ''HMaybe + -- , fBinderCandidate == fBinder + -- = do + -- n <- TH.newName "x" + -- innerType <- [t| Columns $(pure subType)|] + -- let columnType = TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ TH.ConT ''HMaybeTable `TH.AppT` innerType + -- pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n} + -- | subType:(TH.VarT name):other_apps <- typeApps fieldType + -- , name == fBinder + -- = do + -- traceShowM (subType:(TH.VarT name):other_apps) + -- n <- TH.newName "x" + -- columnType <- [t|Columns ($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)])$ unTypeApps subType ((TH.ConT ''Expr):other_apps))) |] + -- traceM $ TH.pprint columnType + -- pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n} + | otherwise + = do + traceShowM fieldType + 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)) |] + traceM $ TH.pprint columnType + pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, 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 -> (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 --`TH.SigE` (fieldColumnType `TH.AppT` TH.WildCardT) + ) + +fromResult' :: forall context a. (Table context a) => Proxy a -> Columns a Result -> FromExprs a +fromResult' _ x = fromResult @_ @a x + +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 {-# 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 :: SContext context -> GColumns $(TH.conT name) context -> $(TH.conT name) context + gfromColumns $( TH.varP contextName ) x = + case $( TH.varE contextName ) of + SResult -> case x of $columnsP -> $(constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x) (\ft x -> TH.VarE 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) + SExpr -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x)) + SField -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x)) + SName -> case x of $columnsP -> $(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) (\ft x -> TH.VarE 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `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 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `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 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) + + |]