{-# LANGUAGE KindSignatures, TypeFamilies, DataKinds, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, EmptyDataDecls, CPP #-}
#ifndef OVERLAPPING_INSTANCES_DEPRECATED
{-# LANGUAGE OverlappingInstances #-}
#endif
#ifdef CUSTOM_TYPE_ERRORS
{-# LANGUAGE TypeOperators #-}
#endif
module Graphics.UI.FLTK.LowLevel.Dispatch
(
FindOp,
Functions,
Match,
NoFunction,
Op,
dispatch,
runOp,
castTo,
safeCast,
Parent
)
where
import Graphics.UI.FLTK.LowLevel.Fl_Types
#ifdef CUSTOM_TYPE_ERRORS
import GHC.TypeLits
#endif
data Same
data Different
data Match a
data NoFunction a b
type family Contains as a where
Contains () (x ()) = Different
Contains (a as) (a ()) = Same
Contains (a as) (b ()) = Contains as (b ())
type family FindOpHelper orig hierarchy (needle :: *) (found :: *) :: * where
FindOpHelper orig hierarchy needle Same = Match hierarchy
FindOpHelper orig (child ancestors) needle Different = FindOp orig ancestors needle
type family FindOp orig hierarchy (needle :: *) :: * where
#ifdef CUSTOM_TYPE_ERRORS
FindOp (w ws) () (n ()) = TypeError (
('ShowType n)
':<>:
('Text " is not supported by ")
':<>:
('ShowType w)
':<>:
('ShowType (Functions ws))
)
#else
FindOp orig () n = NoFunction n orig
#endif
FindOp orig hierarchy needle = FindOpHelper orig hierarchy needle (Contains (Functions hierarchy) needle)
data InHierarchy
#ifndef CUSTOM_TYPE_ERRORS
data NotInHierarchy a b
#endif
type family FindInHierarchy (needle :: * ) (curr :: *) (haystack :: *) :: * where
#ifdef CUSTOM_TYPE_ERRORS
FindInHierarchy (n ns) () (a as) = TypeError (
('ShowType n)
':<>:
('Text " is not a kind of ")
':<>:
('ShowType a)
)
#else
FindInHierarchy needle () (a as) = NotInHierarchy needle (a as)
#endif
FindInHierarchy needle (a as) (a as) = InHierarchy
FindInHierarchy needle (a as) (b bs) = FindInHierarchy needle as (b bs)
class Parent a b
instance (InHierarchy ~ FindInHierarchy a a b) => Parent a b
type family Functions (x :: *) :: *
class Op op obj origObj impl where
runOp :: op -> origObj -> (Ref obj) -> impl
castTo :: Ref a -> Ref r
castTo (Ref x) = (Ref x)
safeCast :: (Parent a r) => Ref a -> Ref r
safeCast (Ref x) = Ref x
dispatch :: forall op obj origObj impl.
(
Match obj ~ FindOp origObj origObj op,
Op op obj origObj impl
) =>
op -> Ref origObj -> impl
dispatch op refOrig = runOp op (undefined :: origObj) ((castTo refOrig) :: Ref obj)