{-# LANGUAGE ExistentialQuantification #-}

-- |
-- Module     : Wayland.Server.Types
-- Description: Primitive types shared among other modules.

module Wayland.Server.Types
  ( -- * Messages
    MessageClass
  , Message(..)
  , fromMessage
  , -- * Handles
    Handle
  , createHandle
  , resolveHandle
  , invalidateHandle
  ) where

import System.Mem.StableName (StableName, makeStableName)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Hashable (Hashable(..))
import Data.Typeable (Typeable, cast)

-- | A message that is dispatched on the display's message loop.
class (Typeable m, Show m) => MessageClass m

-- | A type-erased message processed on the display's message loop.
data Message = forall m. MessageClass m => Message m

-- | A handle to a native pointer.
--
-- The handle remains valid and can be used for equality checks even after the underlying pointer was destroyed. This is
-- realized using an IORef which is set to nullPtr once the object is destroyed. The IORef itself is used for equality
-- checks.
data Handle ptr
  = Handle { hndName    :: StableName (IORef (Maybe ptr)) -- ^ Name used for hashing and ordering.
           , hndPointer :: IORef (Maybe ptr)              -- ^ Reference to the underlying pointer.
           }

instance Eq (Handle ptr) where
  a == b = hndPointer a == hndPointer b

instance Ord (Handle ptr) where
  a <= b = hash (hndName a) <= hash (hndName b)

instance Hashable (Handle ptr) where
  hashWithSalt s o = hashWithSalt s (hndName o)

instance Show (Handle ptr) where
  show o = "Handle " ++ show (hash (hndName o))

instance Show Message where
  show (Message m) = show m

-- | Try to cast a type-erased message into a concrete 'MessageClass'.
fromMessage :: MessageClass m => Message -> Maybe m
fromMessage (Message x) = cast x

-- | Create a handle wrapping a pointer.
--
-- This should only be called once for the underlying resource to ensure equality.
createHandle :: ptr -> IO (Handle ptr)
createHandle p = do
  ptrRef <- newIORef $ Just p
  name <- makeStableName ptrRef
  return $ Handle { hndName = name
                  , hndPointer = ptrRef
                  }

-- | Get the underlying pointer for a handle.
--
-- This function may raise an error if the handle was invalidated.
resolveHandle :: Handle ptr -> IO ptr
resolveHandle h = check <$> readIORef (hndPointer h)
  where check (Just p) = p
        check Nothing  = error "Invalid object handle."

-- | Invalidate the handle, making all further requests to 'resolveHandle' fail.
--
-- The handle itself will still remain valid and can be used to check for equality.
invalidateHandle :: Handle ptr -> IO ()
invalidateHandle h = writeIORef (hndPointer h) Nothing