{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
module Database.Relational.InternalTH.Overloaded (
monomorphicProjection,
polymorphicProjections,
tupleProjection,
definePrimaryHasProjection,
) where
#if __GLASGOW_HASKELL__ >= 800
import Language.Haskell.TH
(Name, mkName, Q, TypeQ, Dec, instanceD, funD,
appT, tupleT, varT, litT, strTyLit, clause, normalB, listE)
import Language.Haskell.TH.Compat.Constraint (classP)
import Language.Haskell.TH.Lib.Extra (integralE)
import Language.Haskell.TH.Name.CamelCase
(ConName, conName, toVarExp, toTypeCon)
import Data.List (foldl', inits)
import Data.Array ((!))
import Database.Record.Persistable
(PersistableWidth, persistableWidth,
PersistableRecordWidth, runPersistableRecordWidth)
import Database.Record.TH (columnOffsetsVarNameDefault)
import Database.Relational.Pi.Unsafe (definePi)
import Database.Relational.Constraint (unsafeDefineConstraintKey, projectionKey)
import Database.Relational.OverloadedProjection (HasProjection (projection))
#else
import Language.Haskell.TH (Name, mkName, Q, TypeQ, appT, tupleT, varT, Dec)
import Language.Haskell.TH.Name.CamelCase (ConName)
import Data.List (foldl')
#endif
monomorphicProjection :: ConName
-> String
-> Int
-> TypeQ
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
monomorphicProjection :: ConName -> String -> Int -> TypeQ -> Q [Dec]
monomorphicProjection ConName
recName String
colStr Int
ix TypeQ
colType =
[d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where
projection _ = definePi $ $offsetsExp ! $(integralE ix)
|]
where
offsetsExp :: ExpQ
offsetsExp = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
recName
#else
monomorphicProjection _ _ _ _ = [d| |]
#endif
polymorphicProjections :: TypeQ
-> [Name]
-> [String]
-> [TypeQ]
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
polymorphicProjections :: TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
recType [Name]
avs [String]
sels [TypeQ]
cts =
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 String -> TypeQ -> [TypeQ] -> Q Dec
template [String]
sels [TypeQ]
cts (forall a. [a] -> [[a]]
inits [TypeQ]
cts)
where
template :: String -> TypeQ -> [TypeQ] -> Q Dec
template String
colStr TypeQ
colType [TypeQ]
pcts =
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 ''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| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
[[TypeQ] -> Q Dec
projectionDec [TypeQ]
pcts]
projectionDec :: [TypeQ] -> Q Dec
projectionDec :: [TypeQ] -> Q Dec
projectionDec [TypeQ]
cts =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
(String -> Name
mkName String
"projection")
[forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [[p| _ |]]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |])
[]]
where
runPW :: m Type -> m Exp
runPW m Type
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
#else
polymorphicProjections _ _ _ _ = [d| |]
#endif
tupleProjection :: Int -> Q [Dec]
tupleProjection :: Int -> Q [Dec]
tupleProjection Int
n = do
[Dec]
p <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs [String
"fst", String
"snd"] [TypeQ]
cts
[Dec]
q <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs [String]
sels [TypeQ]
cts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
p forall a. [a] -> [a] -> [a]
++ [Dec]
q
where
sels :: [String]
sels = [ String
"pi" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
| Int
i <- [ Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1] ]
(([Name]
avs, [TypeQ]
cts), TypeQ
tyRec) = (([Name], [TypeQ]), TypeQ)
tupleN
tupleN :: (([Name], [TypeQ]), TypeQ)
tupleN :: (([Name], [TypeQ]), TypeQ)
tupleN = (([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
definePrimaryHasProjection :: TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
definePrimaryHasProjection :: TypeQ -> TypeQ -> [Int] -> Q [Dec]
definePrimaryHasProjection TypeQ
recType TypeQ
colType [Int]
indexes =
[d| instance HasProjection "primary" $recType $colType where
projection _ = projectionKey
$ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
|]
#else
definePrimaryHasProjection _ _ _ = [d| |]
#endif