-- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./Graphics/X11/XInput/Parser.chs" #-}{-# LANGUAGE TypeFamilies #-}
{-| Functions of this module perform parsing of XInput events structures. -}
module Graphics.X11.XInput.Parser where


import Control.Applicative
import Control.Monad
import qualified Data.Map as M
import Data.Bits
import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Text.Printf
import qualified Graphics.X11 as X11
import qualified Graphics.X11.Xlib.Extras as E

import Graphics.X11.XInput.Types

class Struct a where
  type Pointer a
  peekStruct :: Pointer a -> IO a

peekClasses :: Int -> Ptr a -> IO [GDeviceClass]
peekClasses n ptr = do
  let ptr' = castPtr ptr :: Ptr GDeviceClassPtr
  classesPtrs <- peekArray (fromIntegral n) ptr'
  forM classesPtrs (peekStruct . castPtr)

checkByte :: CUChar -> [Int]
checkByte x = [i | i <- [0..7], x .&. (1 `shiftL` i) /= 0]

parseMask :: Mask -> [Int]
parseMask [] = []
parseMask [x] = checkByte x
parseMask list =
    let x  = last list
        xs = init list
    in  map (+ 8) (checkByte x) ++ parseMask xs

peekMask :: (Ptr a -> IO CInt) -> (Ptr a -> IO (Ptr CUChar)) -> Ptr a -> IO [Int]
peekMask getLength getMask ptr = do
  len <- trace "maskLen" $ getLength ptr
  maskPtr <- trace "maskPtr" $ getMask ptr
  mask <- trace "mask" $ peekArray (fromIntegral len) maskPtr
  return $ parseMask mask

packMask :: [Int] -> X11.KeyMask
packMask list = foldr (.|.) 0 $ map (1 `shiftL`) list

instance Struct DeviceInfo where
  type Pointer DeviceInfo = DeviceInfoPtr

  peekStruct ptr = do
    id <- (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
    namePtr <- (\ptr -> do {peekByteOff ptr 4 ::IO (Ptr CChar)}) ptr
    name <- peekCString namePtr
    use <- int2deviceType <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
    att <- (\ptr -> do {peekByteOff ptr 12 ::IO CInt}) ptr
    on <- toBool <$> (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) ptr
    ncls <- fromIntegral <$> (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) ptr
    clsptr <- (\ptr -> do {peekByteOff ptr 24 ::IO (Ptr (Ptr ()))}) ptr
    classes <- peekClasses ncls clsptr
    return $ DeviceInfo id name use att on classes

instance Struct GDeviceClass where
  type Pointer GDeviceClass = GDeviceClassPtr

  peekStruct ptr = do
    tp <- (toEnum . fromIntegral) <$> (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
    src <- (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) ptr
    cls <- case tp of
             XIButtonClass   -> peekButtonClass ptr
             XIKeyClass      -> peekKeyClass ptr
             XIValuatorClass -> peekValuatorClass ptr
    return $ GDeviceClass tp (fromIntegral src) cls

instance Struct ButtonState where
  type Pointer ButtonState = GDeviceClassPtr

  peekStruct ptr = ButtonState
    <$> peekMask ((\ptr -> do {peekByteOff ptr 16 ::IO CInt}))
                 ((\ptr -> do {peekByteOff ptr 20 ::IO (Ptr CUChar)}))
                 ptr

peekButtonClass :: GDeviceClassPtr -> IO DeviceClass
peekButtonClass ptr = do
  n <- (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
  labelsPtr <- (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr CULong)}) ptr
  labels <- peekArray (fromIntegral n) labelsPtr
  st <- peekStruct ptr
  return $ ButtonClass (fromIntegral n) (map fromIntegral labels) st

peekKeyClass :: GDeviceClassPtr -> IO DeviceClass
peekKeyClass ptr = do
  n <- (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
  kptr <- (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr CInt)}) ptr
  keycodes <- peekArray (fromIntegral n) kptr
  return $ KeyClass (fromIntegral n) (map fromIntegral keycodes)

peekValuatorClass :: GDeviceClassPtr -> IO DeviceClass
peekValuatorClass ptr = ValuatorClass 
  <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 12 ::IO CULong}) ptr)
  <*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 16 ::IO CDouble}) ptr)
  <*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 24 ::IO CDouble}) ptr)
  <*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 32 ::IO CDouble}) ptr)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CInt}) ptr)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 44 ::IO CInt}) ptr)

instance Struct Int where
  type Pointer Int = Ptr CInt
  peekStruct x = fromIntegral <$> peek x

get_event_type :: X11.XEventPtr -> IO X11.EventType
get_event_type ptr = fromIntegral <$> (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr

get_event_extension :: X11.XEventPtr -> IO Opcode
get_event_extension ptr = (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) ptr

instance Struct EventCookie where
  type Pointer EventCookie = EventCookiePtr

  peekStruct xev = do
    ev     <- E.getEvent (castPtr xev)
    ext    <- (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) xev
    et     <- (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) xev
    cookie <- (\ptr -> do {peekByteOff ptr 24 ::IO CUInt}) xev
    dptr  <- (\ptr -> do {peekByteOff ptr 28 ::IO (Ptr ())})   xev
    cdata <- peekStruct (castPtr dptr)

    return $ EventCookie {
               ecEvent  = ev,
               ecExtension = ext,
               ecType   = int2eventType et,
               ecCookie = cookie,
               ecData   = cdata }

getXGenericEventCookie :: X11.XEventPtr -> IO EventCookie
getXGenericEventCookie = peekStruct . castPtr

instance Struct Event where
  type Pointer Event = EventPtr

  peekStruct de = do 
    se <- toBool <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) de
    dpy <- ptr2display <$> (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr ())}) de
    ext <- (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) de
    evt <- int2eventType <$> (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) de
    dev <- (\ptr -> do {peekByteOff ptr 28 ::IO CInt})  de
    spec <- peekEventSpecific evt de
    return $ Event se dpy ext evt dev spec


