{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

-- |
-- Module      : Database.HDBC.Record.InternalTH
-- Copyright   : 2013,2014,2016 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides internal definitions used from DB-record templates.
module Database.HDBC.Record.InternalTH (
  -- * Persistable instances along with 'Convertible' instances
  derivePersistableInstancesFromConvertibleSqlValues
  ) where

import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as Set

import Language.Haskell.TH
  (Q, Dec, Type(AppT, ConT),
   Info (ClassI), reify)
import Language.Haskell.TH.Compat.Data (unInstanceD)
import Data.Convertible (Convertible)
import Database.HDBC (SqlValue)
import Database.HDBC.SqlValueExtra ()
import Database.Record (PersistableWidth)
import Database.Record.TH (deriveNotNullType)
import Database.Record.Instances ()
import Database.Relational.TH (defineScalarDegree)

import Database.HDBC.Record.TH (derivePersistableInstanceFromConvertible)


-- | Wrapper type which represents type constructor.
newtype TypeCon = TypeCon { TypeCon -> Type
unTypeCon :: Type } deriving TypeCon -> TypeCon -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeCon -> TypeCon -> Bool
$c/= :: TypeCon -> TypeCon -> Bool
== :: TypeCon -> TypeCon -> Bool
$c== :: TypeCon -> TypeCon -> Bool
Eq

-- | Ord instance for type constructor.
instance Ord TypeCon  where
  TypeCon (ConT Name
an) compare :: TypeCon -> TypeCon -> Ordering
`compare` TypeCon (ConT Name
bn)    = Name
an forall a. Ord a => a -> a -> Ordering
`compare` Name
bn
  TypeCon (ConT Name
_)  `compare` TypeCon Type
_            = Ordering
LT
  TypeCon Type
_         `compare` TypeCon (ConT Name
_)     = Ordering
GT
  TypeCon
a                 `compare` TypeCon
b       | TypeCon
a forall a. Eq a => a -> a -> Bool
== TypeCon
b     = Ordering
EQ
                                      | Bool
otherwise  = Ordering
EQ

-- | Set of 'TypeCon'.
type TConSet = Set TypeCon

-- | From 'Type' list into 'TConSet'.
fromList :: [Type] -> TConSet
fromList :: [Type] -> TConSet
fromList =  forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeCon
TypeCon

-- | From 'TConSet' into 'Type' list.
toList :: TConSet -> [Type]
toList :: TConSet -> [Type]
toList =  forall a b. (a -> b) -> [a] -> [b]
map TypeCon -> Type
unTypeCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList


-- | 'SqlValue' type 'Q'.
sqlValueType :: Q Type
sqlValueType :: Q Type
sqlValueType =  [t| SqlValue |]

-- | 'Convertble' pairs with 'SqlValue'.
convertibleSqlValues' :: Q [(Type, Type)]
convertibleSqlValues' :: Q [(Type, Type)]
convertibleSqlValues' =  Q Info
cvInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> Q [(Type, Type)]
d0  where
  cvInfo :: Q Info
cvInfo = Name -> Q Info
reify ''Convertible
  unknownDeclaration :: [Char] -> Q a
unknownDeclaration =
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"convertibleSqlValues: Unknown declaration pattern: " forall a. [a] -> [a] -> [a]
++)
  d0 :: Info -> Q [(Type, Type)]
d0 (ClassI Dec
_ [Dec]
is) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a} {c}. Maybe (a, Type, c) -> Q (Maybe (Type, Type))
d1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Maybe ([Type], Type, [Dec])
unInstanceD) [Dec]
is  where
    d1 :: Maybe (a, Type, c) -> Q (Maybe (Type, Type))
d1 (Just (a
_cxt, (AppT (AppT (ConT Name
_n) Type
a) Type
b), c
_ds))
      = do Type
qvt <- Q Type
sqlValueType
           forall (m :: * -> *) a. Monad m => a -> m a
return
             forall a b. (a -> b) -> a -> b
