{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module Database.Relational.InternalTH.Base (
defineTupleShowLiteralInstance,
defineTuplePi,
defineRecordProjections,
) where
import Control.Applicative ((<$>))
import Data.List (foldl', inits)
import Language.Haskell.TH
(Q, Name, mkName, normalB, varP,
TypeQ, forallT, varT, tupleT, appT,
Dec, sigD, valD, instanceD,
TyVarBndr (PlainTV), )
import Language.Haskell.TH.Compat.Constraint (classP)
import Database.Record.Persistable
(PersistableWidth, persistableWidth,
PersistableRecordWidth, runPersistableRecordWidth)
import Database.Relational.ProjectableClass (LiteralSQL (..))
import Database.Relational.Pi.Unsafe (Pi, definePi)
tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n = (([Name]
ns, [TypeQ]
vs), (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) [TypeQ]
vs)
where
ns :: [Name]
ns = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j | Int
j <- [Int
1 .. Int
n] ]
vs :: [TypeQ]
vs = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
ns
defineTupleShowLiteralInstance :: Int -> Q [Dec]
defineTupleShowLiteralInstance :: Int -> Q [Dec]
defineTupleShowLiteralInstance Int
n = do
let (([Name]
_, [TypeQ]
vs), TypeQ
tty) = Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
((TypeQ -> TypeQ) -> [TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL ([TypeQ] -> TypeQ) -> (TypeQ -> [TypeQ]) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
:[])) [TypeQ]
vs)
[t| LiteralSQL $tty |]
[]
defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyRec [Name]
avs [Name]
sels [TypeQ]
cts =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (TypeQ -> [TypeQ] -> Name -> Q [Dec])
-> [TypeQ] -> [[TypeQ]] -> [Name] -> [Q [Dec]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 TypeQ -> [TypeQ] -> Name -> Q [Dec]
template [TypeQ]
cts ([TypeQ] -> [[TypeQ]]
forall a. [a] -> [[a]]
inits [TypeQ]
cts) [Name]
sels
where
template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]
template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]
template TypeQ
ct [TypeQ]
pcts Name
selN = do
Dec
sig <- Name -> TypeQ -> Q Dec
sigD Name
selN (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
[TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
avs)
((Name -> TypeQ) -> [Name] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''PersistableWidth ([TypeQ] -> TypeQ) -> (Name -> [TypeQ]) -> Name -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
:[]) (TypeQ -> [TypeQ]) -> (Name -> TypeQ) -> Name -> [TypeQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TypeQ
varT) [Name]
avs)
[t| Pi $tyRec $ct |]
let runPW :: TypeQ -> ExpQ
runPW TypeQ
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
Dec
val <- PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
selN)
(ExpQ -> BodyQ
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
sig, Dec
val]
defineTuplePi :: Int -> Q [Dec]
defineTuplePi :: Int -> Q [Dec]
defineTuplePi Int
n =
TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyRec [Name]
avs [Name]
sels [TypeQ]
cts
where
(([Name]
avs, [TypeQ]
cts), TypeQ
tyRec) = Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n
sels :: [Name]
sels = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"tuplePi" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
| Int
i <- [ Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]