    {-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds,
                 TypeFamilies, UndecidableInstances, EmptyDataDecls,
                 MultiParamTypeClasses, FlexibleInstances, ConstraintKinds,
                 AllowAmbiguousTypes, FlexibleContexts, ScopedTypeVariables,
                 TypeApplications, OverloadedStrings #-}

    -- | Helpers for dealing with overladed properties, signals and
    -- methods.

    module Data.GI.Base.Overloading
        ( -- * Type level inheritance
          ParentTypes
        , HasParentTypes
        , IsDescendantOf

        , asA

        -- * Looking up attributes in parent types
        , AttributeList
        , HasAttributeList
        , ResolveAttribute
        , HasAttribute
        , HasAttr

        -- * Looking up signals in parent types
        , SignalList
        , ResolveSignal
        , HasSignal

        -- * Looking up methods in parent types
        , MethodResolutionFailed
        , UnsupportedMethodError
        , OverloadedMethodInfo(..)
        , OverloadedMethod(..)
        , MethodProxy(..)

        , ResolvedSymbolInfo(..)
        , resolveMethod
        ) where

    import Data.Coerce (coerce)
    import Data.Kind (Type)

    import GHC.Exts (Constraint)
    import GHC.TypeLits

    import Data.GI.Base.BasicTypes (ManagedPtrNewtype, ManagedPtr(..))

    import Data.Text (Text)
    import qualified Data.Text as T

    -- | Look in the given list of (symbol, tag) tuples for the tag
    -- corresponding to the given symbol. If not found raise the given
    -- type error.
    type family FindElement (m :: Symbol) (ms :: [(Symbol, Type)])
        (typeError :: ErrorMessage) :: Type where
        FindElement m '[] typeError = TypeError typeError
        FindElement m ('(m, o) ': ms) typeError = o
        FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError

    -- | All the types that are ascendants of this type, including
    -- interfaces that the type implements.
    type family ParentTypes a :: [Type]

    -- | A constraint on a type, to be fulfilled whenever it has a type
    -- instance for `ParentTypes`. This leads to nicer errors, thanks to
    -- the overlappable instance below.
    class HasParentTypes (o :: Type)

    -- | Default instance, which will give rise to an error for types
    -- without an associated `ParentTypes` instance.
    instance {-# OVERLAPPABLE #-}
        TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:
                   'Text "’ does not have any known parent types.")
        => HasParentTypes a

    -- | Check whether a type appears in a list. We specialize the
    -- names/types a bit so the error messages are more informative.
    type family CheckForAncestorType t (a :: Type) (as :: [Type]) :: Constraint where
      CheckForAncestorType t a '[] = TypeError ('Text "Required ancestor ‘"
                                                ':<>: 'ShowType a
                                                ':<>: 'Text "’ not found for type ‘"
                                                ':<>: 'ShowType t ':<>: 'Text "’.")
      CheckForAncestorType t a (a ': as) = ()
      CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as

    -- | Check that a type is in the list of `ParentTypes` of another
    -- type.
    type family IsDescendantOf (parent :: Type) (descendant :: Type) :: Constraint where
        -- Every object is defined to be a descendant of itself.
        IsDescendantOf d d = ()
        IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d)

    -- | Safe coercions to a parent class. For instance:
    --
    -- > #show $ label `asA` Gtk.Widget
    --
    asA :: (ManagedPtrNewtype a, ManagedPtrNewtype b,
            HasParentTypes b, IsDescendantOf a b)
        => b -> (ManagedPtr a -> a) -> a
    asA :: forall a b.
    (ManagedPtrNewtype a, ManagedPtrNewtype b, HasParentTypes b,
     IsDescendantOf a b) =>
    b -> (ManagedPtr a -> a) -> a
    asA b
    obj ManagedPtr a -> a
    _constructor = b -> a
    forall a b. Coercible a b => a -> b
    coerce b
    obj

    -- | The list of attributes defined for a given type. Each element of
    -- the list is a tuple, with the first element of the tuple the name
    -- of the attribute, and the second the type encoding the information
    -- of the attribute. This type will be an instance of
    -- `Data.GI.Base.Attributes.AttrInfo`.
    type family AttributeList a :: [(Symbol, Type)]

    -- | A constraint on a type, to be fulfilled whenever it has a type
    -- instance for `AttributeList`. This is here for nicer error
    -- reporting.
    class HasAttributeList a

    -- | Default instance, which will give rise to an error for types
    -- without an associated `AttributeList`.
    instance {-# OVERLAPPABLE #-}
        TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:
                   'Text "’ does not have any known attributes.")
        => HasAttributeList a

    -- | Return the type encoding the attribute information for a given
    -- type and attribute.
    type family ResolveAttribute (s :: Symbol) (o :: Type) :: Type where
        ResolveAttribute s o = FindElement s (AttributeList o)
                               ('Text "Unknown attribute ‘" ':<>:
                                'Text s ':<>: 'Text "’ for object ‘" ':<>:
                                'ShowType o ':<>: 'Text "’.")

    -- | Whether a given type is in the given list. If found, return
    -- @success@, otherwise return @failure@.
    type family IsElem (e :: Symbol) (es :: [(Symbol, Type)]) (success :: k)
        (failure :: ErrorMessage) :: k where
        IsElem e '[] success failure = TypeError failure
        IsElem e ( '(e, t) ': es) success failure = success
        IsElem e ( '(other, t) ': es) s f = IsElem e es s f

    -- | A constraint imposing that the given object has the given attribute.
    type family HasAttribute (attr :: Symbol) (o :: Type) :: Constraint where
        HasAttribute attr o = IsElem attr (AttributeList o)
                              (() :: Constraint) -- success
                              ('Text "Attribute ‘" ':<>: 'Text attr ':<>:
                               'Text "’ not found for type ‘" ':<>:
                               'ShowType o ':<>: 'Text "’.")

    -- | A constraint that enforces that the given type has a given attribute.
    class HasAttr (attr :: Symbol) (o :: Type)
    instance HasAttribute attr o => HasAttr attr o

    -- | The list of signals defined for a given type. Each element of the
    -- list is a tuple, with the first element of the tuple the name of
    -- the signal, and the second the type encoding the information of the
    -- signal. This type will be an instance of
    -- `Data.GI.Base.Signals.SignalInfo`.
    type family SignalList a :: [(Symbol, Type)]

    -- | Return the type encoding the signal information for a given
    -- type and signal.
    type family ResolveSignal (s :: Symbol) (o :: Type) :: Type where
        ResolveSignal s o = FindElement s (SignalList o)
                            ('Text "Unknown signal ‘" ':<>:
                             'Text s ':<>: 'Text "’ for object ‘" ':<>:
                             'ShowType o ':<>: 'Text "’.")

    -- | A constraint enforcing that the signal exists for the given
    -- object, or one of its ancestors.
    type family HasSignal (s :: Symbol) (o :: Type) :: Constraint where
        HasSignal s o = IsElem s (SignalList o)
                        (() :: Constraint) -- success
                        ('Text "Signal ‘" ':<>: 'Text s ':<>:
                         'Text "’ not found for type ‘" ':<>:
                         'ShowType o ':<>: 'Text "’.")

    -- | A constraint that always fails with a type error, for
    -- documentation purposes.
    type family UnsupportedMethodError (s :: Symbol) (o :: Type) :: Type where
      UnsupportedMethodError s o =
        TypeError ('Text "Unsupported method ‘" ':<>:
                   'Text s ':<>: 'Text "’ for object ‘" ':<>:
                   'ShowType o ':<>: 'Text "’.")

    -- | Returned when the method is not found, hopefully making
    -- the resulting error messages somewhat clearer.
    type family MethodResolutionFailed (method :: Symbol) (o :: Type) where
        MethodResolutionFailed m o =
            TypeError ('Text "Unknown method ‘" ':<>:
                       'Text m ':<>: 'Text "’ for type ‘" ':<>:
                       'ShowType o ':<>: 'Text "’.")

    -- | Class for types containing the information about an overloaded
    -- method of type @o -> s@.
    class OverloadedMethod i o s where
      overloadedMethod :: o -> s -- ^ The actual method being invoked.

    -- | Information about a fully resolved symbol, for debugging
    -- purposes.
    data ResolvedSymbolInfo = ResolvedSymbolInfo {
      ResolvedSymbolInfo -> Text
    resolvedSymbolName      :: Text
      , ResolvedSymbolInfo -> Text
    resolvedSymbolURL     :: Text
      }

    instance Show ResolvedSymbolInfo where
      -- Format as a hyperlink on modern terminals (older
      -- terminals should ignore the hyperlink part).
      show :: ResolvedSymbolInfo -> String
    show ResolvedSymbolInfo
    info = Text -> String
    T.unpack (Text
    "\ESC]8;;" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> ResolvedSymbolInfo -> Text
    resolvedSymbolURL ResolvedSymbolInfo
    info
                             Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\ESC\\" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> ResolvedSymbolInfo -> Text
    resolvedSymbolName ResolvedSymbolInfo
    info
                             Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\ESC]8;;\ESC\\")

    -- | This is for debugging purposes, see `resolveMethod` below.
    class OverloadedMethodInfo i o where
      overloadedMethodInfo :: Maybe ResolvedSymbolInfo

    -- | A proxy for carrying the types `MethodInfoName` needs (this is used
    -- for `resolveMethod`, see below).
    data MethodProxy (info :: Type) (obj :: Type) = MethodProxy

    -- | Return the fully qualified method name that a given overloaded
    -- method call resolves to (mostly useful for debugging).
    --
    -- > resolveMethod widget #show
    resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) =>
                     obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo
    resolveMethod :: forall info obj.
    OverloadedMethodInfo info obj =>
    obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo
    resolveMethod obj
    _o MethodProxy info obj
    _p = forall i o. OverloadedMethodInfo i o => Maybe ResolvedSymbolInfo
    forall {k} {k} (i :: k) (o :: k).
    OverloadedMethodInfo i o =>
    Maybe ResolvedSymbolInfo
    overloadedMethodInfo @info @obj