{-# 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, classP,
appT, tupleT, varT, litT, strTyLit, clause, normalB, listE)
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 recName :: ConName
recName colStr :: String
colStr ix :: Int
ix colType :: TypeQ
colType =
[d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where
projection _ = definePi $ $offsetsExp ! $(integralE ix)
|]
where
offsetsExp :: ExpQ
offsetsExp = VarName -> ExpQ
toVarExp (VarName -> ExpQ) -> (Name -> VarName) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault (Name -> ExpQ) -> Name -> ExpQ
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 recType :: TypeQ
recType avs :: [Name]
avs sels :: [String]
sels cts :: [TypeQ]
cts =
[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
$ (String -> TypeQ -> [TypeQ] -> Q Dec)
-> [String] -> [TypeQ] -> [[TypeQ]] -> [Q Dec]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 String -> TypeQ -> [TypeQ] -> Q Dec
template [String]
sels [TypeQ]
cts ([TypeQ] -> [[TypeQ]]
forall a. [a] -> [[a]]
inits [TypeQ]
cts)
where
template :: String -> TypeQ -> [TypeQ] -> Q Dec
template colStr :: String
colStr colType :: TypeQ
colType pcts :: [TypeQ]
pcts =
CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
((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| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
[[TypeQ] -> Q Dec
projectionDec [TypeQ]
pcts]
projectionDec :: [TypeQ] -> Q Dec
projectionDec :: [TypeQ] -> Q Dec
projectionDec cts :: [TypeQ]
cts =
Name -> [ClauseQ] -> Q Dec
funD
(String -> Name
mkName "projection")
[[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[p| _ |]]
(ExpQ -> BodyQ
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |])
[]]
where
runPW :: TypeQ -> ExpQ
runPW t :: TypeQ
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
#else
polymorphicProjections _ _ _ _ = [d| |]
#endif
tupleProjection :: Int -> Q [Dec]
tupleProjection :: Int -> Q [Dec]
tupleProjection n :: Int
n = do
[Dec]
p <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs ["fst", "snd"] [TypeQ]
cts
[Dec]
q <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs [String]
sels [TypeQ]
cts
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
p [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
q
where
sels :: [String]
sels = [ "pi" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
| Int
i <- [ 0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ]
((avs :: [Name]
avs, cts :: [TypeQ]
cts), tyRec :: TypeQ
tyRec) = (([Name], [TypeQ]), TypeQ)
tupleN
tupleN :: (([Name], [TypeQ]), TypeQ)
tupleN :: (([Name], [TypeQ]), TypeQ)
tupleN = (([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
$ "a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j | Int
j <- [1 .. Int
n] ]
vs :: [TypeQ]
vs = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
ns
definePrimaryHasProjection :: TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
definePrimaryHasProjection :: TypeQ -> TypeQ -> [Int] -> Q [Dec]
definePrimaryHasProjection recType :: TypeQ
recType colType :: TypeQ
colType indexes :: [Int]
indexes =
[d| instance HasProjection "primary" $recType $colType where
projection _ = projectionKey
$ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
|]
#else
definePrimaryHasProjection _ _ _ = [d| |]
#endif