[Haskell-cafe] Re: Read Instance code.

[Andy Stewart]

Ivan Lazar Miljenovic <ivan.miljenovic at gmail.com> writes:

> Andy Stewart <lazycat.manatee at gmail.com> writes:
>
>> Hi all,
>>
>> I have some incorrect "Read instance" make i got error "Prelude.read: no
>> parse", and i don't know how to fix it. 
>>
>>
>> newtype SerializedWindow = SerializedWindow (Maybe DrawWindow)
>>     
>> instance Show SerializedWindow where    
>>   show _ = "SerializedWindow Nothing"
>>            
>> instance Read SerializedWindow where           
>>     readsPrec _ str = [(SerializedWindow Nothing, idStr) 
>>                            | (val :: String, idStr) <- reads str]
>
> Try using Derive or DrIFT to generate a proto-typical instance for you,
> and then hack that and make it neater.  If you don't care about
> cross-compiler compatability, using ReadP rather than ReadS also results
> in nicer parsing code.
Sorry, i haven't explain my situation.

I'm try to serialized/derserialized Gtk+ Event C struct over the network.

Since DrawWindow is ForeignPtr to point C structure, and "deriving Read"
nothing help.

So i want build a "bogus value" -- "SerializedWindow Nothing" to fill
DrawWindow pointer field. 

I just want got "SerializedWindow Nothing" and don't care the value
that return by *reads*.

Below are C struct that i want to serialized with Haskell data-type:
typedef struct {
  GdkEventType type;
  GdkWindow *window;
  gint8 send_event;
  guint32 time;
  guint state;
  guint keyval;
  gint length;
  gchar *string;
  guint16 hardware_keycode;
  guint8 group;
  guint is_modifier : 1;
} GdkEventKey;

Below are my C binding that explain my purpose:

------------------------------> C binding start <------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
-- -*-haskell-*-

#include <gtk/gtk.h>
#include "template-hsc-gtk2hs.h"

--  GIMP Toolkit (GTK) GDK Serializabled Event
--
--  Author : Andy Stewart
--
--  Created: 01 Jul 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users\@lists.sourceforge.net
-- Stability   : deprecated
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.Gdk.SerializedEvent (
-- * Types                                            
    SerializedEventKey (..),
    
-- * Methods    
    serializedEvent,
    deserializeEventKey,                   
) where
  
import Control.Monad.Reader (ReaderT, ask, runReaderT )
import Control.Monad.Trans (liftIO)
import Data.Maybe
import Data.Ord
import Graphics.UI.Gtk.Gdk.DrawWindow
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.Gdk.Keys (KeyVal)
import Graphics.UI.GtkInternals
import System.Glib.FFI
import System.Glib.Flags
    
data SerializedEventKey =   
    SerializedEventKey {sEventType      :: Int
                       ,sEventWindow    :: SerializedWindow
                       ,sEventSent      :: Bool
                       ,sEventTime      :: Word32
                       ,sEventState     :: Int
                       ,sEventKeyval    :: KeyVal
                       ,sEventLength    :: Int
                       ,sEventString    :: String
                       ,sEventKeycode   :: Word16
                       ,sEventGroup     :: Word8
                       ,sEventIsModifier:: Int}
    deriving (Show, Eq, Ord, Read)
                       
newtype SerializedWindow = SerializedWindow (Maybe DrawWindow)
    
instance Eq SerializedWindow where           
  (==) _ _ = True
         
instance Ord SerializedWindow where         
  compare _ _ = EQ
           
instance Show SerializedWindow where    
  show _ = "SerializedWindow Nothing"
           
instance Read SerializedWindow where           
    readsPrec _ str = [(SerializedWindow Nothing, idStr) 
                           | (val :: String, idStr) <- reads str]
                      
