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.dup...@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 <leat...@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
>>
>
>
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
