{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Database.HDBC.Record.InternalTH (
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)
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
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
type TConSet = Set TypeCon
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
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
sqlValueType :: Q Type
sqlValueType :: Q Type
sqlValueType = [t| 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
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
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
mapInstanceD :: (Q Type -> Q [Dec])
-> [Type]
-> Q [Dec]
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)
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