instance Storable SerializedEventKey where
    sizeOf _ = #{const sizeof (GdkEventKey)}
    alignment _ = alignment (undefined:: #gtk2hs_type gint)
    peek ptr = peekSerializedKey ptr
    poke ptr event = pokeSerializedKey ptr event    

serializedEvent :: EventM t SerializedEventKey
serializedEvent = do
  ptr <- ask
  eType <- liftIO $ do
    (typ::#gtk2hs_type GdkEventType) <- #{peek GdkEventAny,type} ptr
    return typ
  case eType of
     #{const GDK_KEY_PRESS}	-> serializedKey
     #{const GDK_KEY_RELEASE}	-> serializedKey
     ty                         -> error ("serializedEvent: haven't handle event type " ++ show ty)
                
serializedKey :: EventM t SerializedEventKey
serializedKey = do
  ptr <- ask
  liftIO $ peekSerializedKey ptr
    
peekSerializedKey ptr = do
    (typ_         ::#gtk2hs_type GdkEventType)    <- #{peek GdkEventKey, type} ptr
    (sent_        ::#gtk2hs_type gint8)           <- #{peek GdkEventKey, send_event} ptr
    (time_        ::#gtk2hs_type guint32)         <- #{peek GdkEventKey, time} ptr
    (state_       ::#gtk2hs_type guint)           <- #{peek GdkEventKey, state} ptr
    (keyval_      ::#gtk2hs_type guint)           <- #{peek GdkEventKey, keyval} ptr
    (length_      ::#gtk2hs_type gint)            <- #{peek GdkEventKey, length} ptr
    (keycode_     ::#gtk2hs_type guint16)         <- #{peek GdkEventKey, hardware_keycode} ptr
    (group_       ::#gtk2hs_type guint8)          <- #{peek GdkEventKey, group} ptr
    -- (isModifier_  ::#gtk2hs_type guint)           <- #{peek GdkEventKey, is_modifier} ptr
    return $ SerializedEventKey
               {sEventType        = fromIntegral typ_
               ,sEventWindow      = SerializedWindow Nothing -- this field need synthesize at client side
               ,sEventSent        = toBool sent_
               ,sEventTime        = fromIntegral time_ -- this field need synthesize at client side
               ,sEventState       = fromIntegral state_
               ,sEventKeyval      = keyval_
               ,sEventLength      = fromIntegral length_
               ,sEventString      = "" -- this filed has deprecated and should never be used
               ,sEventKeycode     = keycode_
               ,sEventGroup       = group_
               -- ,sEventIsModifier  = isModifier_
               ,sEventIsModifier  = 0
               }
    
pokeSerializedKey ptr (SerializedEventKey
                       {sEventType        = typ_
                       ,sEventWindow      = SerializedWindow window_
                       ,sEventSent        = sent_
                       ,sEventTime        = time_
                       ,sEventState       = state_
                       ,sEventKeyval      = keyval_
                       ,sEventLength      = length_
                       ,sEventString      = string_
                       ,sEventKeycode     = keycode_
                       ,sEventGroup       = group_
                       ,sEventIsModifier  = isModifier_
                       }) = do
  #{poke GdkEventKey, type}             ptr ((fromIntegral typ_)        ::#gtk2hs_type GdkEventType)
  case (fromMaybe (DrawWindow nullForeignPtr) window_) of
    win_ -> withForeignPtr (unDrawWindow win_) $ \winPtr -> 
                   #{poke GdkEventKey, window} ptr winPtr
  #{poke GdkEventKey, send_event}       ptr ((fromBool sent_)           ::#gtk2hs_type gint8)
  #{poke GdkEventKey, time}             ptr ((fromIntegral time_)       ::#gtk2hs_type guint32)
  #{poke GdkEventKey, state}            ptr ((fromIntegral state_)      ::#gtk2hs_type guint)
  #{poke GdkEventKey, keyval}           ptr (keyval_                    ::#gtk2hs_type guint)   
  #{poke GdkEventKey, length}           ptr ((fromIntegral length_)     ::#gtk2hs_type gint)
  #{poke GdkEventKey, hardware_keycode} ptr (keycode_                   ::#gtk2hs_type guint16)
  #{poke GdkEventKey, group}            ptr (group_                     ::#gtk2hs_type guint8)
  
-- | Insert DrawWindow and TimeStamp field when deserialized SerializedEventKey.
deserializeEventKey :: SerializedEventKey -> DrawWindow -> (EventM t a) -> IO a
deserializeEventKey event drawWindow fun = do
  -- We need use *client* value replace field of event.
  let newEvent = event {sEventWindow    = SerializedWindow $ Just drawWindow
                       ,sEventTime      = currentTime}
  with newEvent $ \eventPtr -> runReaderT fun (castPtr eventPtr)
------------------------------> C binding end   <------------------------------

  -- Andy