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


-- | 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 TypeQ
tyCon [Name]
avs  = do
  -- in template-haskell 2.8 or older, Pred is not Type
  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 |] []

-- | 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 TypeQ
tySql TypeQ
tyRec [Name]
avs = do
  -- in template-haskell 2.8 or older, Pred is not Type
  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

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