{-# 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
(TypeCon -> TypeCon -> Bool)
-> (TypeCon -> TypeCon -> Bool) -> Eq TypeCon
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 an :: Name
an) compare :: TypeCon -> TypeCon -> Ordering
`compare` TypeCon (ConT bn :: Name
bn)    = Name
an Name -> Name -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name
bn
  TypeCon (ConT _)  `compare` TypeCon _            = Ordering
LT
  TypeCon _         `compare` TypeCon (ConT _)     = Ordering
GT
  a :: TypeCon
a                 `compare` b :: TypeCon
b       | TypeCon
a TypeCon -> TypeCon -> Bool
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 =  [TypeCon] -> TConSet
forall a. Ord a => [a] -> Set a
Set.fromList ([TypeCon] -> TConSet)
-> ([Type] -> [TypeCon]) -> [Type] -> TConSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> TypeCon) -> [Type] -> [TypeCon]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeCon
TypeCon

-- | From 'TConSet' into 'Type' list.
toList :: TConSet -> [Type]
toList :: TConSet -> [Type]
toList =  (TypeCon -> Type) -> [TypeCon] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeCon -> Type
unTypeCon ([TypeCon] -> [Type])
-> (TConSet -> [TypeCon]) -> TConSet -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TConSet -> [TypeCon]
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 Q Info -> (Info -> Q [(Type, Type)]) -> Q [(Type, Type)]
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 =
    [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q a) -> ([Char] -> [Char]) -> [Char] -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("convertibleSqlValues: Unknown declaration pattern: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
  d0 :: Info -> Q [(Type, Type)]
d0 (ClassI _ is :: [InstanceDec]
is) = ([Maybe (Type, Type)] -> [(Type, Type)])
-> Q [Maybe (Type, Type)] -> Q [(Type, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Type, Type)] -> [(Type, Type)]
forall a. [Maybe a] -> [a]
catMaybes (Q [Maybe (Type, Type)] -> Q [(Type, Type)])
-> Q [Maybe (Type, Type)] -> Q [(Type, Type)]
forall a b. (a -> b) -> a -> b
$ (InstanceDec -> Q (Maybe (Type, Type)))
-> [InstanceDec] -> Q [Maybe (Type, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ([Type], Type, [InstanceDec]) -> Q (Maybe (Type, Type))
forall a c. Maybe (a, Type, c) -> Q (Maybe (Type, Type))
d1 (Maybe ([Type], Type, [InstanceDec]) -> Q (Maybe (Type, Type)))
-> (InstanceDec -> Maybe ([Type], Type, [InstanceDec]))
-> InstanceDec
-> Q (Maybe (Type, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceDec -> Maybe ([Type], Type, [InstanceDec])
unInstanceD) [InstanceDec]
is  where
    d1 :: Maybe (a, Type, c) -> Q (Maybe (Type, Type))
d1 (Just (_cxt :: a
_cxt, (AppT (AppT (ConT _n :: Name
_n) a :: Type
a) b :: Type
b), _ds :: c
_ds))
      = do Type
qvt <- Q Type
sqlValueType
           Maybe (Type, Type) -> Q (Maybe (Type, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return
             (Maybe (Type, Type) -> Q (Maybe (Type, Type)))
-> Maybe (Type, Type) -> Q (Maybe (Type, Type))
forall a b. (a -> b) -> a -> b
$ if Type
qvt Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
a Bool -> Bool -> Bool
|| Type
qvt Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b
               then case (Type
a, Type
b) of
                 (ConT _, ConT _) -> (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
a, Type
b)
                 _                -> Maybe (Type, Type)
forall a. Maybe a
Nothing
               else Maybe (Type, Type)
forall a. Maybe a
Nothing
    d1  _
      =    [Char] -> Q (Maybe (Type, Type))
forall a. [Char] -> Q a
unknownDeclaration ([Char] -> Q (Maybe (Type, Type)))
-> [Char] -> Q (Maybe (Type, Type))
forall a b. (a -> b) -> a -> b
$ [InstanceDec] -> [Char]
forall a. Show a => a -> [Char]
show [InstanceDec]
is
  d0 cls :: Info
cls           = [Char] -> Q [(Type, Type)]
forall a. [Char] -> Q a
unknownDeclaration ([Char] -> Q [(Type, Type)]) -> [Char] -> Q [(Type, Type)]
forall a b. (a -> b) -> a -> b
$ Info -> [Char]
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 ([Type] -> TConSet)
-> ([(Type, Type)] -> [Type]) -> [(Type, Type)] -> TConSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Type) -> Type) -> [(Type, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type) -> Type
forall a b. (a, b) -> b
snd ([(Type, Type)] -> [Type])
-> ([(Type, Type)] -> [(Type, Type)]) -> [(Type, Type)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Type) -> Bool) -> [(Type, Type)] -> [(Type, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
qvt) (Type -> Bool) -> ((Type, Type) -> Type) -> (Type, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Type) -> Type
forall a b. (a, b) -> a
fst) ([(Type, Type)] -> TConSet) -> [(Type, Type)] -> TConSet
forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
vs
      to :: TConSet
to   = [Type] -> TConSet
fromList ([Type] -> TConSet)
-> ([(Type, Type)] -> [Type]) -> [(Type, Type)] -> TConSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Type) -> Type) -> [(Type, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type) -> Type
forall a b. (a, b) -> a
fst ([(Type, Type)] -> [Type])
-> ([(Type, Type)] -> [(Type, Type)]) -> [(Type, Type)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Type) -> Bool) -> [(Type, Type)] -> [(Type, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
qvt) (Type -> Bool) -> ((Type, Type) -> Type) -> (Type, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Type) -> Type
forall a b. (a, b) -> b
snd) ([(Type, Type)] -> TConSet) -> [(Type, Type)] -> TConSet
forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
vs
  TConSet -> Q TConSet
forall (m :: * -> *) a. Monad m => a -> m a
return (TConSet -> Q TConSet) -> TConSet -> Q TConSet
forall a b. (a -> b) -> a -> b
$ TConSet -> TConSet -> TConSet
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 Q Info -> (Info -> Q TConSet) -> Q TConSet
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 =
    [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q a) -> ([Char] -> [Char]) -> [Char] -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("persistableWidthTypes: Unknown declaration pattern: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
  d0 :: Info -> Q TConSet
d0 (ClassI _ is :: [InstanceDec]
is) = ([Type] -> TConSet) -> Q [Type] -> Q TConSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> TConSet
fromList (Q [Type] -> Q TConSet) -> Q [Type] -> Q TConSet
forall a b. (a -> b) -> a -> b
$ (InstanceDec -> Q Type) -> [InstanceDec] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ([Type], Type, [InstanceDec]) -> Q Type
forall a c. Maybe (a, Type, c) -> Q Type
d1 (Maybe ([Type], Type, [InstanceDec]) -> Q Type)
-> (InstanceDec -> Maybe ([Type], Type, [InstanceDec]))
-> InstanceDec
-> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceDec -> Maybe ([Type], Type, [InstanceDec])
unInstanceD) [InstanceDec]
is  where
    d1 :: Maybe (a, Type, c) -> Q Type
d1 (Just (_cxt :: a
_cxt, (AppT (ConT _n :: Name
_n) a :: Type
a), _ds :: c
_ds))  = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a
    d1  _                                      = [Char] -> Q Type
forall a. [Char] -> Q a
unknownDeclaration ([Char] -> Q Type) -> [Char] -> Q Type
forall a b. (a -> b) -> a -> b
$ [InstanceDec] -> [Char]
forall a. Show a => a -> [Char]
show [InstanceDec]
is
  d0 cls :: Info
cls           = [Char] -> Q TConSet
forall a. [Char] -> Q a
unknownDeclaration ([Char] -> Q TConSet) -> [Char] -> Q TConSet
forall a b. (a -> b) -> a -> b
$ Info -> [Char]
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 [InstanceDec]) -> [Type] -> Q [InstanceDec]
mapInstanceD fD :: Q Type -> Q [InstanceDec]
fD = ([[InstanceDec]] -> [InstanceDec])
-> Q [[InstanceDec]] -> Q [InstanceDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[InstanceDec]] -> [InstanceDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[InstanceDec]] -> Q [InstanceDec])
-> ([Type] -> Q [[InstanceDec]]) -> [Type] -> Q [InstanceDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Q [InstanceDec]) -> [Type] -> Q [[InstanceDec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Type -> Q [InstanceDec]
fD (Q Type -> Q [InstanceDec])
-> (Type -> Q Type) -> Type -> Q [InstanceDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type
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 [InstanceDec]
derivePersistableInstancesFromConvertibleSqlValues =  do
  TConSet
wds <- Q TConSet
persistableWidthTypes
  TConSet
svs <- Q TConSet
convertibleSqlValues
  [InstanceDec]
ws <- (Q Type -> Q [InstanceDec]) -> [Type] -> Q [InstanceDec]
mapInstanceD Q Type -> Q [InstanceDec]
deriveNotNullType (TConSet -> [Type]
toList (TConSet -> [Type]) -> TConSet -> [Type]
forall a b. (a -> b) -> a -> b
$ TConSet -> TConSet -> TConSet
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
  [InstanceDec]
ps <- (Q Type -> Q [InstanceDec]) -> [Type] -> Q [InstanceDec]
mapInstanceD Q Type -> Q [InstanceDec]
derivePersistableInstanceFromConvertible [Type]
svl
  [InstanceDec]
ss <- (Q Type -> Q [InstanceDec]) -> [Type] -> Q [InstanceDec]
mapInstanceD Q Type -> Q [InstanceDec]
defineScalarDegree [Type]
svl
  [InstanceDec] -> Q [InstanceDec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstanceDec] -> Q [InstanceDec])
-> [InstanceDec] -> Q [InstanceDec]
forall a b. (a -> b) -> a -> b
$ [InstanceDec]
ws [InstanceDec] -> [InstanceDec] -> [InstanceDec]
forall a. [a] -> [a] -> [a]
++ [InstanceDec]
ps [InstanceDec] -> [InstanceDec] -> [InstanceDec]
forall a. [a] -> [a] -> [a]
++ [InstanceDec]
ss