khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2025-01-07 21:59:22 +03:00
Code Issues Projects Releases Wiki Activity

relational-query: fix not captured symbol. add overloaded tuple projections.

Browse Source
This commit is contained in:
Kei Hibino 2017-11-20 23:59:29 +09:00
parent cf5ad49af9
commit a17f92f835
1 changed files with 34 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
relational-query/src/Database/Relational/InternalTH/Overloaded.hs
View File

@ -14,21 +14,25 @@
module Database.Relational.InternalTH.Overloaded (
monomorphicProjection,
polymorphicProjections,
tupleProjection,
) where
#if __GLASGOW_HASKELL__ >= 800
import Language.Haskell.TH
(Name, Q, TypeQ, Dec, instanceD, classP, varT, litT, strTyLit)
(Name, mkName, Q, TypeQ, Dec, instanceD, funD, classP,
appT, tupleT, varT, litT, strTyLit, clause, normalB)
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, PersistableRecordWidth)
import Database.Record.Persistable
(PersistableWidth, persistableWidth,
PersistableRecordWidth, runPersistableRecordWidth)
import Database.Record.TH (columnOffsetsVarNameDefault)
import Database.Relational.Pi.Unsafe (definePi)
import Database.Relational.OverloadedProjection (HasProjection (..))
import Database.Relational.OverloadedProjection (HasProjection (projection))
#else
import Language.Haskell.TH (Name, Q, TypeQ, Dec)
import Language.Haskell.TH.Name.CamelCase (ConName)
@ -59,12 +63,37 @@ polymorphicProjections :: TypeQ
polymorphicProjections recType avs sels cts =
sequence $ zipWith3 template sels cts (inits cts)
where
runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
template colStr colType pcts =
instanceD
(mapM (classP ''PersistableWidth . (:[]) . varT) avs)
[t| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
[ head <$> [d| projection _ = definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] pcts) |] ]
[projectionDec pcts]
projectionDec :: [TypeQ] -> Q Dec
projectionDec cts =
funD
(mkName "projection")
[clause [[p| _ |]]
(normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |])
[]]
--- In sub-tree, newName "projection" is called by [d| projection .. = |]?
--- head <$> [d| projection _ = 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 =
polymorphicProjections tyRec avs sels cts
where
sels = [ "tuplePi" ++ show n ++ "_" ++ show i
| i <- [ 0 .. n - 1] ]
((avs, cts), tyRec) = tupleN
tupleN :: (([Name], [TypeQ]), TypeQ)
--- same as tupleN of InternalTH.Base, merge after dropping GHC 7.x
tupleN = ((ns, vs), foldl' appT (tupleT n) vs)
where
ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]
vs = map varT ns