module Database.Record.InternalTH (
definePersistableWidthInstance,
defineSqlPersistableInstances,
defineTupleInstances,
knownWidthIntType,
) where
import Control.Applicative ((<$>))
import Data.Int (Int32, Int64)
import Language.Haskell.TH
(Q, mkName, Name, tupleTypeName,
TypeQ, varT, classP, Dec, instanceD, )
import Data.Functor.ProductIsomorphic.TH (reifyRecordType)
import Database.Record.Persistable (PersistableWidth)
import Database.Record.FromSql (FromSql)
import Database.Record.ToSql (ToSql)
definePersistableWidthInstance :: TypeQ
-> [Name]
-> Q [Dec]
definePersistableWidthInstance tyCon avs = do
let classP' n v = classP n [varT v]
(:[]) <$>
instanceD
(mapM (classP' ''PersistableWidth) avs)
[t| PersistableWidth $tyCon |] []
defineSqlPersistableInstances :: TypeQ
-> TypeQ
-> [Name]
-> Q [Dec]
defineSqlPersistableInstances tySql tyRec avs = do
let classP' n v = classP n [tySql, varT v]
fromI <-
instanceD
(mapM (classP' ''FromSql) avs)
[t| FromSql $tySql $tyRec |] []
toI <-
instanceD
(mapM (classP' ''ToSql) avs)
[t| ToSql $tySql $tyRec |] []
return [fromI, toI]
persistableWidth :: Int -> Q [Dec]
persistableWidth n = do
(((tyCon, avs), _), _) <- reifyRecordType $ tupleTypeName n
definePersistableWidthInstance tyCon avs
sqlInstances :: Int -> Q [Dec]
sqlInstances n = do
(((tyCon, avs), _), _) <- reifyRecordType $ tupleTypeName n
defineSqlPersistableInstances (varT $ mkName "q") tyCon avs
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances n =
concat <$> sequence
[ persistableWidth n, sqlInstances n ]
knownWidthIntType :: Maybe TypeQ
knownWidthIntType
| toI (minBound :: Int) == toI (minBound :: Int32) &&
toI (maxBound :: Int) == toI (maxBound :: Int32) = Just [t| Int |]
| toI (minBound :: Int) == toI (minBound :: Int64) &&
toI (maxBound :: Int) == toI (maxBound :: Int64) = Just [t| Int |]
| otherwise = Nothing
where
toI :: Integral a => a -> Integer
toI = fromIntegral