{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,
TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,
UndecidableInstances, FlexibleInstances, TypeApplications,
DefaultSignatures, PolyKinds, AllowAmbiguousTypes #-}
module Data.GI.Base.Attributes (
AttrInfo(..),
AttrOpTag(..),
AttrOp(..),
AttrOpAllowed,
AttrGetC,
AttrSetC,
AttrConstructC,
AttrClearC,
get,
set,
clear,
AttrLabelProxy(..)
) where
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.GI.Base.BasicTypes (GObject)
import Data.GI.Base.GValue (GValueConstruct)
import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute)
import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on)
import Data.Proxy (Proxy(..))
import GHC.TypeLits
import GHC.Exts (Constraint)
import GHC.OverloadedLabels (IsLabel(..))
infixr 0 :=,:~,:=>,:~>
data AttrLabelProxy (a :: Symbol) = AttrLabelProxy
#if MIN_VERSION_base(4,10,0)
instance a ~ x => IsLabel x (AttrLabelProxy a) where
fromLabel = AttrLabelProxy
#else
instance a ~ x => IsLabel x (AttrLabelProxy a) where
fromLabel _ = AttrLabelProxy
#endif
class AttrInfo (info :: *) where
type AttrAllowedOps info :: [AttrOpTag]
type AttrBaseTypeConstraint info :: * -> Constraint
type AttrGetType info
type AttrSetTypeConstraint info :: * -> Constraint
type AttrSetTypeConstraint info = (~) (AttrGetType info)
type AttrTransferTypeConstraint info :: * -> Constraint
type AttrTransferTypeConstraint info = (~) (AttrTransferType info)
type AttrTransferType info :: *
type AttrTransferType info = AttrGetType info
type AttrLabel info :: Symbol
type AttrOrigin info
attrGet :: AttrBaseTypeConstraint info o =>
o -> IO (AttrGetType info)
default attrGet ::
CheckNotElem 'AttrGet (AttrAllowedOps info)
(GetNotProvidedError info) =>
o -> IO (AttrGetType info)
attrGet = undefined
attrSet :: (AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
o -> b -> IO ()
default attrSet ::
CheckNotElem 'AttrSet (AttrAllowedOps info)
(SetNotProvidedError info) =>
o -> b -> IO ()
attrSet = undefined
attrClear :: AttrBaseTypeConstraint info o =>
o -> IO ()
default attrClear ::
CheckNotElem 'AttrClear (AttrAllowedOps info)
(ClearNotProvidedError info) =>
o -> IO ()
attrClear = undefined
attrConstruct :: (AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
b -> IO (GValueConstruct o)
default attrConstruct ::
CheckNotElem 'AttrConstruct (AttrAllowedOps info)
(ConstructNotProvidedError info) =>
b -> IO (GValueConstruct o)
attrConstruct = undefined
attrTransfer :: forall o b. (AttrBaseTypeConstraint info o,
AttrTransferTypeConstraint info b) =>
Proxy o -> b -> IO (AttrTransferType info)
default attrTransfer :: forall o b. (AttrBaseTypeConstraint info o,
AttrTransferTypeConstraint info b,
b ~ AttrGetType info,
b ~ AttrTransferType info) =>
Proxy o -> b -> IO (AttrTransferType info)
attrTransfer _ = return
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 "’)"
type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: *) (useType :: *) :: Constraint where
AttrOpIsAllowed tag '[] label definingType useType =
TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>:
'Text "’ for type " ':<>:
TypeOriginInfo definingType useType ':<>:
'Text " is not " ':<>:
'Text (AttrOpText tag) ':<>: 'Text ".")
AttrOpIsAllowed tag (tag ': ops) label definingType useType = ()
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
type family OpNotProvidedError (info :: o) (op :: AttrOpTag) (methodName :: Symbol) :: ErrorMessage where
OpNotProvidedError info op methodName =
'Text "The attribute ‘" ':<>: 'Text (AttrLabel info) ':<>:
'Text "’ for type ‘" ':<>:
'ShowType (AttrOrigin info) ':<>:
'Text "’ is declared as " ':<>:
'Text (AttrOpText op) ':<>:
'Text ", but no implementation of ‘" ':<>:
'Text methodName ':<>:
'Text "’ has been provided."
':$$: 'Text "Either provide an implementation of ‘" ':<>:
'Text methodName ':<>:
'Text "’ or remove ‘" ':<>:
'ShowType op ':<>:
'Text "’ from ‘AttrAllowedOps’."
type family ClearNotProvidedError (info :: o) :: ErrorMessage where
ClearNotProvidedError info = OpNotProvidedError info 'AttrClear "attrClear"
type family GetNotProvidedError (info :: o) :: ErrorMessage where
GetNotProvidedError info = OpNotProvidedError info 'AttrGet "attrGet"
type family SetNotProvidedError (info :: o) :: ErrorMessage where
SetNotProvidedError info = OpNotProvidedError info 'AttrSet "attrSet"
type family ConstructNotProvidedError (info :: o) :: ErrorMessage where
ConstructNotProvidedError info = OpNotProvidedError info 'AttrConstruct "attrConstruct"
type family CheckNotElem (a :: k) (as :: [k]) (msg :: ErrorMessage) :: Constraint where
CheckNotElem a '[] msg = ()
CheckNotElem a (a ': rest) msg = TypeError msg
CheckNotElem a (other ': rest) msg = CheckNotElem a rest msg
data AttrOpTag = AttrGet
| AttrSet
| AttrConstruct
| AttrClear
deriving (Eq, Ord, Enum, Bounded, Show)
type family AttrOpText (tag :: AttrOpTag) :: Symbol where
AttrOpText 'AttrGet = "gettable"
AttrOpText 'AttrSet = "settable"
AttrOpText 'AttrConstruct = "constructible"
AttrOpText 'AttrClear = "nullable"
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
(:&=) :: (HasAttributeList obj,
info ~ ResolveAttribute attr obj,
AttrInfo info,
AttrBaseTypeConstraint info obj,
AttrOpAllowed tag info obj,
(AttrTransferTypeConstraint info) b,
AttrSetTypeConstraint info (AttrTransferType info)) =>
AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag
On :: (GObject obj, SignalInfo info) =>
SignalProxy obj info -> HaskellCallbackType info -> AttrOp obj tag
set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m ()
set obj = liftIO . mapM_ app
where
app :: AttrOp o 'AttrSet -> IO ()
app ((_attr :: AttrLabelProxy label) := x) =
attrSet @(ResolveAttribute label o) obj x
app ((_attr :: AttrLabelProxy label) :=> x) =
x >>= attrSet @(ResolveAttribute label o) obj
app ((_attr :: AttrLabelProxy label) :~ f) =
attrGet @(ResolveAttribute label o) obj >>=
\v -> attrSet @(ResolveAttribute label o) obj (f v)
app ((_attr :: AttrLabelProxy label) :~> f) =
attrGet @(ResolveAttribute label o) obj >>= f >>=
attrSet @(ResolveAttribute label o) obj
app ((_attr :: AttrLabelProxy label) :&= x) =
attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>=
attrSet @(ResolveAttribute label o) obj
app (On signal callback) = void $ on obj signal callback
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 o _ = liftIO $ attrGet @info 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 o _ = liftIO $ attrClear @info o