{-# 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)


-- | Polymorphic 'PersistableWidth' instance template.
definePersistableWidthInstance :: TypeQ   -- ^ Record type construct expression.
                               -> [Name]  -- ^ Record type construct argument variables.
                               -> Q [Dec] -- ^ Definition of 'PersistableWidth' instance.
definePersistableWidthInstance :: TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance tyCon :: TypeQ
tyCon avs :: [Name]
avs  = do
  -- in template-haskell 2.8 or older, Pred is not Type
  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 |] []

-- | Polymorphic record parser and printer instance templates
--   for converting between list of SQL type and Haskell record type.
defineSqlPersistableInstances :: TypeQ
                              -> TypeQ
                              -> [Name]
                              -> Q [Dec]
defineSqlPersistableInstances :: TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances tySql :: TypeQ
tySql tyRec :: TypeQ
tyRec avs :: [Name]
avs = do
  -- in template-haskell 2.8 or older, Pred is not Type
  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

-- | Template to define tuple instances of persistable-record classes.
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