[Haskell-cafe] type variable in class instance

[Corentin Dupont]

I finally come up with this version, which allows to do pattern matching
against the events.
I'm sure it could be cleaned a bit, but it think the idea is there.
I would like to thank again everybody on this list, that's very friendly
and helpful!
Corentin

*{-# LANGUAGE ExistentialQuantification, TypeFamilies, DeriveDataTypeable,
GADTs, ScopedTypeVariables, StandaloneDeriving #-}

import Data.Typeable

data Player = Arrive | Leave deriving (Show, Typeable, Eq)
data Message m = Message String deriving (Show, Typeable, Eq)

data Event a where
  PlayerEvent  :: Player -> Event Player
  MessageEvent :: Message m -> Event (Message m)

data Data a where
  PlayerData  :: Int -> Data (Event Player)
  MessageData :: m -> Data (Event (Message m))

data Handler where
  Handler :: (Typeable e) => Event e -> (Data (Event e) -> IO ()) -> Handler

deriving instance Eq (Event a)
deriving instance Typeable1 Data
deriving instance Typeable1 Event

addEvent :: (Typeable e) => Event e -> (Data (Event e) -> IO ()) ->
[Handler] -> [Handler]
addEvent e h hs = (Handler e h) : hs

triggerEvent :: (Eq e, Typeable e) => Event e -> (Data (Event e)) ->
[Handler] -> IO ()
triggerEvent e d hs = do
    let filtered = filter (\(Handler e1 _) -> e1 === e) hs
    mapM_ f filtered where
        f (Handler _ h) = case cast h of
            Just castedH -> do
                castedH d
            Nothing -> return ()

viewEvent :: (Typeable e) => (Event e) -> IO()
viewEvent (PlayerEvent p) = putStrLn $ "Player " ++ show p
viewEvent m@(MessageEvent s) = putStrLn $ "Message " ++ show s ++ " of type
" ++ (show $ typeOf m)

-- | an equality that tests also the types.
(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool
(===) x y = cast x == Just y

--TEST
testPlayer = addEvent (PlayerEvent Arrive) (\(PlayerData d) -> putStrLn $
show d) []
msg :: Message Int
msg = Message "give me a number"
myList = addEvent (MessageEvent msg) (\(MessageData n) -> putStrLn $ "Your
number is: " ++ show n) []
trigger = triggerEvent (MessageEvent msg) (MessageData 1) myList --Yelds
"Your number is: 1"*


On Tue, Sep 11, 2012 at 5:06 PM, Corentin Dupont
<corentin.dupont at gmail.com>wrote:

> Yes.
> That's fantastic! This GADT is the missing piece of my puzzle. I
> transformed a bit your solution, polluting it with some classes instances
> and fleshing the functions:
>
> *data Player = Arrive | Leave deriving (Show, Typeable, Eq)
> data Message m = Message String deriving (Show, Typeable, Eq)
>
>
> data Data a where
>   PlayerData  :: Int -> Data Player
>   MessageData :: m -> Data (Message m)
>
> data Handler where
>   Handler :: (Typeable e) => e -> (Data e -> IO ()) -> Handler
>
> instance forall e. (Typeable e) => Typeable (Data e) where
>     typeOf _  = mkTyConApp (mkTyCon( ("Expression.EventData (" ++ (show $
> typeOf (undefined::e))) ++ ")" )) []
>
> addEvent :: (Typeable e) => e -> (Data e -> IO ()) -> [Handler] ->
> [Handler]
> addEvent e h hs = (Handler e h) : hs
>
> triggerEvent :: (Eq e, Typeable e) => e -> Data e -> [Handler] -> IO ()
> triggerEvent e d hs = do
>     let filtered = filter (\(Handler e1 _) -> e1 === e) hs
>     mapM_ f filtered where
>         f (Handler _ h) = case cast h of
>             Just castedH -> do
>                 castedH d
>             Nothing -> return ()
>
> viewEvent :: (Typeable e) => e -> IO()
>
> viewEvent event = do
>     case cast event of
>         Just (a :: Player) -> putStrLn $ "Player" ++ show a
>
>         Nothing -> return ()
>     case cast event of
>         (Just (Message s)) -> putStrLn $ "Player" ++ s
>         Nothing -> return ()*
>
>
> Unfortunately, I still cannot pattern match on the events to view them (*viewEvent
> won't compile)*...
>
> Best,
> Corentin
>
>
>
> On Tue, Sep 11, 2012 at 4:10 PM, Sean Leather <leather at cs.uu.nl> wrote:
>
>> On Tue, Sep 11, 2012 at 3:39 PM, Corentin Dupontwrote:
>>
>> @Oleg: Yes the set of events is closed and I would be much happier with a
>>> GADT! But no matter how hard I tried I couldn't manage.
>>> Here is the full problem:
>>>
>>> *{-# LANGUAGE ExistentialQuantification, TypeFamilies,
>>> DeriveDataTypeable #-}
>>>
>>> import Data.Typeable
>>>
>>> -- | Define the events and their related data
>>> class (Eq e, Typeable e, Show e) => Event e where
>>>     data EventData e
>>>
>>> -- | Groups of events
>>> data PlayerEvent = Arrive | Leave deriving (Typeable, Show, Eq)
>>>
>>> -- | events types
>>> data Player          = Player PlayerEvent deriving (Typeable, Show, Eq)
>>> data Message m  = Message String     deriving (Typeable, Show, Eq)
>>>
>>> -- | event instances
>>> instance Event Player                                      where data
>>> EventData Player             = PlayerData {playerData :: Int}
>>> instance (Typeable m) => Event (Message m)   where data EventData
>>> (Message m)   = MessageData {messageData :: m}
>>>
>>> -- | structure to store an event
>>> data EventHandler = forall e . (Event e) =>
>>>      EH {eventNumber :: Int,
>>>          event :: e,
>>>          handler :: (EventData e) -> IO ()} deriving Typeable
>>>
>>> -- store a new event with its handler in the list
>>> addEvent :: (Event e) => e -> (EventData e -> IO ()) -> [EventHandler]
>>> -> [EventHandler]
>>> addEvent event handler ehs = undefined
>>>
>>> -- trigger all the corresponding events in the list, passing the **data
>>> to the handlers
>>> triggerEvent :: (Event e) => e -> (EventData e) -> [EventHandler] -> IO
>>> ()
>>> triggerEvent event edata ehs = undefined
>>>
>>> --Examples:
>>> msg :: Message Int
>>> msg = Message "give me a number"
>>> myList = addEvent msg (\(MessageData n) -> putStrLn $ "Your number is: "
>>> ++ show n) []
>>> trigger = triggerEvent msg (MessageData 1) **myList --Yelds "Your
>>> number is: 1"*
>>>
>>> Has you can see this allows me to associate an arbitrary data type to
>>> each event with the type family "EventData". Furthermore some events like
>>> "Message" let the user choose the data type using the type parameter. This
>>> way I have nice signatures for the functions "addEvent" and "triggerEvent".
>>> The right types for the handlers and the data passed is enforced at
>>> compilation time.
>>> But I couldn't find any way to convert this into a GATD and get rid of
>>> the "Event" class......
>>>
>>
>> Would this work?
>>
>> data Player = Arrive | Leave
>>  data Message m = Message String
>>
>> data Data a where
>>   PlayerData  :: Int -> Data Player
>>   MessageData :: m -> Data (Message m)
>>
>> data Handler where
>>   Handler :: Int -> e -> (Data e -> IO ()) -> Handler
>>
>> addEvent :: e -> (Data e -> IO ()) -> [Handler] -> [Handler]
>> addEvent = undefined
>>
>> triggerEvent :: e -> Data e -> [Handler] -> IO ()
>> triggerEvent = undefined
>>
>> Regards,
>> Sean
>>
>
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/haskell-cafe/attachments/20120911/947e3192/attachment.htm>