$ if Type
qvt forall a. Eq a => a -> a -> Bool
== Type
a Bool -> Bool -> Bool
|| Type
qvt forall a. Eq a => a -> a -> Bool
== Type
b
               then case (Type
a, Type
b) of
                 (ConT Name
_, ConT Name
_) -> forall a. a -> Maybe a
Just (Type
a, Type
b)
                 (Type, Type)
_                -> forall a. Maybe a
Nothing
               else forall a. Maybe a
Nothing
    d1  Maybe (a, Type, c)
_
      =    forall {a}. [Char] -> Q a
unknownDeclaration forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show [Dec]
is
  d0 Info
cls           = forall {a}. [Char] -> Q a
unknownDeclaration forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Info
cls

-- | Get types which are 'Convertible' with.
convertibleSqlValues :: Q TConSet
convertibleSqlValues :: Q TConSet
convertibleSqlValues =  do
  Type
qvt <- Q Type
sqlValueType
  [(Type, Type)]
vs  <- Q [(Type, Type)]
convertibleSqlValues'
  let from :: TConSet
from = [Type] -> TConSet
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Type
qvt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
vs
      to :: TConSet
to   = [Type] -> TConSet
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Type
qvt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
vs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.intersection TConSet
from TConSet
to

-- | Get types which are instance of 'PersistableWith'.
persistableWidthTypes :: Q TConSet
persistableWidthTypes :: Q TConSet
persistableWidthTypes =  Q Info
cvInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> Q TConSet
d0  where
  cvInfo :: Q Info
cvInfo = Name -> Q Info
reify ''PersistableWidth
  unknownDeclaration :: [Char] -> Q a
unknownDeclaration =
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"persistableWidthTypes: Unknown declaration pattern: " forall a. [a] -> [a] -> [a]
++)
  d0 :: Info -> Q TConSet
d0 (ClassI Dec
_ [Dec]
is) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> TConSet
fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a} {c}. Maybe (a, Type, c) -> Q Type
d1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Maybe ([Type], Type, [Dec])
unInstanceD) [Dec]
is  where
    d1 :: Maybe (a, Type, c) -> Q Type
d1 (Just (a
_cxt, (AppT (ConT Name
_n) Type
a), c
_ds))  = forall (m :: * -> *) a. Monad m => a -> m a
return Type
a
    d1  Maybe (a, Type, c)
_                                      = forall {a}. [Char] -> Q a
unknownDeclaration forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show [Dec]
is
  d0 Info
cls           = forall {a}. [Char] -> Q a
unknownDeclaration forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Info
cls

-- | Map instance declarations.
mapInstanceD :: (Q Type -> Q [Dec]) -- ^ Template to declare instances from a type
             -> [Type]              -- ^ Types
             -> Q [Dec]             -- ^ Result declaration template.
mapInstanceD :: (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
mapInstanceD Q Type -> Q [Dec]
fD = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Type -> Q [Dec]
fD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return)

-- | Template to declare HDBC instances of DB-record along with 'Convertible' instances.
derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec]
derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec]
derivePersistableInstancesFromConvertibleSqlValues =  do
  TConSet
wds <- Q TConSet
persistableWidthTypes
  TConSet
svs <- Q TConSet
convertibleSqlValues
  [Dec]
ws <- (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
mapInstanceD Q Type -> Q [Dec]
deriveNotNullType (TConSet -> [Type]
toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference TConSet
svs TConSet
wds)
  let svl :: [Type]
svl = TConSet -> [Type]
toList TConSet
svs
  [Dec]
ps <- (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
mapInstanceD Q Type -> Q [Dec]
derivePersistableInstanceFromConvertible [Type]
svl
  [Dec]
ss <- (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
mapInstanceD Q Type -> Q [Dec]
defineScalarDegree [Type]
svl
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
ws forall a. [a] -> [a] -> [a]
++ [Dec]
ps forall a. [a] -> [a] -> [a]
++ [Dec]
ss