{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
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 :: TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance tyCon :: TypeQ
tyCon avs :: [Name]
avs = do
let classP' :: Name -> Name -> TypeQ
classP' n :: Name
n v :: Name
v = Name -> [TypeQ] -> TypeQ
classP Name
n [Name -> TypeQ
varT Name
v]
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
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 -> Name -> TypeQ
classP' ''PersistableWidth) [Name]
avs)
[t| PersistableWidth $tyCon |] []
defineSqlPersistableInstances :: TypeQ
-> TypeQ
-> [Name]
-> Q [Dec]
defineSqlPersistableInstances :: TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances tySql :: TypeQ
tySql tyRec :: TypeQ
tyRec avs :: [Name]
avs = do
let classP' :: Name -> Name -> TypeQ
classP' n :: Name
n v :: Name
v = Name -> [TypeQ] -> TypeQ
classP Name
n [TypeQ
tySql, Name -> TypeQ
varT Name
v]
Dec
fromI <-
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 -> Name -> TypeQ
classP' ''FromSql) [Name]
avs)
[t| FromSql $tySql $tyRec |] []
Dec
toI <-
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 -> Name -> TypeQ
classP' ''ToSql) [Name]
avs)
[t| ToSql $tySql $tyRec |] []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
fromI, Dec
toI]
persistableWidth :: Int -> Q [Dec]
persistableWidth :: Int -> Q [Dec]
persistableWidth n :: Int
n = do
(((tyCon :: TypeQ
tyCon, avs :: [Name]
avs), _), _) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType (Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
n
TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance TypeQ
tyCon [Name]
avs
sqlInstances :: Int -> Q [Dec]
sqlInstances :: Int -> Q [Dec]
sqlInstances n :: Int
n = do
(((tyCon :: TypeQ
tyCon, avs :: [Name]
avs), _), _) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType (Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
n
TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances (Name -> TypeQ
varT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "q") TypeQ
tyCon [Name]
avs
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances n :: Int
n =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ Int -> Q [Dec]
persistableWidth Int
n, Int -> Q [Dec]
sqlInstances Int
n ]
knownWidthIntType :: Maybe TypeQ
knownWidthIntType :: Maybe TypeQ
knownWidthIntType
| Int -> Integer
forall a. Integral a => a -> Integer
toI (Int
forall a. Bounded a => a
minBound :: Int) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int32 -> Integer
forall a. Integral a => a -> Integer
toI (Int32
forall a. Bounded a => a
minBound :: Int32) Bool -> Bool -> Bool
&&
Int -> Integer
forall a. Integral a => a -> Integer
toI (Int
forall a. Bounded a => a
maxBound :: Int) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int32 -> Integer
forall a. Integral a => a -> Integer
toI (Int32
forall a. Bounded a => a
maxBound :: Int32) = TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just [t| Int |]
| Int -> Integer
forall a. Integral a => a -> Integer
toI (Int
forall a. Bounded a => a
minBound :: Int) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Integer
forall a. Integral a => a -> Integer
toI (Int64
forall a. Bounded a => a
minBound :: Int64) Bool -> Bool -> Bool
&&
Int -> Integer
forall a. Integral a => a -> Integer
toI (Int
forall a. Bounded a => a
maxBound :: Int) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Integer
forall a. Integral a => a -> Integer
toI (Int64
forall a. Bounded a => a
maxBound :: Int64) = TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just [t| Int |]
| Bool
otherwise = Maybe TypeQ
forall a. Maybe a
Nothing
where
toI :: Integral a => a -> Integer
toI :: a -> Integer
toI = a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral