{-# 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 Language.Haskell.TH.Compat.Data (plainTVspecified)
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), forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
n) [TypeQ]
vs)
where
ns :: [Name]
ns = [ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
j | Int
j <- [Int
1 .. Int
n] ]
vs :: [TypeQ]
vs = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
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
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 TypeQ -> [TypeQ] -> Name -> Q [Dec]
template [TypeQ]
cts (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 <- forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
selN forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT (forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVspecified [Name]
avs)
(forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''PersistableWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Type
varT) [Name]
avs)
[t| Pi $tyRec $ct |]
let runPW :: m Type -> m Exp
runPW m Type
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
Dec
val <- forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
selN)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) []
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 forall a b. (a -> b) -> a -> b
$ String
"tuplePi" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
"'"
| Int
i <- [ Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1] ]