{-# 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
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 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
type TConSet = Set TypeCon
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
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
sqlValueType :: Q Type
sqlValueType :: Q Type
sqlValueType = [t| 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
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
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
mapInstanceD :: (Q Type -> Q [Dec])
-> [Type]
-> Q [Dec]
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)
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