{-# 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
    { ParsedDatatype -> Name
name :: TH.Name
    , ParsedDatatype -> Name
conName :: TH.Name
    , ParsedDatatype -> Name
fBinder :: TH.Name
    , ParsedDatatype -> NonEmpty ParsedField
fields :: NonEmpty ParsedField
    }
    deriving (Int -> ParsedDatatype -> ShowS
[ParsedDatatype] -> ShowS
ParsedDatatype -> String
(Int -> ParsedDatatype -> ShowS)
-> (ParsedDatatype -> String)
-> ([ParsedDatatype] -> ShowS)
-> Show ParsedDatatype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParsedDatatype -> ShowS
showsPrec :: Int -> ParsedDatatype -> ShowS
$cshow :: ParsedDatatype -> String
show :: ParsedDatatype -> String
$cshowList :: [ParsedDatatype] -> ShowS
showList :: [ParsedDatatype] -> ShowS
Show)

-- | Represent a valid field
data ParsedField
    = ParsedField
    { ParsedField -> Maybe Name
fieldSelector :: Maybe TH.Name
    , ParsedField -> Type
fieldType :: TH.Type
    , ParsedField -> Type
fieldColumnType :: TH.Type
    , ParsedField -> Name
fieldFreshName :: TH.Name
    }
    deriving (Int -> ParsedField -> ShowS
[ParsedField] -> ShowS
ParsedField -> String
(Int -> ParsedField -> ShowS)
-> (ParsedField -> String)
-> ([ParsedField] -> ShowS)
-> Show ParsedField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParsedField -> ShowS
showsPrec :: Int -> ParsedField -> ShowS
$cshow :: ParsedField -> String
show :: ParsedField -> String
$cshowList :: [ParsedField] -> ShowS
showList :: [ParsedField] -> ShowS
Show)

-- | 'fail' but indicate that the failure is coming from our code
prettyFail :: String -> Q a
prettyFail :: forall a. String -> Q a
prettyFail String
str = String -> Q a
forall a. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"deriveRel8able: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

parseDatatype :: DatatypeInfo -> Q ParsedDatatype
parseDatatype :: DatatypeInfo -> Q ParsedDatatype
parseDatatype DatatypeInfo
datatypeInfo = do
    constructor <-
        -- Check that it only has one constructor
        case DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo of
            [ConstructorInfo
cons] -> ConstructorInfo -> Q ConstructorInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorInfo
cons
            [ConstructorInfo]
_ -> String -> Q ConstructorInfo
forall a. String -> Q a
prettyFail String
"exepecting a datatype with exactly 1 constructor"
    let conName = ConstructorInfo -> Name
TH.Datatype.constructorName ConstructorInfo
constructor
    let name = DatatypeInfo -> Name
datatypeName DatatypeInfo
datatypeInfo
    fBinder <- case unsnoc $ datatypeInstTypes datatypeInfo of
        Just ([Type]
_, Type
candidate) -> Type -> Q Name
parseFBinder Type
candidate
        Maybe ([Type], Type)
Nothing -> String -> Q Name
forall a. String -> Q a
prettyFail String
"expecting the datatype to have a context type parameter like `data Foo f = ...`"
    let fieldSelectors = case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
constructor of
            -- Only record constructors have field names
            RecordConstructor [Name]
names -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
names
            ConstructorVariant
_ -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
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 :: Type -> Q Name
parseFBinder (TH.SigT Type
x (TH.ConT Name
kind))
    | Name
kind Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Context = Type -> Q Name
parseFBinder Type
x
    | Bool
otherwise = String -> Q Name
forall a. String -> Q a
prettyFail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"expected kind encountered for the context type argument: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
kind
-- type Context = Type -> Type
parseFBinder (TH.SigT Type
x (Type
TH.ArrowT `TH.AppT` Type
TH.StarT `TH.AppT` Type
TH.StarT)) = Type -> Q Name
parseFBinder Type
x
parseFBinder (TH.VarT Name
name) = Name -> Q Name
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name
parseFBinder Type
typ = String -> Q Name
forall a. String -> Q a
prettyFail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"unexpected type encountered while looking for the context type argument to the datatype: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ

parseField :: TH.Name -> TH.Type -> Maybe TH.Name -> Q ParsedField
parseField :: Name -> Type -> Maybe Name -> Q ParsedField
parseField Name
fBinder Type
fieldType Maybe Name
fieldSelector = do
    n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"x"
    let ft = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
TH.Datatype.applySubstitution ([(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name
fBinder, Name -> Type
TH.ConT ''Expr)]) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type
resolveColumnF Name
fBinder Type
fieldType
    columnType <- case ft of
        -- Without special casing this, we get lots of UndecidableInstance errors
        -- ie, rewrite Expr \phi to HIdentity \phi
        (TH.ConT Name
exprName' `TH.AppT` Type
x) | Name
exprName' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Expr -> [t|HIdentity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
x)|] --
        Type
