module Database.Record.InternalTH (
defineTupleInstances,
knownWidthIntType,
) where
import Control.Applicative ((<$>))
import Data.Int (Int32, Int64)
import Data.List (foldl')
import Language.Haskell.TH
(Q, mkName, Name,
conT, varT, tupleT, appT, classP,
TypeQ, Dec, instanceD, )
import Database.Record.Persistable (PersistableWidth)
import Database.Record.FromSql (FromSql)
import Database.Record.ToSql (ToSql)
persistableWidth :: Int -> Q [Dec]
persistableWidth n = do
let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]
(:[]) <$> instanceD
(mapM (classP ''PersistableWidth . (:[])) vs)
[t| PersistableWidth $(foldl' appT (tupleT n) vs) |]
[]
tupleInstance2 :: Int -> Name -> Q [Dec]
tupleInstance2 n clazz = do
let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]
q = varT $ mkName "q"
(:[]) <$> instanceD
(mapM (\v -> classP clazz [q, v]) vs)
[t| $(conT clazz) $q $(foldl' appT (tupleT n) vs) |]
[]
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances n =
concat <$> sequence
[ persistableWidth n
, tupleInstance2 n ''FromSql
, tupleInstance2 n ''ToSql ]
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