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