{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,
TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,
UndecidableInstances, FlexibleInstances #-}
module Data.GI.Base.Attributes (
AttrInfo(..),
AttrOpTag(..),
AttrOp(..),
AttrOpAllowed,
AttrGetC,
AttrSetC,
AttrConstructC,
AttrClearC,
get,
set,
clear,
AttrLabelProxy(..)
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Proxy (Proxy(..))
import Data.GI.Base.GValue (GValueConstruct)
import Data.GI.Base.Overloading (HasAttributeList,
ResolveAttribute, IsLabelProxy(..))
import GHC.TypeLits
import GHC.Exts (Constraint)
#if MIN_VERSION_base(4,9,0)
import GHC.OverloadedLabels (IsLabel(..))
#endif
infixr 0 :=,:~,:=>,:~>
data AttrLabelProxy (a :: Symbol) = AttrLabelProxy
instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where
fromLabelProxy :: Proxy x -> AttrLabelProxy a
fromLabelProxy _ = AttrLabelProxy a
forall (a :: Symbol). AttrLabelProxy a
AttrLabelProxy
#if MIN_VERSION_base(4,10,0)
instance a ~ x => IsLabel x (AttrLabelProxy a) where
fromLabel :: AttrLabelProxy a
fromLabel = AttrLabelProxy a
forall (a :: Symbol). AttrLabelProxy a
AttrLabelProxy
#elif MIN_VERSION_base(4,9,0)
instance a ~ x => IsLabel x (AttrLabelProxy a) where
fromLabel _ = AttrLabelProxy
#endif
class AttrInfo (info :: *) where
type AttrAllowedOps info :: [AttrOpTag]
type AttrSetTypeConstraint info :: * -> Constraint
type AttrBaseTypeConstraint info :: * -> Constraint
type AttrGetType info
type AttrLabel info :: Symbol
type AttrOrigin info
attrGet :: AttrBaseTypeConstraint info o =>
Proxy info -> o -> IO (AttrGetType info)
attrSet :: (AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> o -> b -> IO ()
attrClear :: AttrBaseTypeConstraint info o =>
Proxy info -> o -> IO ()
attrConstruct :: (AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> b -> IO (GValueConstruct o)
data OpAllowed tag attrName definingType useType =
OpIsAllowed
#if !MIN_VERSION_base(4,9,0)
| AttrOpNotAllowed Symbol tag Symbol definingType Symbol attrName
#endif
#if MIN_VERSION_base(4,9,0)
type family TypeOriginInfo definingType useType :: ErrorMessage where
TypeOriginInfo definingType definingType =
'Text "‘" ':<>: 'ShowType definingType ':<>: 'Text "’"
TypeOriginInfo definingType useType =
'Text "‘" ':<>: 'ShowType useType ':<>:
'Text "’ (inherited from parent type ‘" ':<>:
'ShowType definingType ':<>: 'Text "’)"
#endif
type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: *) (useType :: *) :: OpAllowed AttrOpTag Symbol * * where
AttrOpIsAllowed tag '[] label definingType useType =
#if !MIN_VERSION_base(4,9,0)
'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute " definingType "." label
#else
TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>:
'Text "’ for type " ':<>:
TypeOriginInfo definingType useType ':<>:
'Text " is not " ':<>:
'Text (AttrOpText tag) ':<>: 'Text ".")
#endif
AttrOpIsAllowed tag (tag ': ops) label definingType useType = 'OpIsAllowed
AttrOpIsAllowed tag (other ': ops) label definingType useType = AttrOpIsAllowed tag ops label definingType useType
type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) (useType :: *) :: Constraint where
AttrOpAllowed tag info useType =
AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) (AttrOrigin info) useType ~ 'OpIsAllowed
data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear
deriving (AttrOpTag -> AttrOpTag -> Bool
(AttrOpTag -> AttrOpTag -> Bool)
-> (AttrOpTag -> AttrOpTag -> Bool) -> Eq AttrOpTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttrOpTag -> AttrOpTag -> Bool
$c/= :: AttrOpTag -> AttrOpTag -> Bool
== :: AttrOpTag -> AttrOpTag -> Bool
$c== :: AttrOpTag -> AttrOpTag -> Bool
Eq, Eq AttrOpTag
Eq AttrOpTag =>
(AttrOpTag -> AttrOpTag -> Ordering)
-> (AttrOpTag -> AttrOpTag -> Bool)
-> (AttrOpTag -> AttrOpTag -> Bool)
-> (AttrOpTag -> AttrOpTag -> Bool)
-> (AttrOpTag -> AttrOpTag -> Bool)
-> (AttrOpTag -> AttrOpTag -> AttrOpTag)
-> (AttrOpTag -> AttrOpTag -> AttrOpTag)
-> Ord AttrOpTag
AttrOpTag -> AttrOpTag -> Bool
AttrOpTag -> AttrOpTag -> Ordering
AttrOpTag -> AttrOpTag -> AttrOpTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AttrOpTag -> AttrOpTag -> AttrOpTag
$cmin :: AttrOpTag -> AttrOpTag -> AttrOpTag
max :: AttrOpTag -> AttrOpTag -> AttrOpTag
$cmax :: AttrOpTag -> AttrOpTag -> AttrOpTag
>= :: AttrOpTag -> AttrOpTag -> Bool
$c>= :: AttrOpTag -> AttrOpTag -> Bool
> :: AttrOpTag -> AttrOpTag -> Bool
$c> :: AttrOpTag -> AttrOpTag -> Bool
<= :: AttrOpTag -> AttrOpTag -> Bool
$c<= :: AttrOpTag -> AttrOpTag -> Bool
< :: AttrOpTag -> AttrOpTag -> Bool
$c< :: AttrOpTag -> AttrOpTag -> Bool
compare :: AttrOpTag -> AttrOpTag -> Ordering
$ccompare :: AttrOpTag -> AttrOpTag -> Ordering
$cp1Ord :: Eq AttrOpTag
Ord, Int -> AttrOpTag
AttrOpTag -> Int
AttrOpTag -> [AttrOpTag]
AttrOpTag -> AttrOpTag
AttrOpTag -> AttrOpTag -> [AttrOpTag]
AttrOpTag -> AttrOpTag -> AttrOpTag -> [AttrOpTag]
(AttrOpTag -> AttrOpTag)
-> (AttrOpTag -> AttrOpTag)
-> (Int -> AttrOpTag)
-> (AttrOpTag -> Int)
-> (AttrOpTag -> [AttrOpTag])
-> (AttrOpTag -> AttrOpTag -> [AttrOpTag])
-> (AttrOpTag -> AttrOpTag -> [AttrOpTag])
-> (AttrOpTag -> AttrOpTag -> AttrOpTag -> [AttrOpTag])
-> Enum AttrOpTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: AttrOpTag -> AttrOpTag -> AttrOpTag -> [AttrOpTag]
$cenumFromThenTo :: AttrOpTag -> AttrOpTag -> AttrOpTag -> [AttrOpTag]
enumFromTo :: AttrOpTag -> AttrOpTag -> [AttrOpTag]
$cenumFromTo :: AttrOpTag -> AttrOpTag -> [AttrOpTag]
enumFromThen :: AttrOpTag -> AttrOpTag -> [AttrOpTag]
$cenumFromThen :: AttrOpTag -> AttrOpTag -> [AttrOpTag]
enumFrom :: AttrOpTag -> [AttrOpTag]
$cenumFrom :: AttrOpTag -> [AttrOpTag]
fromEnum :: AttrOpTag -> Int
$cfromEnum :: AttrOpTag -> Int
toEnum :: Int -> AttrOpTag
$ctoEnum :: Int -> AttrOpTag
pred :: AttrOpTag -> AttrOpTag
$cpred :: AttrOpTag -> AttrOpTag
succ :: AttrOpTag -> AttrOpTag
$csucc :: AttrOpTag -> AttrOpTag
Enum, AttrOpTag
AttrOpTag -> AttrOpTag -> Bounded AttrOpTag
forall a. a -> a -> Bounded a
maxBound :: AttrOpTag
$cmaxBound :: AttrOpTag
minBound :: AttrOpTag
$cminBound :: AttrOpTag
Bounded, Int -> AttrOpTag -> ShowS
[AttrOpTag] -> ShowS
AttrOpTag -> String
(Int -> AttrOpTag -> ShowS)
-> (AttrOpTag -> String)
-> ([AttrOpTag] -> ShowS)
-> Show AttrOpTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrOpTag] -> ShowS
$cshowList :: [AttrOpTag] -> ShowS
show :: AttrOpTag -> String
$cshow :: AttrOpTag -> String
showsPrec :: Int -> AttrOpTag -> ShowS
$cshowsPrec :: Int -> AttrOpTag -> ShowS
Show)
#if MIN_VERSION_base(4,9,0)
type family AttrOpText (tag :: AttrOpTag) :: Symbol where
AttrOpText 'AttrGet = "gettable"
AttrOpText 'AttrSet = "settable"
AttrOpText 'AttrConstruct = "constructible"
AttrOpText 'AttrClear = "nullable"
#endif
type AttrSetC info obj attr value = (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
AttrOpAllowed 'AttrSet info obj,
(AttrSetTypeConstraint info) value)
type AttrConstructC info obj attr value = (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
AttrOpAllowed 'AttrConstruct info obj,
(AttrSetTypeConstraint info) value)
data AttrOp obj (tag :: AttrOpTag) where
(:=) :: (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
AttrOpAllowed tag info obj,
(AttrSetTypeConstraint info) b) =>
AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag
(:=>) :: (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
AttrOpAllowed tag info obj,
(AttrSetTypeConstraint info) b) =>
AttrLabelProxy (attr :: Symbol) -> IO b -> AttrOp obj tag
(:~) :: (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
tag ~ 'AttrSet,
AttrOpAllowed 'AttrSet info obj,
AttrOpAllowed 'AttrGet info obj,
(AttrSetTypeConstraint info) b,
a ~ (AttrGetType info)) =>
AttrLabelProxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag
(:~>) :: (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
tag ~ 'AttrSet,
AttrOpAllowed 'AttrSet info obj,
AttrOpAllowed 'AttrGet info obj,
(AttrSetTypeConstraint info) b,
a ~ (AttrGetType info)) =>
AttrLabelProxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag
set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m ()
set :: o -> [AttrOp o 'AttrSet] -> m ()
set obj :: o
obj = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ([AttrOp o 'AttrSet] -> IO ()) -> [AttrOp o 'AttrSet] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttrOp o 'AttrSet -> IO ()) -> [AttrOp o 'AttrSet] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AttrOp o 'AttrSet -> IO ()
app
where
resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve _ = Proxy (ResolveAttribute attr o)
forall k (t :: k). Proxy t
Proxy
app :: AttrOp o 'AttrSet -> IO ()
app :: AttrOp o 'AttrSet -> IO ()
app (attr :: AttrLabelProxy attr
attr := x :: b
x) = Proxy info -> o -> b -> IO ()
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> o -> b -> IO ()
attrSet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj b
x
app (attr :: AttrLabelProxy attr
attr :=> x :: IO b
x) = IO b
x IO b -> (b -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Proxy info -> o -> b -> IO ()
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> o -> b -> IO ()
attrSet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj
app (attr :: AttrLabelProxy attr
attr :~ f :: a -> b
f) = Proxy info -> o -> IO (AttrGetType info)
forall info o.
(AttrInfo info, AttrBaseTypeConstraint info o) =>
Proxy info -> o -> IO (AttrGetType info)
attrGet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\v :: a
v -> Proxy info -> o -> b -> IO ()
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> o -> b -> IO ()
attrSet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj (a -> b
f a
v)
app (attr :: AttrLabelProxy attr
attr :~> f :: a -> IO b
f) = Proxy info -> o -> IO (AttrGetType info)
forall info o.
(AttrInfo info, AttrBaseTypeConstraint info o) =>
Proxy info -> o -> IO (AttrGetType info)
attrGet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO b
f IO b -> (b -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Proxy info -> o -> b -> IO ()
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
Proxy info -> o -> b -> IO ()
attrSet (AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
forall (attr :: Symbol).
AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve AttrLabelProxy attr
attr) o
obj
type AttrGetC info obj attr result = (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
(AttrBaseTypeConstraint info) obj,
AttrOpAllowed 'AttrGet info obj,
result ~ AttrGetType info)
get :: forall info attr obj result m.
(AttrGetC info obj attr result, MonadIO m) =>
obj -> AttrLabelProxy (attr :: Symbol) -> m result
get :: obj -> AttrLabelProxy attr -> m result
get o :: obj
o _ = IO result -> m result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO result -> m result) -> IO result -> m result
forall a b. (a -> b) -> a -> b
$ Proxy info -> obj -> IO (AttrGetType info)
forall info o.
(AttrInfo info, AttrBaseTypeConstraint info o) =>
Proxy info -> o -> IO (AttrGetType info)
attrGet (Proxy info
forall k (t :: k). Proxy t
Proxy :: Proxy info) obj
o
type AttrClearC info obj attr = (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
(AttrBaseTypeConstraint info) obj,
AttrOpAllowed 'AttrClear info obj)
clear :: forall info attr obj m.
(AttrClearC info obj attr, MonadIO m) =>
obj -> AttrLabelProxy (attr :: Symbol) -> m ()
clear :: obj -> AttrLabelProxy attr -> m ()
clear o :: obj
o _ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Proxy info -> obj -> IO ()
forall info o.
(AttrInfo info, AttrBaseTypeConstraint info o) =>
Proxy info -> o -> IO ()
attrClear (Proxy info
forall k (t :: k). Proxy t
Proxy :: Proxy info) obj
o