_ -> [t|Columns $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
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 :: forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1Tree a -> a -> a
f NonEmpty a
xs0 = [a] -> Int -> a
go (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
xs0) Int
size0
  where
    size0 :: Int
size0 = NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
xs0
    go :: [a] -> Int -> a
go [] Int
_ = String -> a
forall a. HasCallStack => String -> a
error String
"impossible"
    go [a
x] Int
_ = a
x
    go [a
x,a
y] Int
_ = a -> a -> a
f a
x a
y
    go [a]
xs Int
size = a -> a -> a
f ([a] -> Int -> a
go [a]
left Int
half) ([a] -> Int -> a
go [a]
right (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
half))
      where
        -- Invariants:
        -- half > 0, since size is >2, this will always be the case
        -- size - half > 0
        half :: Int
half = Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
        ([a]
left, [a]
right) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
half [a]
xs

generateGColumns :: ParsedDatatype -> Q TH.Type
generateGColumns :: ParsedDatatype -> Q Type
generateGColumns ParsedDatatype{NonEmpty ParsedField
Name
name :: ParsedDatatype -> Name
conName :: ParsedDatatype -> Name
fBinder :: ParsedDatatype -> Name
fields :: ParsedDatatype -> NonEmpty ParsedField
name :: Name
conName :: Name
fBinder :: Name
fields :: NonEmpty ParsedField
..} =
    (Q Type -> Q Type -> Q Type) -> NonEmpty (Q Type) -> Q Type
forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1Tree (\Q Type
x Q Type
y -> [t|HProduct $Q Type
x $Q Type
y|]) (NonEmpty (Q Type) -> Q Type) -> NonEmpty (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ (ParsedField -> Q Type)
-> NonEmpty ParsedField -> NonEmpty (Q Type)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedField -> Q Type
forall {m :: * -> *}. Quote m => ParsedField -> m Type
generateGColumn NonEmpty ParsedField
fields
  where
    generateGColumn :: ParsedField -> m Type
generateGColumn ParsedField{Maybe Name
Type
Name
fieldSelector :: ParsedField -> Maybe Name
fieldType :: ParsedField -> Type
fieldColumnType :: ParsedField -> Type
fieldFreshName :: ParsedField -> Name
fieldSelector :: Maybe Name
fieldType :: Type
fieldColumnType :: Type
fieldFreshName :: Name
..} =
        Maybe Name -> m Type -> m Type
forall {m :: * -> *}. Quote m => Maybe Name -> m Type -> m Type
labelled Maybe Name
fieldSelector [t|$(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldColumnType)|]
    labelled :: Maybe Name -> m Type -> m Type
labelled Maybe Name
Nothing m Type
x = m Type
x
    labelled (Just (TH.Name (TH.OccName String
fieldSelector) NameFlavour
_)) m Type
x = [t|HLabel $(m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
TH.litT (m TyLit -> m Type) -> m TyLit -> m Type
forall a b. (a -> b) -> a -> b
$ String -> m TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
TH.strTyLit String
fieldSelector) $m Type
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 -> (Q Type -> Q Exp -> Q Exp) -> Q Exp
generateColumnsE ParsedDatatype{NonEmpty ParsedField
Name
name :: ParsedDatatype -> Name
conName :: ParsedDatatype -> Name
fBinder :: ParsedDatatype -> Name
fields :: ParsedDatatype -> NonEmpty ParsedField
name :: Name
conName :: Name
fBinder :: Name
fields :: NonEmpty ParsedField
..} Q Type -> Q Exp -> Q Exp
g =
    (Q Exp -> Q Exp -> Q Exp) -> NonEmpty (Q Exp) -> Q Exp
forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1Tree (\Q Exp
x Q Exp
y -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE 'HProduct Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Q Exp
x Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Q Exp
y) (NonEmpty (Q Exp) -> Q Exp) -> NonEmpty (Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ParsedField -> Q Exp) -> NonEmpty ParsedField -> NonEmpty (Q Exp)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedField -> Q Exp
generateColumnE NonEmpty ParsedField
fields
  where
    generateColumnE :: ParsedField -> Q Exp
generateColumnE ParsedField{Maybe Name
Type
Name
fieldSelector :: ParsedField -> Maybe Name
fieldType :: ParsedField -> Type
fieldColumnType :: ParsedField -> Type
fieldFreshName :: ParsedField -> Name
fieldSelector :: Maybe Name
fieldType :: Type
fieldColumnType :: Type
fieldFreshName :: Name
..} =
        Maybe Name -> Q Exp -> Q Exp
forall {m :: * -> *} {a}. Quote m => Maybe a -> m Exp -> m Exp
labelled Maybe Name
fieldSelector (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
            Q Type -> Q Exp -> Q Exp
g (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
fieldFreshName
    labelled :: Maybe a -> m Exp -> m Exp
labelled Maybe a
Nothing m Exp
x = m Exp
x
    labelled (Just a
_) m Exp
x = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE 'HLabel m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` m Exp
x

-- | Generate a pattern to destruct a column
generateColumnsP :: ParsedDatatype -> TH.Pat
generateColumnsP :: ParsedDatatype -> Pat
generateColumnsP ParsedDatatype{NonEmpty ParsedField
Name
name :: ParsedDatatype -> Name
conName :: ParsedDatatype -> Name
fBinder :: ParsedDatatype -> Name
fields :: ParsedDatatype -> NonEmpty ParsedField
name :: Name
conName :: Name
fBinder :: Name
fields :: NonEmpty ParsedField
..} =
    (Pat -> Pat -> Pat) -> NonEmpty Pat -> Pat
forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1Tree (\Pat
x Pat
y -> Name -> [Type] -> [Pat] -> Pat
TH.ConP 'HProduct [] [Pat
x, Pat
y]) (NonEmpty Pat -> Pat) -> NonEmpty Pat -> Pat
forall a b. (a -> b) -> a -> b
$ (ParsedField -> Pat) -> NonEmpty ParsedField -> NonEmpty Pat
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedField -> Pat
generateColumnP NonEmpty ParsedField
fields
  where
    generateColumnP :: ParsedField -> Pat
generateColumnP ParsedField{Maybe Name
Type
Name
fieldSelector :: ParsedField -> Maybe Name
fieldType :: ParsedField -> Type
fieldColumnType :: ParsedField -> Type
fieldFreshName :: ParsedField -> Name
fieldSelector :: Maybe Name
fieldType :: Type
fieldColumnType :: Type
fieldFreshName :: Name
..} =
        Maybe Name -> Pat -> Pat
forall {a}. Maybe a -> Pat -> Pat
labelled Maybe Name
fieldSelector (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$
            Name -> Pat
TH.VarP Name
fieldFreshName
    labelled :: Maybe a -> Pat -> Pat
labelled Maybe a
Nothing Pat
x = Pat
x
    labelled (Just a
_) Pat
x = Name -> [Type] -> [Pat] -> Pat
TH.ConP 'HLabel [] [Pat
x]

-- | Generate an expression to create the constructor
generateConstructorE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp
generateConstructorE :: ParsedDatatype -> (Q Type -> Q Exp -> Q Exp) -> Q Exp
generateConstructorE ParsedDatatype
parsedDatatype Q Type -> Q Exp -> Q Exp
g =
    (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> NonEmpty (Q Exp) -> Q Exp
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE (ParsedDatatype -> Name
conName ParsedDatatype
parsedDatatype)) (NonEmpty (Q Exp) -> Q Exp)
-> (NonEmpty ParsedField -> NonEmpty (Q Exp))
-> NonEmpty ParsedField
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedField -> Q Exp) -> NonEmpty ParsedField -> NonEmpty (Q Exp)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedField -> Q Exp
generateFieldE (NonEmpty ParsedField -> Q Exp) -> NonEmpty ParsedField -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParsedDatatype -> NonEmpty ParsedField
fields ParsedDatatype
parsedDatatype
  where
    generateFieldE :: ParsedField -> Q Exp
generateFieldE ParsedField{Maybe Name
Type
Name
fieldSelector :: ParsedField -> Maybe Name
fieldType :: ParsedField -> Type
fieldColumnType :: ParsedField -> Type
fieldFreshName :: ParsedField -> Name
fieldSelector :: Maybe Name
fieldType :: Type
fieldColumnType :: Type
fieldFreshName :: Name
..} =
        Q Type -> Q Exp -> Q Exp
g (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
fieldFreshName

-- | Generate a pattern to destruct the datatype
generateConstructorP :: ParsedDatatype -> Q TH.Pat
generateConstructorP :: ParsedDatatype -> Q Pat
generateConstructorP ParsedDatatype
parsedDatatype =
  Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> [Pat] -> Pat
TH.ConP (ParsedDatatype -> Name
conName ParsedDatatype
parsedDatatype) [] ([Pat] -> Pat)
-> (NonEmpty ParsedField -> [Pat]) -> NonEmpty ParsedField -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Pat -> [Pat]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Pat -> [Pat])
-> (NonEmpty ParsedField -> NonEmpty Pat)
-> NonEmpty ParsedField
-> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedField -> Pat) -> NonEmpty ParsedField -> NonEmpty Pat
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
TH.VarP (Name -> Pat) -> (ParsedField -> Name) -> ParsedField -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedField -> Name
fieldFreshName) (NonEmpty ParsedField -> Pat) -> NonEmpty ParsedField -> Pat
forall a b. (a -> b) -> a -> b
$ ParsedDatatype -> NonEmpty ParsedField
fields ParsedDatatype
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' :: forall (transposition :: Bool) expr a.
Proxy expr
-> (Serialize transposition expr a,
    transposition ~ (a == Transpose Result expr)) =>
   Columns expr Result -> a
deserialize' Proxy expr
_ = forall (transposition :: Bool) expr a.
Serialize transposition expr a =>
Columns expr Result -> a
deserialize @_ @expr

serialize' :: forall transposition expr a. Proxy expr -> (Serialize transposition expr a, transposition ~ (a == Transpose Result expr)) => a -> Columns expr Result
serialize' :: forall (transposition :: Bool) expr a.
Proxy expr
-> (Serialize transposition expr a,
    transposition ~ (a == Transpose Result expr)) =>
   a -> Columns expr Result
serialize' Proxy expr
_ = forall (transposition :: Bool) expr a.
Serialize transposition expr a =>
a -> Columns expr Result
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 -> Q [Dec]
deriveRel8able Name
name = do
    datatypeInfo <- Name -> Q DatatypeInfo
reifyDatatype Name
name
    parsedDatatype <- parseDatatype datatypeInfo
    let gColumns = ParsedDatatype -> Q Type
generateGColumns ParsedDatatype
parsedDatatype
    let constructorE = ParsedDatatype -> (Q Type -> Q Exp -> Q Exp) -> Q Exp
generateConstructorE ParsedDatatype
parsedDatatype
    let constructorP = ParsedDatatype -> Q Pat
generateConstructorP ParsedDatatype
parsedDatatype
    let columnsE = ParsedDatatype -> (Q Type -> Q Exp -> Q Exp) -> Q Exp
generateColumnsE ParsedDatatype
parsedDatatype
    let columnsP = Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ ParsedDatatype -> Pat
generateColumnsP ParsedDatatype
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 (\Q Type
ft Q Exp
x -> [|deserialize' (Proxy :: Proxy $Q Type
ft) $Q Exp
x|]))
                    SExpr -> case v of $columnsP -> $(constructorE (\Q Type
_ Q Exp
x -> [|fromColumns $Q Exp
x|]))
                    SField -> case v of $columnsP -> $(constructorE (\Q Type
_ Q Exp
x -> [|fromColumns $Q Exp
x|]))
                    SName -> case v of $columnsP -> $(constructorE (\Q Type
_ Q Exp
x -> [|fromColumns $Q Exp
x|]))

            gtoColumns $(TH.varP contextName) $constructorP =
                case $(TH.varE contextName) of
                    SExpr -> $(columnsE (\Q Type
_ Q Exp
x -> [|toColumns $Q Exp
x|]))
                    SField -> $(columnsE (\Q Type
_ Q Exp
x -> [|toColumns $Q Exp
x|]))
                    SName -> $(columnsE (\Q Type
_ Q Exp
x -> [|toColumns $Q Exp
x|]))
                    SResult -> $(columnsE (\Q Type
ft Q Exp
x -> [|serialize' (Proxy :: Proxy $Q Type
ft) $Q Exp
x|]))

            gfromResult $columnsP =
                $(constructorE (\Q Type
ft Q Exp
x -> [|deserialize' (Proxy :: Proxy $Q Type
ft) $Q Exp
x|]))

            gtoResult $constructorP =
                $(columnsE (\Q Type
ft Q Exp
x -> [|serialize' (Proxy :: Proxy $Q Type
ft) $Q Exp
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 :: [Name] -> Q [Dec]
deriveRel8ables [Name]
xs = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Name -> Q [Dec]
deriveRel8able [Name]
xs

-- | Walk 'TH.Type' and replace all occurences of @Column f x@ with @Expr x@.
resolveColumnF :: TH.Name -> TH.Type -> TH.Type
resolveColumnF :: Name -> Type -> Type
resolveColumnF Name
fBinder (TH.ForallT [TyVarBndr Specificity]
tvs [Type]
context Type
t) =
    [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
tvs [Type]
context (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t)
resolveColumnF Name
fBinder (TH.AppT Type
f Type
x)
    | TH.ConT Name
columnName `TH.AppT` (TH.VarT Name
fBinder') <- Type
f
    , Name
columnName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Column
    , Name
fBinder Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fBinder' =
        Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Expr) (Name -> Type -> Type
resolveColumnF Name
fBinder Type
x)
    | Bool
otherwise = Type -> Type -> Type
TH.AppT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
f) (Name -> Type -> Type
resolveColumnF Name
fBinder Type
x)
resolveColumnF Name
fBinder (TH.SigT Type
t Type
k) = Type -> Type -> Type
TH.SigT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t) (Name -> Type -> Type
resolveColumnF Name
fBinder Type
k) -- k could be Kind
resolveColumnF Name
fBinder (TH.InfixT Type
l Name
c Type
r) = Type -> Name -> Type -> Type
TH.InfixT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
l) Name
c (Name -> Type -> Type
resolveColumnF Name
fBinder Type
r)
resolveColumnF Name
fBinder (TH.UInfixT Type
l Name
c Type
r) = Type -> Name -> Type -> Type
TH.UInfixT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
l) Name
c (Name -> Type -> Type
resolveColumnF Name
fBinder Type
r)
resolveColumnF Name
fBinder (TH.ParensT Type
t) = Type -> Type
TH.ParensT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t)
#if MIN_VERSION_template_haskell(2,15,0)
resolveColumnF Name
fBinder (TH.AppKindT Type
t Type
k)  = Type -> Type -> Type
TH.AppKindT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t) (Name -> Type -> Type
resolveColumnF Name
fBinder Type
k)
resolveColumnF Name
fBinder (TH.ImplicitParamT String
n Type
t)
  = String -> Type -> Type
TH.ImplicitParamT String
n (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t)
#endif
#if MIN_VERSION_template_haskell(2,16,0)
resolveColumnF Name
fBinder (TH.ForallVisT [TyVarBndr ()]
tvs Type
t) =
  [TyVarBndr ()] -> Type -> Type
TH.ForallVisT [TyVarBndr ()]
tvs (Name -> Type -> Type
resolveColumnF Name
fBinder Type
t)
#endif
#if MIN_VERSION_template_haskell(2,19,0)
resolveColumnF Name
fBinder (TH.PromotedInfixT Type
l Name
c Type
r)
  = Type -> Name -> Type -> Type
TH.PromotedInfixT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
l) Name
c (Name -> Type -> Type
resolveColumnF Name
fBinder Type
r)
resolveColumnF Name
fBinder (TH.PromotedUInfixT Type
l Name
c Type
r)
  = Type -> Name -> Type -> Type
TH.PromotedUInfixT (Name -> Type -> Type
resolveColumnF Name
fBinder Type
l) Name
c (Name -> Type -> Type
resolveColumnF Name
fBinder Type
r)
#endif
resolveColumnF Name
_ Type
t = Type
t