peekEventSpecific XI_PropertyEvent e = PropertyEvent
  <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 32 ::IO CULong}) e)
  <*> (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e

peekEventSpecific XI_DeviceChanged e = do
  reason <- (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e
  ncls   <- (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CInt}) e)
  clsPtr <- (\ptr -> do {peekByteOff ptr 44 ::IO (Ptr (Ptr ()))}) e
  classes <- peekClasses ncls clsPtr
  return $ DeviceChangedEvent reason classes

peekEventSpecific t e = GPointerEvent
  <$> (\ptr -> do {peekByteOff ptr 32 ::IO CInt}) e
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CULong})   e)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 44 ::IO CULong})  e)
  <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 48 ::IO CULong})  e)
  <*> (\ptr -> do {peekByteOff ptr 52 ::IO CDouble})  e
  <*> (\ptr -> do {peekByteOff ptr 60 ::IO CDouble})  e
  <*> (\ptr -> do {peekByteOff ptr 68 ::IO CDouble}) e
  <*> (\ptr -> do {peekByteOff ptr 76 ::IO CDouble}) e
  <*> trace "pointerEvent" (peekPointerEvent t e)

trace :: Show a => String -> IO a -> IO a
trace _ x = x
-- trace prefix action = do
--   result <- action
--   putStrLn $ prefix ++ ": " ++ show result
--   return result

peekPointerEvent XI_Enter e = EnterLeaveEvent
  <$> (\ptr -> do {peekByteOff ptr 84 ::IO CInt}) e
  <*> (toBool <$> (\ptr -> do {peekByteOff ptr 88 ::IO CInt}) e)
  <*> (toBool <$> (\ptr -> do {peekByteOff ptr 92 ::IO CInt}) e)
  <*> (ButtonState <$>
        (peekMask ((\ptr -> do {peekByteOff ptr 96 ::IO CInt}))
                  ((\ptr -> do {peekByteOff ptr 100 ::IO (Ptr CUChar)}))
                  e ) )
  <*> (ModifierState
        <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 104 ::IO CInt})      e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 108 ::IO CInt})   e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 112 ::IO CInt})    e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 116 ::IO CInt}) e))
  <*> (ModifierState
        <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 120 ::IO CInt})      e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 124 ::IO CInt})   e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 128 ::IO CInt})    e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 132 ::IO CInt}) e))

peekPointerEvent XI_Leave e = peekPointerEvent XI_Enter e

peekPointerEvent XI_RawKeyPress e = peekRawEvent XI_RawKeyPress e

peekPointerEvent XI_RawKeyRelease e = peekRawEvent XI_RawKeyRelease e

peekPointerEvent t e = DeviceEvent
  <$> trace "event type" (return t)
  <*> trace "flags" ((\ptr -> do {peekByteOff ptr 84 ::IO CInt}) e)
  <*> trace "buttons" (ButtonState <$>
        (peekMask ((\ptr -> do {peekByteOff ptr 88 ::IO CInt}))
                  ((\ptr -> do {peekByteOff ptr 92 ::IO (Ptr CUChar)}))
                  e ) )
  <*> trace "valuators" (do
        mask <- trace "mask" $ peekMask ((\ptr -> do {peekByteOff ptr 96 ::IO CInt}))
                         ((\ptr -> do {peekByteOff ptr 100 ::IO (Ptr CUChar)}))
                         e
        valuesPtr <- trace "valuesPtr" $ (\ptr -> do {peekByteOff ptr 104 ::IO (Ptr CDouble)}) e
        values <- trace "values" $ peekArray (length mask) valuesPtr :: IO [CDouble]
        let values' = map realToFrac values :: [Double]
        return $ M.fromList $ zip mask values' )
  <*> trace "mods" (ModifierState
        <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 108 ::IO CInt})      e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 112 ::IO CInt})   e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 116 ::IO CInt})    e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 120 ::IO CInt}) e))
  <*> trace "group" (ModifierState
        <$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 124 ::IO CInt})      e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 128 ::IO CInt})   e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 132 ::IO CInt})    e)
        <*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 136 ::IO CInt}) e))


peekRawEvent t e = RawEvent
  <$> trace "event type" (return t)
  <*> trace "flags" ((\ptr -> do {peekByteOff ptr 40 ::IO CInt}) e)
  <*> trace "valuators" (do
        mask <- trace "mask" $ peekMask ((\ptr -> do {peekByteOff ptr 44 ::IO CInt}))
                         ((\ptr -> do {peekByteOff ptr 48 ::IO (Ptr CUChar)}))
                         e
        valuesPtr <- trace "valuesPtr" $ (\ptr -> do {peekByteOff ptr 52 ::IO (Ptr CDouble)}) e
        values <- trace "values" $ peekArray (length mask) valuesPtr :: IO [CDouble]
        let values' = map realToFrac values :: [Double]
        return $ M.fromList $ zip mask values' )