{-# 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, Dec, instanceD, )
import Language.Haskell.TH.Compat.Constraint (classP)
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 TypeQ
tyCon [Name]
avs = do
let classP' :: Name -> Name -> TypeQ
classP' Name
n Name
v = Name -> [TypeQ] -> TypeQ
classP Name
n [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v]
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(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 TypeQ
tySql TypeQ
tyRec [Name]
avs = do
let classP' :: Name -> Name -> TypeQ
classP' Name
n Name
v = Name -> [TypeQ] -> TypeQ
classP Name
n [TypeQ
tySql, forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v]
Dec
fromI <-
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(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 <-
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(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 |] []
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
fromI, Dec
toI]
persistableWidth :: Int -> Q [Dec]
persistableWidth :: Int -> Q [Dec]
persistableWidth Int
n = do
(((TypeQ
tyCon, [Name]
avs), ExpQ
_), (Maybe [Name], [TypeQ])
_) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType 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 Int
n = do
(((TypeQ
tyCon, [Name]
avs), ExpQ
_), (Maybe [Name], [TypeQ])
_) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
n
TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances (forall (m :: * -> *). Quote m => Name -> m Type
varT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"q") TypeQ
tyCon [Name]
avs
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances Int
n =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
| forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
minBound :: Int) forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
minBound :: Int32) Bool -> Bool -> Bool
&&
forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
maxBound :: Int) forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
maxBound :: Int32) = forall a. a -> Maybe a
Just [t| Int |]
| forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
minBound :: Int) forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
minBound :: Int64) Bool -> Bool -> Bool
&&
forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
maxBound :: Int) forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toI (forall a. Bounded a => a
maxBound :: Int64) = forall a. a -> Maybe a
Just [t| Int |]
| Bool
otherwise = forall a. Maybe a
Nothing
where
toI :: Integral a => a -> Integer
toI :: forall a. Integral a => a -> Integer
toI = forall a b. (Integral a, Num b) => a -> b
fromIntegral