module Text.XkbCommon.InternalTypes
( Context, CContext, InternalContext, toContext, fromContext, withContext,
ContextFlags(..), defaultFlags,
pureFlags, contextNoDefaultIncludes, contextNoEnvironment,
Keymap, CKeymap, InternalKeymap, toKeymap, fromKeymap, withKeymap, RMLVO(..), noPrefs,
KeyboardState, CKeyboardState, toKeyboardState, fromKeyboardState, withKeyboardState,
readCString,
Direction(..), keyUp, keyDown,
CKeysym(..), Keysym(..), toKeysym, fromKeysym, safeToKeysym,
CLogLevel(..), CKeycode(..), CLayoutIndex(..), CModIndex(..), CLevelIndex(..),
CLedIndex(..), StateComponent(..), CModMask(..),
stateModDepressed, stateModLatched, stateModLocked, stateModEffective,
stateLayoutDepressed, stateLayoutLatched, stateLayoutLocked,
stateLayoutEffective, stateLeds,
) where
import Foreign
import Foreign.C
import Foreign.Storable
import Control.Monad (ap, liftM)
import qualified Foreign.Storable.Newtype as Store
import Data.Flags
import Data.Flags.TH
data Context = Context InternalContext
data CContext
type InternalContext = ForeignPtr CContext
toContext :: InternalContext -> Context
toContext = Context
fromContext :: Context -> InternalContext
fromContext (Context ic) = ic
withContext :: Context -> (Ptr CContext -> IO a) -> IO a
withContext = withForeignPtr . fromContext
data Keymap = Keymap InternalKeymap
data CKeymap
type InternalKeymap = ForeignPtr CKeymap
toKeymap :: InternalKeymap -> Keymap
toKeymap = Keymap
fromKeymap :: Keymap -> InternalKeymap
fromKeymap (Keymap km) = km
withKeymap :: Keymap -> (Ptr CKeymap -> IO a) -> IO a
withKeymap = withForeignPtr . fromKeymap
data RMLVO = RMLVO {rules, model, layout, variant, options :: Maybe String}
noPrefs = RMLVO { rules = Nothing
, model = Nothing
, layout = Nothing
, variant = Nothing
, options = Nothing
}
wrapCString :: CString -> IO (Maybe String)
wrapCString x = if x == nullPtr
then return Nothing
else do
k <- peekCString x
return $ Just k
wrapString :: Maybe String -> IO CString
wrapString Nothing = return nullPtr
wrapString (Just str) = newCString str
instance Storable RMLVO where
sizeOf _ = (40)
alignment _ = alignment (undefined :: CInt)
poke p rmlvo = do
wrapString (rules rmlvo) >>= (\hsc_ptr -> pokeByteOff hsc_ptr 0) p
wrapString (model rmlvo) >>= (\hsc_ptr -> pokeByteOff hsc_ptr 8) p
wrapString (layout rmlvo) >>= (\hsc_ptr -> pokeByteOff hsc_ptr 16) p
wrapString (variant rmlvo) >>= (\hsc_ptr -> pokeByteOff hsc_ptr 24) p
wrapString (options rmlvo) >>= (\hsc_ptr -> pokeByteOff hsc_ptr 32) p
peek p = return RMLVO
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p >>= wrapCString)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 8) p >>= wrapCString)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 16) p >>= wrapCString)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 24) p >>= wrapCString)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 32) p >>= wrapCString)
data KeyboardState = KeyboardState InternalKeyboardState
data CKeyboardState
type InternalKeyboardState = ForeignPtr CKeyboardState
toKeyboardState :: InternalKeyboardState -> KeyboardState
toKeyboardState = KeyboardState
fromKeyboardState :: KeyboardState -> InternalKeyboardState
fromKeyboardState (KeyboardState st) = st
withKeyboardState :: KeyboardState -> (Ptr CKeyboardState -> IO a) -> IO a
withKeyboardState = withForeignPtr . fromKeyboardState
readCString :: CString -> IO String
readCString cstr = do
str <- peekCString cstr
free cstr
return str
newtype CKeysym = CKeysym {unCKeysym :: Word32} deriving (Show, Eq)
instance Storable CKeysym where
sizeOf = Store.sizeOf unCKeysym
alignment = Store.alignment unCKeysym
peek = Store.peek CKeysym
poke = Store.poke unCKeysym
newtype Keysym = Keysym Int deriving (Show, Eq)
fromKeysym :: Keysym -> CKeysym
fromKeysym (Keysym k) = CKeysym (fromIntegral k)
toKeysym :: CKeysym -> Keysym
toKeysym (CKeysym 0) = error "Keysym must be nonzero!"
toKeysym (CKeysym k) = Keysym (fromIntegral k)
safeToKeysym :: CKeysym -> Maybe Keysym
safeToKeysym (CKeysym 0) = Nothing
safeToKeysym (CKeysym n) = Just (Keysym (fromIntegral n))
newtype CKeycode = CKeycode {unCKeycode :: Word32} deriving (Show, Eq)
instance Storable CKeycode where
sizeOf = Store.sizeOf unCKeycode
alignment = Store.alignment unCKeycode
peek = Store.peek CKeycode
poke = Store.poke unCKeycode
newtype ContextFlags = ContextFlags Word32
deriving (Eq, Flags)
$(liftM (tail.init) $ bitmaskWrapper "ContextFlags" ''Word32 []
[("contextNoEnvironment", 2),
("contextNoDefaultIncludes", 1)])
defaultFlags = noFlags :: ContextFlags
pureFlags = contextNoEnvironment .+. contextNoDefaultIncludes
newtype Direction = Direction Word32
keyUp :: Direction
keyUp = Direction 0
keyDown :: Direction
keyDown = Direction 1
newtype CLayoutIndex = CLayoutIndex Word32
newtype CLedIndex = CLedIndex {unCLedIndex :: Word32} deriving (Show, Eq)
newtype CLevelIndex = CLevelIndex Word32
newtype CLogLevel = CLogLevel Word32
newtype CModIndex = CModIndex {unCModIndex :: Word32} deriving (Show, Eq)
instance Storable CModIndex where
sizeOf = Store.sizeOf unCModIndex
alignment = Store.alignment unCModIndex
peek = Store.peek CModIndex
poke = Store.poke unCModIndex
newtype CModMask = CModMask Word32 deriving(Eq, Num, Show)
newtype StateComponent = StateComponent Word32
deriving (Eq, Flags, BoundedFlags)
stateModDepressed :: StateComponent
stateModDepressed = StateComponent 1
stateModLatched :: StateComponent
stateModLatched = StateComponent 2
stateModLocked :: StateComponent
stateModLocked = StateComponent 4
stateModEffective :: StateComponent
stateModEffective = StateComponent 8
stateLayoutDepressed :: StateComponent
stateLayoutDepressed = StateComponent 16
stateLayoutLatched :: StateComponent
stateLayoutLatched = StateComponent 32
stateLayoutLocked :: StateComponent
stateLayoutLocked = StateComponent 64
stateLayoutEffective :: StateComponent
stateLayoutEffective = StateComponent 128
stateLeds :: StateComponent
stateLeds = StateComponent 256