Fix SourceStyleSchemeManager docs.

Fix SourceStyleSchemeManager docs.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceStyleSchemeManager (
-- * Types
  SourceStyleSchemeManager,
  SourceStyleSchemeManagerClass,

-- * Methods
  sourceStyleSchemeManagerNew,
  sourceStyleSchemeManagerGetDefault,
  sourceStyleSchemeManagerSetSearchPath,
  sourceStyleSchemeManagerAppendSearchPath,
  sourceStyleSchemeManagerPrependSearchPath,
  sourceStyleSchemeManagerGetSearchPath,
  sourceStyleSchemeManagerGetSchemeIds,
  sourceStyleSchemeManagerGetScheme,
  sourceStyleSchemeManagerForceRescan,

-- * Attributes
  sourceStyleSchemeManagerStyleIds,
  sourceStyleSchemeManagerSearchPath
  ) where

{# context lib="gtk" prefix="gtk" #}

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject (constructNewGObject, makeNewGObject)
import System.Glib.UTFString
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

-- | Creates a new style manager. If you do not need more than one style manager then use
-- 'sourceStyleSchemeManagerGetDefault' instead.
--
sourceStyleSchemeManagerNew :: IO SourceStyleSchemeManager
sourceStyleSchemeManagerNew = constructNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_new#}

-- | Returns the default 'SourceStyleSchemeManager' instance.
--
sourceStyleSchemeManagerGetDefault :: IO SourceStyleSchemeManager -- ^ returns a 'SourceStyleSchemeManager'. Return value is owned by 'SourceView' library and must not be unref'ed.
sourceStyleSchemeManagerGetDefault = makeNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_get_default#}

-- | Sets the list of directories where the manager looks for style scheme files. If dirs is 'Nothing', the
-- search path is reset to default.
--
sourceStyleSchemeManagerSetSearchPath :: SourceStyleSchemeManager -> Maybe [String] -> IO ()
sourceStyleSchemeManagerSetSearchPath ssm dirs =
  maybeWith withUTFStringArray0 dirs $ \dirsPtr -> do
    {#call unsafe source_style_scheme_manager_set_search_path#} ssm dirsPtr

-- | Appends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerAppendSearchPath :: SourceStyleSchemeManager
                                         -> String  -- ^ @path@    a directory or a filename.
                                         -> IO ()
sourceStyleSchemeManagerAppendSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_append_search_path#} ssm

-- | Prepends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerPrependSearchPath :: SourceStyleSchemeManager
                                          -> String  -- ^ @path@    a directory or a filename.
                                          -> IO ()
sourceStyleSchemeManagerPrependSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_prepend_search_path#} ssm

-- | Returns the current search path for the manager. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerGetSearchPath :: SourceStyleSchemeManager
                                      -> IO [String]
sourceStyleSchemeManagerGetSearchPath ssm = do
  dirsPtr <- {#call unsafe source_style_scheme_manager_get_search_path#} ssm
  peekUTFStringArray0 dirsPtr

-- | Returns the ids of the available style schemes.
--
sourceStyleSchemeManagerGetSchemeIds :: SourceStyleSchemeManager -> IO [String]
sourceStyleSchemeManagerGetSchemeIds ssm = do
  idsPtr <- {#call unsafe source_style_scheme_manager_get_scheme_ids#} ssm
  liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 idsPtr

-- | Looks up style scheme by id.
--
sourceStyleSchemeManagerGetScheme :: SourceStyleSchemeManager
                                  -> String  -- ^ @schemeId@ style scheme id to find
                                  -> IO SourceStyleScheme
sourceStyleSchemeManagerGetScheme ssm id = makeNewGObject mkSourceStyleScheme $
  withUTFString id $ {#call unsafe source_style_scheme_manager_get_scheme#} ssm

-- | Mark any currently cached information about the available style scehems as invalid. All the
-- available style schemes will be reloaded next time the manager is accessed.
--
sourceStyleSchemeManagerForceRescan :: SourceStyleSchemeManager -> IO ()
sourceStyleSchemeManagerForceRescan =
  {#call unsafe source_style_scheme_manager_force_rescan#}

-- | List of the ids of the available style schemes.
--
sourceStyleSchemeManagerStyleIds :: ReadAttr SourceStyleSchemeManager [String]
sourceStyleSchemeManagerStyleIds =
  readAttrFromBoxedOpaqueProperty (liftM (fromMaybe []) . maybePeek peekUTFStringArray0 . castPtr)
                                  "style-ids" {#call pure g_strv_get_type#}

-- | List of directories and files where the style schemes are located.
--
sourceStyleSchemeManagerSearchPath :: ReadWriteAttr SourceStyleSchemeManager [String] (Maybe [String])
sourceStyleSchemeManagerSearchPath =
  newAttr (objectGetPropertyBoxedOpaque (peekUTFStringArray0 . castPtr) gtype "search-path")
          (objectSetPropertyBoxedOpaque (\dirs f -> maybeWith withUTFStringArray0 dirs (f . castPtr)) gtype "search-path")
  where gtype = {#call pure g_strv_get_type#}

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceStyleSchemeManager (
  SourceStyleSchemeManager,
  SourceStyleSchemeManagerClass,
  sourceStyleSchemeManagerNew,
  sourceStyleSchemeManagerGetDefault,
  sourceStyleSchemeManagerSetSearchPath,
  sourceStyleSchemeManagerAppendSearchPath,
  sourceStyleSchemeManagerPrependSearchPath,
  sourceStyleSchemeManagerGetSearchPath,
  sourceStyleSchemeManagerGetSchemeIds,
  sourceStyleSchemeManagerGetScheme,
  sourceStyleSchemeManagerForceRescan,
  sourceStyleSchemeManagerStyleIds,
  sourceStyleSchemeManagerSearchPath
  ) where

{# context lib="gtk" prefix="gtk" #}

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject (constructNewGObject, makeNewGObject)
import System.Glib.UTFString
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

-- |
--
sourceStyleSchemeManagerNew :: IO SourceStyleSchemeManager
sourceStyleSchemeManagerNew = constructNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_new#}

-- |
--
sourceStyleSchemeManagerGetDefault :: IO SourceStyleSchemeManager
sourceStyleSchemeManagerGetDefault = makeNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_get_default#}

-- |
--
sourceStyleSchemeManagerSetSearchPath :: SourceStyleSchemeManager -> Maybe [String] -> IO ()
sourceStyleSchemeManagerSetSearchPath ssm dirs =
  maybeWith withUTFStringArray0 dirs $ \dirsPtr -> do
    {#call unsafe source_style_scheme_manager_set_search_path#} ssm dirsPtr

-- |
--
sourceStyleSchemeManagerAppendSearchPath :: SourceStyleSchemeManager -> String -> IO ()
sourceStyleSchemeManagerAppendSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_append_search_path#} ssm

-- |
--
sourceStyleSchemeManagerPrependSearchPath :: SourceStyleSchemeManager -> String -> IO ()
sourceStyleSchemeManagerPrependSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_prepend_search_path#} ssm

-- |
--
sourceStyleSchemeManagerGetSearchPath :: SourceStyleSchemeManager -> IO [String]
sourceStyleSchemeManagerGetSearchPath ssm = do
  dirsPtr <- {#call unsafe source_style_scheme_manager_get_search_path#} ssm
  peekUTFStringArray0 dirsPtr

-- |
--
sourceStyleSchemeManagerGetSchemeIds :: SourceStyleSchemeManager -> IO [String]
sourceStyleSchemeManagerGetSchemeIds ssm = do
  idsPtr <- {#call unsafe source_style_scheme_manager_get_scheme_ids#} ssm
  liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 idsPtr

-- |
--
sourceStyleSchemeManagerGetScheme :: SourceStyleSchemeManager -> String -> IO SourceStyleScheme
sourceStyleSchemeManagerGetScheme ssm id = makeNewGObject mkSourceStyleScheme $
  withUTFString id $ {#call unsafe source_style_scheme_manager_get_scheme#} ssm

-- |
--
sourceStyleSchemeManagerForceRescan :: SourceStyleSchemeManager -> IO ()
sourceStyleSchemeManagerForceRescan =
  {#call unsafe source_style_scheme_manager_force_rescan#}

-- |
--
sourceStyleSchemeManagerStyleIds :: ReadAttr SourceStyleSchemeManager [String]
sourceStyleSchemeManagerStyleIds =
  readAttrFromBoxedOpaqueProperty (liftM (fromMaybe []) . maybePeek peekUTFStringArray0 . castPtr)
                                  "style-ids" {#call pure g_strv_get_type#}

-- |
--
sourceStyleSchemeManagerSearchPath :: ReadWriteAttr SourceStyleSchemeManager [String] (Maybe [String])
sourceStyleSchemeManagerSearchPath =
  newAttr (objectGetPropertyBoxedOpaque (peekUTFStringArray0 . castPtr) gtype "search-path")
          (objectSetPropertyBoxedOpaque (\dirs f -> maybeWith withUTFStringArray0 dirs (f . castPtr)) gtype "search-path")
  where gtype = {#call pure g_strv_get_type#}


Use SourceStyleSchemeManagerClass replace SourceStyleSchemeManager as function argument.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceStyleSchemeManager (
-- * Types
  SourceStyleSchemeManager,
  SourceStyleSchemeManagerClass,

-- * Methods
  sourceStyleSchemeManagerNew,
  sourceStyleSchemeManagerGetDefault,
  sourceStyleSchemeManagerSetSearchPath,
  sourceStyleSchemeManagerAppendSearchPath,
  sourceStyleSchemeManagerPrependSearchPath,
  sourceStyleSchemeManagerGetSearchPath,
  sourceStyleSchemeManagerGetSchemeIds,
  sourceStyleSchemeManagerGetScheme,
  sourceStyleSchemeManagerForceRescan,

-- * Attributes
  sourceStyleSchemeManagerStyleIds,
  sourceStyleSchemeManagerSearchPath
  ) where

{# context lib="gtk" prefix="gtk" #}

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject (constructNewGObject, makeNewGObject)
import System.Glib.UTFString
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

-- | Creates a new style manager. If you do not need more than one style manager then use
-- 'sourceStyleSchemeManagerGetDefault' instead.
--
sourceStyleSchemeManagerNew :: IO SourceStyleSchemeManager
sourceStyleSchemeManagerNew = constructNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_new#}

-- | Returns the default 'SourceStyleSchemeManager' instance.
--
sourceStyleSchemeManagerGetDefault :: IO SourceStyleSchemeManager -- ^ returns a 'SourceStyleSchemeManager'. Return value is owned by 'SourceView' library and must not be unref'ed.
sourceStyleSchemeManagerGetDefault = makeNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_get_default#}

-- | Sets the list of directories where the manager looks for style scheme files. If dirs is 'Nothing', the
-- search path is reset to default.
--
sourceStyleSchemeManagerSetSearchPath :: SourceStyleSchemeManagerClass sssm => sssm -> Maybe [String] -> IO ()
sourceStyleSchemeManagerSetSearchPath ssm dirs =
  maybeWith withUTFStringArray0 dirs $ \dirsPtr -> do
    {#call unsafe source_style_scheme_manager_set_search_path#} (toSourceStyleSchemeManager ssm) dirsPtr

-- | Appends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerAppendSearchPath :: SourceStyleSchemeManagerClass sssm => sssm
                                         -> String  -- ^ @path@    a directory or a filename.
                                         -> IO ()
sourceStyleSchemeManagerAppendSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_append_search_path#} (toSourceStyleSchemeManager ssm)

-- | Prepends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerPrependSearchPath :: SourceStyleSchemeManagerClass sssm => sssm
                                          -> String  -- ^ @path@    a directory or a filename.
                                          -> IO ()
sourceStyleSchemeManagerPrependSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_prepend_search_path#} (toSourceStyleSchemeManager ssm)

-- | Returns the current search path for the manager. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerGetSearchPath :: SourceStyleSchemeManagerClass sssm => sssm
                                      -> IO [String]
sourceStyleSchemeManagerGetSearchPath ssm = do
  dirsPtr <- {#call unsafe source_style_scheme_manager_get_search_path#} (toSourceStyleSchemeManager ssm)
  peekUTFStringArray0 dirsPtr

-- | Returns the ids of the available style schemes.
--
sourceStyleSchemeManagerGetSchemeIds :: SourceStyleSchemeManagerClass sssm => sssm -> IO [String]
sourceStyleSchemeManagerGetSchemeIds ssm = do
  idsPtr <- {#call unsafe source_style_scheme_manager_get_scheme_ids#} (toSourceStyleSchemeManager ssm)
  liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 idsPtr

-- | Looks up style scheme by id.
--
sourceStyleSchemeManagerGetScheme :: SourceStyleSchemeManagerClass sssm => sssm
                                  -> String  -- ^ @schemeId@ style scheme id to find
                                  -> IO SourceStyleScheme
sourceStyleSchemeManagerGetScheme ssm id = makeNewGObject mkSourceStyleScheme $
  withUTFString id $ {#call unsafe source_style_scheme_manager_get_scheme#} (toSourceStyleSchemeManager ssm)

-- | Mark any currently cached information about the available style scehems as invalid. All the
-- available style schemes will be reloaded next time the manager is accessed.
--
sourceStyleSchemeManagerForceRescan :: SourceStyleSchemeManagerClass sssm => sssm -> IO ()
sourceStyleSchemeManagerForceRescan ssm =
  {#call unsafe source_style_scheme_manager_force_rescan#} (toSourceStyleSchemeManager ssm)

-- | List of the ids of the available style schemes.
--
sourceStyleSchemeManagerStyleIds :: SourceStyleSchemeManagerClass sssm => ReadAttr sssm [String]
sourceStyleSchemeManagerStyleIds =
  readAttrFromBoxedOpaqueProperty (liftM (fromMaybe []) . maybePeek peekUTFStringArray0 . castPtr)
                                  "style-ids" {#call pure g_strv_get_type#}

-- | List of directories and files where the style schemes are located.
--
sourceStyleSchemeManagerSearchPath :: SourceStyleSchemeManagerClass sssm => ReadWriteAttr sssm [String] (Maybe [String])
sourceStyleSchemeManagerSearchPath =
  newAttr (objectGetPropertyBoxedOpaque (peekUTFStringArray0 . castPtr) gtype "search-path")
          (objectSetPropertyBoxedOpaque (\dirs f -> maybeWith withUTFStringArray0 dirs (f . castPtr)) gtype "search-path")
  where gtype = {#call pure g_strv_get_type#}

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceStyleSchemeManager (
-- * Types
  SourceStyleSchemeManager,
  SourceStyleSchemeManagerClass,

-- * Methods
  sourceStyleSchemeManagerNew,
  sourceStyleSchemeManagerGetDefault,
  sourceStyleSchemeManagerSetSearchPath,
  sourceStyleSchemeManagerAppendSearchPath,
  sourceStyleSchemeManagerPrependSearchPath,
  sourceStyleSchemeManagerGetSearchPath,
  sourceStyleSchemeManagerGetSchemeIds,
  sourceStyleSchemeManagerGetScheme,
  sourceStyleSchemeManagerForceRescan,

-- * Attributes
  sourceStyleSchemeManagerStyleIds,
  sourceStyleSchemeManagerSearchPath
  ) where

{# context lib="gtk" prefix="gtk" #}

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject (constructNewGObject, makeNewGObject)
import System.Glib.UTFString
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

-- | Creates a new style manager. If you do not need more than one style manager then use
-- 'sourceStyleSchemeManagerGetDefault' instead.
--
sourceStyleSchemeManagerNew :: IO SourceStyleSchemeManager
sourceStyleSchemeManagerNew = constructNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_new#}

-- | Returns the default 'SourceStyleSchemeManager' instance.
--
sourceStyleSchemeManagerGetDefault :: IO SourceStyleSchemeManager -- ^ returns a 'SourceStyleSchemeManager'. Return value is owned by 'SourceView' library and must not be unref'ed.
sourceStyleSchemeManagerGetDefault = makeNewGObject mkSourceStyleSchemeManager $ liftM castPtr
  {#call unsafe source_style_scheme_manager_get_default#}

-- | Sets the list of directories where the manager looks for style scheme files. If dirs is 'Nothing', the
-- search path is reset to default.
--
sourceStyleSchemeManagerSetSearchPath :: SourceStyleSchemeManager -> Maybe [String] -> IO ()
sourceStyleSchemeManagerSetSearchPath ssm dirs =
  maybeWith withUTFStringArray0 dirs $ \dirsPtr -> do
    {#call unsafe source_style_scheme_manager_set_search_path#} ssm dirsPtr

-- | Appends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerAppendSearchPath :: SourceStyleSchemeManager
                                         -> String  -- ^ @path@    a directory or a filename.
                                         -> IO ()
sourceStyleSchemeManagerAppendSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_append_search_path#} ssm

-- | Prepends path to the list of directories where the manager looks for style scheme files. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerPrependSearchPath :: SourceStyleSchemeManager
                                          -> String  -- ^ @path@    a directory or a filename.
                                          -> IO ()
sourceStyleSchemeManagerPrependSearchPath ssm dir =
  withUTFString dir $ {#call unsafe source_style_scheme_manager_prepend_search_path#} ssm

-- | Returns the current search path for the manager. See
-- 'sourceStyleSchemeManagerSetSearchPath' for details.
--
sourceStyleSchemeManagerGetSearchPath :: SourceStyleSchemeManager
                                      -> IO [String]
sourceStyleSchemeManagerGetSearchPath ssm = do
  dirsPtr <- {#call unsafe source_style_scheme_manager_get_search_path#} ssm
  peekUTFStringArray0 dirsPtr

-- | Returns the ids of the available style schemes.
--
sourceStyleSchemeManagerGetSchemeIds :: SourceStyleSchemeManager -> IO [String]
sourceStyleSchemeManagerGetSchemeIds ssm = do
  idsPtr <- {#call unsafe source_style_scheme_manager_get_scheme_ids#} ssm
  liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 idsPtr

-- | Looks up style scheme by id.
--
sourceStyleSchemeManagerGetScheme :: SourceStyleSchemeManager
                                  -> String  -- ^ @schemeId@ style scheme id to find
                                  -> IO SourceStyleScheme
sourceStyleSchemeManagerGetScheme ssm id = makeNewGObject mkSourceStyleScheme $
  withUTFString id $ {#call unsafe source_style_scheme_manager_get_scheme#} ssm

-- | Mark any currently cached information about the available style scehems as invalid. All the
-- available style schemes will be reloaded next time the manager is accessed.
--
sourceStyleSchemeManagerForceRescan :: SourceStyleSchemeManager -> IO ()
sourceStyleSchemeManagerForceRescan =
  {#call unsafe source_style_scheme_manager_force_rescan#}

-- | List of the ids of the available style schemes.
--
sourceStyleSchemeManagerStyleIds :: ReadAttr SourceStyleSchemeManager [String]
sourceStyleSchemeManagerStyleIds =
  readAttrFromBoxedOpaqueProperty (liftM (fromMaybe []) . maybePeek peekUTFStringArray0 . castPtr)
                                  "style-ids" {#call pure g_strv_get_type#}

-- | List of directories and files where the style schemes are located.
--
sourceStyleSchemeManagerSearchPath :: ReadWriteAttr SourceStyleSchemeManager [String] (Maybe [String])
sourceStyleSchemeManagerSearchPath =
  newAttr (objectGetPropertyBoxedOpaque (peekUTFStringArray0 . castPtr) gtype "search-path")
          (objectSetPropertyBoxedOpaque (\dirs f -> maybeWith withUTFStringArray0 dirs (f . castPtr)) gtype "search-path")
  where gtype = {#call pure g_strv_get_type#}


Removed redundant util

Removed redundant util

{-# LANGUAGE CPP, MagicHash, TupleSections #-}
module Network.Bluetooth.Utils
  ( allocaLen
  , byteSwap32
  , cToEnum
  , cFromEnum
  , getFromIntegral
  , getRealToFrac
  , setFromIntegral
  , setRealToFrac
  , peekFromIntegral
  , peekRealToFrac
  , throwSocketErrorIf
  , throwSocketErrorIfNull
  , throwSocketErrorIfNull_
  , unsafePeek
  , unsafePeekFromIntegral
  , unsafePeekRealToFrac
  , with'
  , withCast
  , withCastArray
  , withCastArray0
  , withCastArrayLen
  , withCastArrayLen0
  , withCastLen
  , withCastLenConv
  , withFunWrapper
  , withLen
  , withLenConv
  ) where

import           Control.Monad

import qualified Data.Word as W
import           Data.Word (Word32)

import           Foreign.C.Types hiding (CSize)
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

#if __GLASGOW_HASKELL__ < 708
import           GHC.Prim
import           GHC.Word
#endif

import           Network.Socket.Internal

import           System.IO.Unsafe

#include <stddef.h>

-- | Remove this when <https://github.com/haskell/c2hs/issues/20 this issue> is resolved
type CSize = {#type size_t #}

allocaLen :: Storable a => (Int -> Ptr a -> IO b) -> IO b
allocaLen = doAllocaLen undefined
  where
    doAllocaLen :: Storable a => a -> (Int -> Ptr a -> IO b) -> IO b
    doAllocaLen dummy f = alloca . f $ sizeOf dummy

byteSwap32 :: Word32 -> Word32
#if __GLASGOW_HASKELL__ >= 708
byteSwap32 = W.byteSwap32
#else
byteSwap32 (W32# w#) = W32# (narrow32Word# (byteSwap32# w#))
#endif

-- TODO: Rename this to something more sensible.
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum = toEnum . fromIntegral

-- TODO: Rename this to something more sensible.
cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum = fromIntegral . fromEnum

getFromIntegral :: (Integral i, Num n) => (Ptr a -> IO i) -> Ptr a -> IO n
getFromIntegral getter = fmap fromIntegral . getter

getRealToFrac :: (Real r, Fractional f) => (Ptr a -> IO r) -> Ptr a -> IO f
getRealToFrac getter = fmap realToFrac . getter

setFromIntegral :: (Integral i, Num n) => (Ptr a -> n -> IO ()) -> Ptr a -> i -> IO ()
setFromIntegral setter ptr = setter ptr . fromIntegral

setRealToFrac :: (Real r, Fractional f) => (Ptr a -> f -> IO ()) -> Ptr a -> r -> IO ()
setRealToFrac setter ptr = setter ptr . realToFrac

peekFromIntegral :: (Integral a, Storable a, Num b) => Ptr a -> IO b
peekFromIntegral = fmap fromIntegral . peek

peekRealToFrac :: (Real a, Storable a, Fractional b) => Ptr a -> IO b
peekRealToFrac = fmap realToFrac . peek

throwSocketErrorIf :: (a -> Bool) -> String -> IO a -> IO a
throwSocketErrorIf p name act = do
    r <- act
    if p r
       then throwSocketError name
       else return r

throwSocketErrorIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwSocketErrorIfNull = throwSocketErrorIf (== nullPtr)

throwSocketErrorIfNull_ :: String -> IO (Ptr a) -> IO ()
throwSocketErrorIfNull_ name = void . throwSocketErrorIfNull name

unsafePeek :: Storable a => Ptr a -> a
unsafePeek = unsafePerformIO . peek

unsafePeekFromIntegral :: (Integral a, Storable a, Num b) => Ptr a -> b
unsafePeekFromIntegral = fromIntegral . unsafePeek

unsafePeekRealToFrac :: (Real a, Storable a, Fractional b) => Ptr a -> b
unsafePeekRealToFrac = realToFrac . unsafePeek

-- | Synonym for 'with' to avoid c2hs issues.
--   See <https://github.com/haskell/c2hs/issues/93 this issue>.
with' :: Storable s => s -> (Ptr s -> IO a) -> IO a
with' = with

withCast :: Storable s1 => s1 -> (Ptr s2 -> IO a) -> IO a
withCast val f = with val $ f . castPtr

withCastArray :: Storable s1 => [s1] -> (Ptr s2 -> IO a) -> IO a
withCastArray vals = withCastArrayLen vals . const

withCastArrayLen :: Storable s1 => [s1] -> (Int -> Ptr s2 -> IO a) -> IO a
withCastArrayLen vals f = withArrayLen vals $ \len -> f len . castPtr

withCastArray0 :: Storable s1 => s1 -> [s1] -> (Ptr s2 -> IO a) -> IO a
withCastArray0 marker vals = withCastArrayLen0 marker vals . const

withCastArrayLen0 :: Storable s1 => s1 -> [s1] -> (Int -> Ptr s2 -> IO a) -> IO a
withCastArrayLen0 marker vals f = withArrayLen0 marker vals $ \len -> f len . castPtr

withCastLen :: Storable s1 => s1 -> ((Ptr s2, CSize) -> IO a) -> IO a
withCastLen val f = withLen val $ f . mapFst castPtr

withCastLenConv :: (Num n, Storable s1) => s1 -> ((Ptr s2, n) -> IO a) -> IO a
withCastLenConv val f = withCastLen val $ f . mapSnd fromIntegral

withFunWrapper :: (a -> IO (FunPtr a)) -> a -> (FunPtr a -> IO b) -> IO b
withFunWrapper wrapper hFun f = do
    funPtr <- wrapper hFun
    res <- f funPtr
    freeHaskellFunPtr funPtr
    return res

withLen :: Storable a => a -> ((Ptr a, CSize) -> IO b) -> IO b
withLen val f = with val $ f . (, fromIntegral $ sizeOf val)

withLenConv :: (Num n, Storable s) => s -> ((Ptr s, n) -> IO a) -> IO a
withLenConv val f = withLen val $ f . mapSnd fromIntegral

-------------------------------------------------------------------------------

mapFst :: (a1 -> a2) -> (a1, b) -> (a2, b)
mapFst f (x, y) = (f x, y)

mapSnd :: (b1 -> b2) -> (a, b1) -> (a, b2)
mapSnd = fmap

{-# LANGUAGE CPP, MagicHash, TupleSections #-}
module Network.Bluetooth.Utils
  ( allocaLen
  , byteSwap32
  , cToEnum
  , cFromEnum
  , getFromIntegral
  , getRealToFrac
  , setFromIntegral
  , setRealToFrac
  , peekFromIntegral
  , peekRealToFrac
  , throwSocketErrorIf
  , throwSocketErrorIfMinus1Retry_
  , throwSocketErrorIfNull
  , throwSocketErrorIfNull_
  , unsafePeek
  , unsafePeekFromIntegral
  , unsafePeekRealToFrac
  , with'
  , withCast
  , withCastArray
  , withCastArray0
  , withCastArrayLen
  , withCastArrayLen0
  , withCastLen
  , withCastLenConv
  , withFunWrapper
  , withLen
  , withLenConv
  ) where

import           Control.Monad

import qualified Data.Word as W
import           Data.Word (Word32)

import           Foreign.C.Types hiding (CSize)
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

#if __GLASGOW_HASKELL__ < 708
import           GHC.Prim
import           GHC.Word
#endif

import           Network.Socket.Internal

import           System.IO.Unsafe

#include <stddef.h>

-- | Remove this when <https://github.com/haskell/c2hs/issues/20 this issue> is resolved
type CSize = {#type size_t #}

allocaLen :: Storable a => (Int -> Ptr a -> IO b) -> IO b
allocaLen = doAllocaLen undefined
  where
    doAllocaLen :: Storable a => a -> (Int -> Ptr a -> IO b) -> IO b
    doAllocaLen dummy f = alloca . f $ sizeOf dummy

byteSwap32 :: Word32 -> Word32
#if __GLASGOW_HASKELL__ >= 708
byteSwap32 = W.byteSwap32
#else
byteSwap32 (W32# w#) = W32# (narrow32Word# (byteSwap32# w#))
#endif

-- TODO: Rename this to something more sensible.
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum = toEnum . fromIntegral

-- TODO: Rename this to something more sensible.
cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum = fromIntegral . fromEnum

getFromIntegral :: (Integral i, Num n) => (Ptr a -> IO i) -> Ptr a -> IO n
getFromIntegral getter = fmap fromIntegral . getter

getRealToFrac :: (Real r, Fractional f) => (Ptr a -> IO r) -> Ptr a -> IO f
getRealToFrac getter = fmap realToFrac . getter

setFromIntegral :: (Integral i, Num n) => (Ptr a -> n -> IO ()) -> Ptr a -> i -> IO ()
setFromIntegral setter ptr = setter ptr . fromIntegral

setRealToFrac :: (Real r, Fractional f) => (Ptr a -> f -> IO ()) -> Ptr a -> r -> IO ()
setRealToFrac setter ptr = setter ptr . realToFrac

peekFromIntegral :: (Integral a, Storable a, Num b) => Ptr a -> IO b
peekFromIntegral = fmap fromIntegral . peek

peekRealToFrac :: (Real a, Storable a, Fractional b) => Ptr a -> IO b
peekRealToFrac = fmap realToFrac . peek

throwSocketErrorIf :: (a -> Bool) -> String -> IO a -> IO a
throwSocketErrorIf p name act = do
    r <- act
    if p r
       then throwSocketError name
       else return r

throwSocketErrorIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO ()
throwSocketErrorIfMinus1Retry_ name = void . throwSocketErrorIfMinus1Retry name

throwSocketErrorIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwSocketErrorIfNull = throwSocketErrorIf (== nullPtr)

throwSocketErrorIfNull_ :: String -> IO (Ptr a) -> IO ()
throwSocketErrorIfNull_ name = void . throwSocketErrorIfNull name

unsafePeek :: Storable a => Ptr a -> a
unsafePeek = unsafePerformIO . peek

unsafePeekFromIntegral :: (Integral a, Storable a, Num b) => Ptr a -> b
unsafePeekFromIntegral = fromIntegral . unsafePeek

unsafePeekRealToFrac :: (Real a, Storable a, Fractional b) => Ptr a -> b
unsafePeekRealToFrac = realToFrac . unsafePeek

-- | Synonym for 'with' to avoid c2hs issues.
--   See <https://github.com/haskell/c2hs/issues/93 this issue>.
with' :: Storable s => s -> (Ptr s -> IO a) -> IO a
with' = with

withCast :: Storable s1 => s1 -> (Ptr s2 -> IO a) -> IO a
withCast val f = with val $ f . castPtr

withCastArray :: Storable s1 => [s1] -> (Ptr s2 -> IO a) -> IO a
withCastArray vals = withCastArrayLen vals . const

withCastArrayLen :: Storable s1 => [s1] -> (Int -> Ptr s2 -> IO a) -> IO a
withCastArrayLen vals f = withArrayLen vals $ \len -> f len . castPtr

withCastArray0 :: Storable s1 => s1 -> [s1] -> (Ptr s2 -> IO a) -> IO a
withCastArray0 marker vals = withCastArrayLen0 marker vals . const

withCastArrayLen0 :: Storable s1 => s1 -> [s1] -> (Int -> Ptr s2 -> IO a) -> IO a
withCastArrayLen0 marker vals f = withArrayLen0 marker vals $ \len -> f len . castPtr

withCastLen :: Storable s1 => s1 -> ((Ptr s2, CSize) -> IO a) -> IO a
withCastLen val f = withLen val $ f . mapFst castPtr

withCastLenConv :: (Num n, Storable s1) => s1 -> ((Ptr s2, n) -> IO a) -> IO a
withCastLenConv val f = withCastLen val $ f . mapSnd fromIntegral

withFunWrapper :: (a -> IO (FunPtr a)) -> a -> (FunPtr a -> IO b) -> IO b
withFunWrapper wrapper hFun f = do
    funPtr <- wrapper hFun
    res <- f funPtr
    freeHaskellFunPtr funPtr
    return res

withLen :: Storable a => a -> ((Ptr a, CSize) -> IO b) -> IO b
withLen val f = with val $ f . (, fromIntegral $ sizeOf val)

withLenConv :: (Num n, Storable s) => s -> ((Ptr s, n) -> IO a) -> IO a
withLenConv val f = withLen val $ f . mapSnd fromIntegral

-------------------------------------------------------------------------------

mapFst :: (a1 -> a2) -> (a1, b) -> (a2, b)
mapFst f (x, y) = (f x, y)

mapSnd :: (b1 -> b2) -> (a, b1) -> (a, b2)
mapSnd = fmap


Added connect()

Added connect()

module Network.Bluetooth.Linux.Socket where

import Control.Concurrent.MVar
import Control.Exception
import Control.Monad

import Data.Either
import Data.Word

import Foreign.C.Error
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Network.Bluetooth.Linux.Addr
import Network.Bluetooth.Linux.Internal
import Network.Bluetooth.Utils
import Network.Socket

#include <bluetooth/bluetooth.h>
#include "wr_l2cap.h"
#include "wr_rfcomm.h"

bluetoothSocket :: BluetoothProtocol -> IO Socket
bluetoothSocket proto = do
    let family  = AF_BLUETOOTH
        sockType = case proto of
            L2CAP  -> SeqPacket
            RFCOMM -> Stream
    fd <- throwErrnoIfMinus1 "socket" $ c_socket family sockType proto
    status <- newMVar NotConnected
    return $ MkSocket fd family sockType (cFromEnum proto) status

assignSocket :: (Num n1, Num n2, SockAddrPtr p) =>
                Int
             -> (Ptr p -> n1 -> IO ())
             -> (Ptr p -> Ptr BluetoothAddr -> IO ())
             -> (Ptr p -> n2 -> IO ())
             -> (CInt -> Ptr p -> Int -> IO Int)
             -> String
             -> Socket -> BluetoothAddr -> Int -> IO ()
assignSocket sockaddrSize familySetter bdaddrSetter portSetter c_assigner name (MkSocket fd _ _ proto sockStatus) bdaddr portNum =
    modifyMVar_ sockStatus $ \status -> do
        when (status /= NotConnected) . ioError . userError $
          name ++ ": can't peform " ++ name ++ " on socket in status " ++ show status
        let protoEnum = cToEnum proto
        btPort <- mkPort protoEnum portNum
        let portNum' = (case protoEnum of
                           L2CAP -> c_htobs
                           RFCOMM -> id) $ getPort btPort
        allocaBytes sockaddrSize $ \sockaddrPtr -> with bdaddr $ \bdaddrPtr -> do
            setFromIntegral familySetter sockaddrPtr $ packFamily AF_BLUETOOTH
            bdaddrSetter sockaddrPtr bdaddrPtr
            setFromIntegral portSetter sockaddrPtr portNum'
            throwErrnoIfMinus1_ name $ c_assigner fd sockaddrPtr sockaddrSize
        return Bound

bluetoothBind :: Socket -> BluetoothAddr -> Int -> IO ()
bluetoothBind sock@(MkSocket _ _ _ proto _) =
  let bind' = case cToEnum proto of
                   L2CAP  -> assignSocket {#sizeof sockaddr_l2_t #}
                                          {#set sockaddr_l2_t.l2_family #}
                                          c_sockaddr_l2_set_bdaddr
                                          {#set sockaddr_l2_t.l2_psm #}
                                          c_bind
                   RFCOMM -> assignSocket {#sizeof sockaddr_rc_t #}
                                          {#set sockaddr_rc_t.rc_family #}
                                          c_sockaddr_rc_set_bdaddr
                                          {#set sockaddr_rc_t.rc_channel #}
                                          c_bind
  in bind' "bind" sock
-- bluetoothBind (MkSocket fd _ _ proto sockStatus) bdaddr portNum = do
--     modifyMVar_ sockStatus $ \status -> do
--         when (status /= NotConnected) . ioError . userError $
--           "bind: can't peform bind on socket in status " ++ show status
--         let protoEnum = cToEnum proto
--         btPort <- mkPort protoEnum portNum
--         case protoEnum of
--              L2CAP  -> callBind {#sizeof sockaddr_l2_t #}
--                                 {#set sockaddr_l2_t.l2_family #}
--                                 c_sockaddr_l2_set_bdaddr
--                                 {#set sockaddr_l2_t.l2_psm #}
--                                 (c_htobs $ getPort btPort)
--              RFCOMM -> callBind {#sizeof sockaddr_rc_t #}
--                                 {#set sockaddr_rc_t.rc_family #}
--                                 c_sockaddr_rc_set_bdaddr
--                                 {#set sockaddr_rc_t.rc_channel #}
--                                 (getPort btPort)
--         return Bound
--   where
--     callBind :: (Num s1, Num s2, SockAddrPtr p, Integral i) =>
--                 Int
--              -> (Ptr p -> s1 -> IO ())
--              -> (Ptr p -> Ptr BluetoothAddr -> IO ())
--              -> (Ptr p -> s2 -> IO ())
--              -> i
--              -> IO ()
--     callBind size setter1 setter2 setter3 port' =
--       allocaBytes size $ \sockaddrPtr ->
--       with bdaddr      $ \bdaddrPtr   -> do
--           setFromIntegral setter1 sockaddrPtr $ packFamily AF_BLUETOOTH
--           setter2 sockaddrPtr bdaddrPtr
--           setFromIntegral setter3 sockaddrPtr port'
--           throwErrnoIfMinus1_ "bind" $ c_bind fd sockaddrPtr size

bluetoothBindAnyPort :: Socket -> BluetoothAddr -> IO BluetoothPort
bluetoothBindAnyPort sock@(MkSocket _ _ _ proto _) bdaddr = do
    port <- bindAnyPort (cToEnum proto) bdaddr
    bluetoothBind sock bdaddr $ getPort port
    return port

data BluetoothPort = RFCOMMPort Word8
                   | L2CAPPort Word16
                   deriving Eq

instance Show BluetoothPort where
    show = show . getPort

getPort :: BluetoothPort -> Int
getPort (L2CAPPort p)  = fromIntegral p
getPort (RFCOMMPort p) = fromIntegral p

mkPort :: BluetoothProtocol -> Int -> IO BluetoothPort
mkPort RFCOMM port | 1 <= port && port <= 30
                   = return . RFCOMMPort $ fromIntegral port
mkPort RFCOMM _    = ioError $ userError "RFCOMM ports must be between 1 and 30."
mkPort L2CAP  port | odd port && 4097 <= port && port <= 32767
                   = return . L2CAPPort $ fromIntegral port
mkPort L2CAP  _    = ioError $ userError "L2CAP ports must be odd numbers between 4097 and 32,767."

bindAnyPort :: BluetoothProtocol -> BluetoothAddr -> IO BluetoothPort
bindAnyPort proto addr = do
    avails <- flip filterM (portRange proto) $ \portNum -> do
        sock <- bluetoothSocket proto
        res  <- try $ bluetoothBind sock addr portNum
        close sock
        return $ isRight (res :: Either IOError ())
    case avails of
        portNum:_ -> mkPort proto portNum
        _         -> ioError $ userError "Unable to find any available port"
  where
    portRange L2CAP  = [4097, 4099 .. 32767]
    portRange RFCOMM = [1 .. 30]

bluetoothListen :: Socket -> Int -> IO ()
bluetoothListen = listen -- TODO: tweak exception handling

bluetoothAccept :: Socket -> IO (Socket, BluetoothAddr)
bluetoothAccept (MkSocket fd family sockType proto sockStatus) = do
    currentStatus <- readMVar sockStatus
    when (currentStatus /= Connected && currentStatus /= Listening) . ioError . userError $
      "accept: can't perform accept on socket (" ++ show (family,sockType,proto) ++ ") in status " ++ show currentStatus
    case cToEnum proto of
         L2CAP  -> callAccept {#sizeof sockaddr_l2_t #} c_sockaddr_l2_get_bdaddr
         RFCOMM -> callAccept {#sizeof sockaddr_rc_t #} c_sockaddr_rc_get_bdaddr
  where
    callAccept :: SockAddrPtr p =>
                  Int
               -> (Ptr BluetoothAddr -> Ptr p -> IO (Ptr BluetoothAddr))
               -> IO (Socket, BluetoothAddr)
    callAccept size getter =
      allocaBytes size                                  $ \sockaddrPtr ->
      allocaBytes (sizeOf (undefined :: BluetoothAddr)) $ \bdaddrPtr   -> do
          (newFd,_) <- throwErrnoIf ((== -1) . fst) "accept" $ c_accept fd sockaddrPtr size
          _ <- getter bdaddrPtr sockaddrPtr
          bdaddr <- peek bdaddrPtr
          newStatus <- newMVar Connected
          return (MkSocket newFd family sockType proto newStatus, bdaddr)

-- bluetoothConnect :: Socket -> BluetoothAddr -> Int -> IO ()
-- bluetoothConnect (MkSocket fd _ _ proto sockStatus) bdaddr portNum = do
--     modifyMVar sockStatus $ \status -> do
--         when (status /= NotConnected) . ioError . userError $
--           "accept: can't peform connect on socket in status " ++ show status
--         let protoEnum = cToEnum proto
--         btPort <- mkPort protoEnum bdaddr portNum
--         case protoEnum of
--              L2CAP  ->
--              RFCOMM ->
--   where
--     callConnect :: SockAddrPtr p => Int

bluetoothConnect :: Socket -> BluetoothAddr -> Int -> IO ()
bluetoothConnect sock@(MkSocket _ _ _ proto _) =
  let connect' = case cToEnum proto of
                      L2CAP  -> assignSocket {#sizeof sockaddr_l2_t #}
                                             {#set sockaddr_l2_t.l2_family #}
                                             c_sockaddr_l2_set_bdaddr
                                             {#set sockaddr_l2_t.l2_psm #}
                                             c_connect
                      RFCOMM -> assignSocket {#sizeof sockaddr_rc_t #}
                                             {#set sockaddr_rc_t.rc_family #}
                                             c_sockaddr_rc_set_bdaddr
                                             {#set sockaddr_rc_t.rc_channel #}
                                             c_connect
  in connect' "connect" sock

getSockPort :: Socket -> IO BluetoothPort
getSockPort (MkSocket fd _ _ proto status) = do
    currentStatus <- readMVar status
    when (currentStatus == NotConnected || currentStatus == Closed) . ioError . userError $
      "getsockname: can't get name of socket in status " ++ show currentStatus
    case cToEnum proto of
         L2CAP  -> callGetSockName {#sizeof sockaddr_l2_t #}
                                   ({#get sockaddr_l2_t.l2_psm #} :: SockAddrL2CAPPtr -> IO CUShort)
                                   L2CAPPort
         RFCOMM -> callGetSockName {#sizeof sockaddr_rc_t #}
                                   ({#get sockaddr_rc_t.rc_channel #} :: SockAddrRFCOMMPtr -> IO CUInt8)
                                   RFCOMMPort
  where
    callGetSockName :: (Integral i, Integral j, SockAddrPtr p) =>
                       Int
                    -> (Ptr p -> IO i)
                    -> (j -> BluetoothPort)
                    -> IO BluetoothPort
    callGetSockName size getter portCon = allocaBytes size $ \sockaddrPtr -> do
        throwErrnoIf_ ((== -1) . fst) "getsockname" $ c_getsockname fd sockaddrPtr size
        fmap portCon $ getFromIntegral getter sockaddrPtr

module Network.Bluetooth.Linux.Socket where

import Control.Concurrent.MVar
import Control.Exception
import Control.Monad

import Data.Either
import Data.Word

import Foreign.C.Error
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Network.Bluetooth.Linux.Addr
import Network.Bluetooth.Linux.Internal
import Network.Bluetooth.Utils
import Network.Socket

#include <bluetooth/bluetooth.h>
#include "wr_l2cap.h"
#include "wr_rfcomm.h"

bluetoothSocket :: BluetoothProtocol -> IO Socket
bluetoothSocket proto = do
    let family  = AF_BLUETOOTH
        sockType = case proto of
            L2CAP  -> SeqPacket
            RFCOMM -> Stream
    fd <- throwErrnoIfMinus1 "socket" $ c_socket family sockType proto
    status <- newMVar NotConnected
    return $ MkSocket fd family sockType (cFromEnum proto) status

bluetoothBind :: Socket -> BluetoothAddr -> Int -> IO ()
bluetoothBind (MkSocket fd _ _ proto sockStatus) bdaddr portNum = do
    modifyMVar_ sockStatus $ \status -> do
        when (status /= NotConnected) . ioError . userError $
          "bind: can't peform bind on socket in status " ++ show status
        btPort <- mkPort (cToEnum proto) portNum
        case cToEnum proto of
             L2CAP  -> callBind {#sizeof sockaddr_l2_t #}
                                {#set sockaddr_l2_t.l2_family #}
                                c_sockaddr_l2_set_bdaddr
                                {#set sockaddr_l2_t.l2_psm #}
                                (c_htobs $ getPort btPort)
             RFCOMM -> callBind {#sizeof sockaddr_rc_t #}
                                {#set sockaddr_rc_t.rc_family #}
                                c_sockaddr_rc_set_bdaddr
                                {#set sockaddr_rc_t.rc_channel #}
                                (getPort btPort)
        return Bound
  where
    callBind :: (Num s1, Num s2, SockAddrPtr p, Integral i) =>
                Int
             -> (Ptr p -> s1 -> IO ())
             -> (Ptr p -> Ptr BluetoothAddr -> IO ())
             -> (Ptr p -> s2 -> IO ())
             -> i
             -> IO ()
    callBind size setter1 setter2 setter3 port' =
      allocaBytes size $ \sockaddrPtr ->
      with bdaddr      $ \bdaddrPtr   -> do
          setFromIntegral setter1 sockaddrPtr $ packFamily AF_BLUETOOTH
          setter2 sockaddrPtr bdaddrPtr
          setFromIntegral setter3 sockaddrPtr port'
          throwErrnoIfMinus1_ "bind" $ c_bind fd sockaddrPtr size

bluetoothBindAnyPort :: Socket -> BluetoothAddr -> IO BluetoothPort
bluetoothBindAnyPort sock@(MkSocket _ _ _ proto _) bdaddr = do
    port <- bindAnyPort (cToEnum proto) bdaddr
    bluetoothBind sock bdaddr $ getPort port
    return port

data BluetoothPort = RFCOMMPort Word8
                   | L2CAPPort Word16
                   deriving Eq

instance Show BluetoothPort where
    show = show . getPort

getPort :: BluetoothPort -> Int
getPort (L2CAPPort p)  = fromIntegral p
getPort (RFCOMMPort p) = fromIntegral p

mkPort :: BluetoothProtocol -> Int -> IO BluetoothPort
mkPort RFCOMM port | 1 <= port && port <= 30
                   = return . RFCOMMPort $ fromIntegral port
mkPort RFCOMM _    = ioError $ userError "RFCOMM ports must be between 1 and 30."
mkPort L2CAP  port | odd port && 4097 <= port && port <= 32767
                   = return . L2CAPPort $ fromIntegral port
mkPort L2CAP  _    = ioError $ userError "L2CAP ports must be odd numbers between 4097 and 32,767."

bindAnyPort :: BluetoothProtocol -> BluetoothAddr -> IO BluetoothPort
bindAnyPort proto addr = do
    avails <- flip filterM (portRange proto) $ \portNum -> do
        sock <- bluetoothSocket proto
        res  <- try $ bluetoothBind sock addr portNum
        close sock
        return $ isRight (res :: Either IOError ())
    case avails of
        portNum:_ -> mkPort proto portNum
        _         -> ioError $ userError "Unable to find any available port"
  where
    portRange L2CAP  = [4097, 4099 .. 32767]
    portRange RFCOMM = [1 .. 30]

bluetoothListen :: Socket -> Int -> IO ()
bluetoothListen = listen -- TODO: tweak exception handling

bluetoothAccept :: Socket -> IO (Socket, BluetoothAddr)
bluetoothAccept (MkSocket fd family sockType proto sockStatus) = do
    currentStatus <- readMVar sockStatus
    when (currentStatus /= Connected && currentStatus /= Listening) . ioError . userError $
      "accept: can't perform accept on socket (" ++ show (family,sockType,proto) ++ ") in status " ++ show currentStatus
    case cToEnum proto of
         L2CAP  -> callAccept {#sizeof sockaddr_l2_t #} c_sockaddr_l2_get_bdaddr
         RFCOMM -> callAccept {#sizeof sockaddr_rc_t #} c_sockaddr_rc_get_bdaddr
  where
    callAccept :: SockAddrPtr p =>
                  Int
               -> (Ptr BluetoothAddr -> Ptr p -> IO (Ptr BluetoothAddr))
               -> IO (Socket, BluetoothAddr)
    callAccept size getter =
      allocaBytes size                                  $ \sockaddrPtr ->
      allocaBytes (sizeOf (undefined :: BluetoothAddr)) $ \bdaddrPtr   -> do
          (newFd,_) <- throwErrnoIf ((== -1) . fst) "accept" $ c_accept fd sockaddrPtr size
          _ <- getter bdaddrPtr sockaddrPtr
          bdaddr <- peek bdaddrPtr
          newStatus <- newMVar Connected
          return (MkSocket newFd family sockType proto newStatus, bdaddr)

-- bluetoothAccept :: Socket -> BluetoothAddr -> Int -> IO ()
-- bluetoothAccept (MkSocket fd _ _ proto sockStatus) bdaddr portNum = do
--     modifyMVar sockStatus $ \status -> do
--         when (status /= NotConnected) . ioError . userError $
--           "accept: can't peform connect on socket in status " ++ show status
--         btPort <- mkPort (cToEnum proto) bdaddr portNum

getSockPort :: Socket -> IO BluetoothPort
getSockPort (MkSocket fd _ _ proto status) = do
    currentStatus <- readMVar status
    when (currentStatus == NotConnected || currentStatus == Closed) . ioError . userError $
      "getsockname: can't get name of socket in status " ++ show currentStatus
    case cToEnum proto of
         L2CAP  -> callGetSockName {#sizeof sockaddr_l2_t #}
                                   ({#get sockaddr_l2_t.l2_psm #} :: SockAddrL2CAPPtr -> IO CUShort)
                                   L2CAPPort
         RFCOMM -> callGetSockName {#sizeof sockaddr_rc_t #}
                                   ({#get sockaddr_rc_t.rc_channel #} :: SockAddrRFCOMMPtr -> IO CUInt8)
                                   RFCOMMPort
  where
    callGetSockName :: (Integral i, Integral j, SockAddrPtr p) =>
                       Int
                    -> (Ptr p -> IO i)
                    -> (j -> BluetoothPort)
                    -> IO BluetoothPort
    callGetSockName size getter portCon = allocaBytes size $ \sockaddrPtr -> do
        throwErrnoIf_ ((== -1) . fst) "getsockname" $ c_getsockname fd sockaddrPtr size
        fmap portCon $ getFromIntegral getter sockaddrPtr


wibble

wibble

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal              (peekDeviceHandle)
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Unsafe.Coerce

import Control.Monad                            (liftM)
import Control.Exception                        (throwIO)
import Data.Maybe                               (mapMaybe)
import Data.ByteString.Char8                    (ByteString)
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Internal       as B

#if CUDA_VERSION < 5050
import Debug.Trace                              (trace)
#endif

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
  | GenerateDebugInfo                   -- ^ generate debug info (-g) (requires cuda >= 5.5)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)
  | Verbose                             -- ^ verbose log messages (requires cuda >= 5.5)
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- Return a global pointer, and size of the global (in bytes)
--
{-# INLINEABLE getPtr #-}
getPtr :: Module -> String -> IO (DevicePtr a, Int)
getPtr !mdl !name = do
  (!status,!dptr,!bytes) <- cuModuleGetGlobal mdl name
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

-- |
-- Load the contents of the specified file (either a ptx or cubin file) to
-- create a new module, and load that module into the current context.
--
{-# INLINEABLE loadFile #-}
loadFile :: FilePath -> IO Module
loadFile !ptx = resultIfOk =<< cuModuleLoad ptx

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = Just (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = Just (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = Just (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = Just (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = Just (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = Just (JIT_LOG_VERBOSE,         fromEnum True)
#else
    unpack x                     = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
resultIfFound kind name (!status,!result) =
  case status of
       Success  -> return result
       NotFound -> cudaError (kind ++ ' ' : describe status ++ ": " ++ name)
       _        -> throwIO (ExitCode status)

{-# INLINE peekMod #-}
peekMod :: Ptr {# type CUmodule #} -> IO Module
peekMod = liftM Module . peek

{-# INLINE c_strnlen' #-}
foreign import ccall unsafe "string.h strnlen" c_strnlen'
  :: CString -> CSize -> IO CSize

{-# INLINE c_strnlen #-}
c_strnlen :: CString -> Int -> IO Int
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal              (peekDeviceHandle)
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Unsafe.Coerce

import Control.Monad                            (liftM)
import Control.Exception                        (throwIO)
import Debug.Trace                              (trace)
import Data.Maybe                               (mapMaybe)
import Data.ByteString.Char8                    (ByteString)
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Internal       as B

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
  | GenerateDebugInfo                   -- ^ generate debug info (-g) (requires cuda >= 5.5)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)
  | Verbose                             -- ^ verbose log messages (requires cuda >= 5.5)
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- Return a global pointer, and size of the global (in bytes)
--
{-# INLINEABLE getPtr #-}
getPtr :: Module -> String -> IO (DevicePtr a, Int)
getPtr !mdl !name = do
  (!status,!dptr,!bytes) <- cuModuleGetGlobal mdl name
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

-- |
-- Load the contents of the specified file (either a ptx or cubin file) to
-- create a new module, and load that module into the current context.
--
{-# INLINEABLE loadFile #-}
loadFile :: FilePath -> IO Module
loadFile !ptx = resultIfOk =<< cuModuleLoad ptx

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = Just (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = Just (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = Just (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = Just (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = Just (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = Just (JIT_LOG_VERBOSE,         fromEnum True)
#else
    unpack x                     = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
resultIfFound kind name (!status,!result) =
  case status of
       Success  -> return result
       NotFound -> cudaError (kind ++ ' ' : describe status ++ ": " ++ name)
       _        -> throwIO (ExitCode status)

{-# INLINE peekMod #-}
peekMod :: Ptr {# type CUmodule #} -> IO Module
peekMod = liftM Module . peek

{-# INLINE c_strnlen' #-}
foreign import ccall unsafe "string.h strnlen" c_strnlen'
  :: CString -> CSize -> IO CSize

{-# INLINE c_strnlen #-}
c_strnlen :: CString -> Int -> IO Int
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)


gconf: S.G.G.GConfValue: remove -fallow-overlapping-instances (it's handled in the makefile)

{-# OPTIONS -fallow-overlapping-instances #-} -- String & [a] overlap
-- -*-haskell-*-
-- GIMP Toolkit (GTK) GConf API
--
--  Author : Duncan Coutts
--  Created: 16 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
--  |
--
--  Module for dealing with the values stored in the GConf system.
--
--  GConfValue has its own primitive type system which is represented in
--  Haskell using type classes. This allows values to be get and set without
--  needing to perform any dynamic type casting or needing a union type.
--
--  Alternatively, a dynamic\/union type is provided for the rare occasions
--  when that degree of flexability is required. It should only be necessary
--  if you need to deal with configuration values without statically knowing
--  their type.
--

module System.Gnome.GConf.GConfValue (
 GConfPrimitiveValueClass,
 GConfValueClass(marshalFromGConfValue, marshalToGConfValue),
 GConfValue(GConfValue),
 GConfValueDyn(..),
 ) where

import Control.Monad (liftM, when)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList (toGSList, readGSList)

--{# context lib="gconf" prefix ="gconf_value" #}
{# context lib="gconf" #}

{# enum GConfValueType {underscoreToCase} deriving (Eq, Show) #}

{# pointer *GConfValue newtype #}

-- | Class of types which can be kept by GConf
class GConfValueClass value where
  --unsafe because assumes non-null pointer and correct type
  unsafeMarshalFromGConfValue :: GConfValue -> IO value

  -- safe checked version, may throw exception
  marshalFromGConfValue :: GConfValue -> IO value
  marshalFromGConfValue value = do
    checkForNullAndExpectedType (typeofGConfValue (undefined::value)) value
    unsafeMarshalFromGConfValue value

  typeofGConfValue :: value -> GConfValueType

  marshalToGConfValue :: value -> IO GConfValue

-- The above methods follow the following memory management rules regarding
-- GConfValues: marshalFrom reads the value but does not gain ownership and thus
-- does not deallocate. marshalTo allocates a new value and gives up ownership;
-- it is not responsible for dellocation (it does not attach a finaliser).
-- The code that uses marshalTo must ensure that it hands the value off to a
-- function that is prepared to asume ownership of the value.

-- | Dynamic version for when the type is not known statically.
data GConfValueDyn = GConfValueString String
                   | GConfValueInt Int
                   | GConfValueFloat Double
                   | GConfValueBool Bool
                   | GConfValueSchema               -- ^ Not supported
                   | GConfValueList [GConfValueDyn] -- ^ Must all be of same primitive type
                   | GConfValuePair (GConfValueDyn, GConfValueDyn) -- ^ Must both be primitive

-- Allow variant using Maybe, where Nothing means the value was not set
-- Use this variant when you expect the gconf key to not be set somethimes;
-- otherwise the 'raw' types will raise an exception if you get an unset key.
-- Just for consistency, setting a key to Nothing will unset the key, however
-- it is preferable to use gconfClientUnset explicitly.
instance GConfValueClass value => GConfValueClass (Maybe value) where
  typeofGConfValue _ = typeofGConfValue (undefined :: value)
  unsafeMarshalFromGConfValue = marshalFromGConfValue
  marshalFromGConfValue value =
    catch (liftM Just $ marshalFromGConfValue value)
          (\_ -> return Nothing)
  marshalToGConfValue (Just v) = marshalToGConfValue v
  marshalToGConfValue Nothing  = return $ GConfValue nullPtr

-- The GConfValue type system says some types are primitive.
-- Compound types (lists & pairs) may only be constructed from primitive types.
class GConfValueClass value => GConfPrimitiveValueClass value
instance GConfPrimitiveValueClass Int
instance GConfPrimitiveValueClass Bool
instance GConfPrimitiveValueClass Double
instance GConfPrimitiveValueClass String

instance GConfValueClass Int where
  typeofGConfValue _ = GconfValueInt
  unsafeMarshalFromGConfValue = liftM fromIntegral . {# call unsafe gconf_value_get_int #}
  marshalToGConfValue n = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueInt)
    {# call unsafe gconf_value_set_int #} (GConfValue value) (fromIntegral n)
    return (GConfValue value)

instance GConfValueClass Bool where
  typeofGConfValue _ = GconfValueBool
  unsafeMarshalFromGConfValue = liftM toBool . {# call unsafe gconf_value_get_bool #}
  marshalToGConfValue b = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueBool)
    {# call unsafe gconf_value_set_bool #} (GConfValue value) (fromBool b)
    return (GConfValue value)

instance GConfValueClass Double where
  typeofGConfValue _ = GconfValueFloat
  unsafeMarshalFromGConfValue = liftM realToFrac . {# call unsafe gconf_value_get_float #}
  marshalToGConfValue f = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueFloat)
    {# call unsafe gconf_value_set_float #} (GConfValue value) (realToFrac f)
    return (GConfValue value)

-- Now unfortunately String & [a] overlap, although really they don't since Char
-- is not an instance of GConfPrimitiveValueClass, however classes are open so
-- we don't know that Char would never be an instance. I want closed classes!
instance GConfValueClass String where
  typeofGConfValue _ = GconfValueString

  unsafeMarshalFromGConfValue value = do
    strPtr <- {# call unsafe gconf_value_get_string #} value
    peekUTFString strPtr

  marshalToGConfValue s = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueString)
    withCString s $ \strPtr ->
      {# call unsafe gconf_value_set_string #} (GConfValue value) strPtr
    return (GConfValue value)

instance (GConfPrimitiveValueClass a, GConfPrimitiveValueClass b) => GConfValueClass (a,b) where
  typeofGConfValue _ = GconfValuePair

  unsafeMarshalFromGConfValue value = do
    a <- {# call unsafe gconf_value_get_car #} value
    b <- {# call unsafe gconf_value_get_cdr #} value
    a' <- marshalFromGConfValue (GConfValue a)
    b' <- marshalFromGConfValue (GConfValue b)
    return (a',b')

  marshalToGConfValue (a,b) = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValuePair)
    a' <- marshalToGConfValue a
    b' <- marshalToGConfValue b
    {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
    {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
    return (GConfValue value)

instance GConfPrimitiveValueClass a => GConfValueClass [a] where
  typeofGConfValue _ = GconfValueList

  unsafeMarshalFromGConfValue value = do
    gsList <- {# call unsafe gconf_value_get_list #} value
    valuesPtrs <- readGSList gsList
    mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

  marshalFromGConfValue value = do
    checkForNullAndExpectedType GconfValueList value
    listType <- liftM (toEnum . fromIntegral) $
                {# call unsafe gconf_value_get_list_type #} value
    when (listType /= typeofGConfValue (undefined :: a))
         (fail "GConf: key is list with elements of unexpected type")
    unsafeMarshalFromGConfValue value

  marshalToGConfValue list = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueList)
    valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) list
    valuesList <- toGSList valuesPtrs
    {# call unsafe gconf_value_set_list_type #} (GConfValue value)
      (fromIntegral $ fromEnum $ typeofGConfValue (undefined::a))
    {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
    return (GConfValue value)

----------------
-- For convenience and best practice, an instance for Enum
-- This conforms to the GConf GTK+/Gnome convention for storing enum types,
-- which is to store them as a string using ThisStlyeOfCapitalisation.

-- Note: currently disabled since it requires -fallow-undecidable-instances
{-
instance (Show enum, Read enum, Enum enum, GConfValueClass enum)
      => GConfPrimitiveValueClass enum
instance (Show enum, Read enum, Enum enum) => GConfValueClass enum where
  marshalFromGConfValue value = do
    enumStr <- marshalFromGConfValue value
    case reads enumStr of
      [(enum,_)] -> return enum
      _          -> fail "GCconf: invalid enum value"
  marshalFromGConfValue' value = do
    maybeEnumStr <- marshalFromGConfValue' value
    case maybeEnumStr of
      Nothing -> return Nothing
      (Just enumStr) -> case reads enumStr of
                          [(enum,_)] -> return (Just enum)
                          _          -> return Nothing
  marshalToGConfValue enum = marshalToGConfValue (show enum)
  typeofGConfValue _ = GconfValueString
-}

----------------
-- Helper funcs

gconfValueGetType :: GConfValue ->  IO GConfValueType
--we mean the following but unfortunately c2hs barfs on 'type'
--gconfValueGetType (GConfValue valuePtr) = {# get GConfValue->type #} valuePtr
-- so instead we have the ugly:
gconfValueGetType (GConfValue valuePtr) =
  liftM (toEnum . fromIntegral) $ peek (castPtr valuePtr :: Ptr CInt)
--TODO: check that sizeof(GConfValueType) == sizeof(int)

-- returns Nothing if ok, or and error message
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO ()
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  when (valueType /= expectedType)
                       (fail $ "GConf: key is of unexpected type, expected: "
                          ++ show expectedType ++ ", got: " ++ show valueType)

{-
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO GConfValue
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then fail $ "GConf: key is of unexpected type, expected: "
                             ++ show expectedType ++ ", got: " ++ show valueType
                    else return value

checkForNullAndExpectedType' :: GConfValueType -> GConfValue -> IO (Maybe GConfValue)
checkForNullAndExpectedType' expectedType value@(GConfValue ptr)
 | ptr == nullPtr = return Nothing
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then return Nothing
                    else return (Just value)
-}
----------------
-- GConfValueDyn

unsafeMarshalGConfValueDynListFromGConfValue :: GConfValue -> IO [GConfValueDyn]
unsafeMarshalGConfValueDynListFromGConfValue value = do
  gsList <- {# call unsafe gconf_value_get_list #} value
  valuesPtrs <- readGSList gsList
  mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

marshalGConfValueDynListToGConfValue :: [GConfValueDyn] -> IO GConfValue
marshalGConfValueDynListToGConfValue as = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValueList)
  valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) as
  valuesList <- toGSList valuesPtrs
  {# call unsafe gconf_value_set_list_type #} (GConfValue value)
    (fromIntegral $ fromEnum $ (case as of
                                  []    -> GconfValueInvalid  --unknown type
                                  (a:_) -> gconfValueDynGetType (head as)))
  {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
  return (GConfValue value)

unsafeMarshalGConfValueDynPairFromGConfValue :: GConfValue -> IO (GConfValueDyn, GConfValueDyn)
unsafeMarshalGConfValueDynPairFromGConfValue value = do
  a <- {# call unsafe gconf_value_get_car #} value
  b <- {# call unsafe gconf_value_get_cdr #} value
  a' <- marshalFromGConfValue (GConfValue a)
  b' <- marshalFromGConfValue (GConfValue b)
  return (a', b')

marshalGConfValueDynPairToGConfValue :: (GConfValueDyn, GConfValueDyn) -> IO GConfValue
marshalGConfValueDynPairToGConfValue (a,b) = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValuePair)
  a' <- marshalToGConfValue a
  b' <- marshalToGConfValue b
  {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
  {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
  return (GConfValue value)

instance GConfValueClass GConfValueDyn where
  typeofGConfValue _ = undefined -- will never be used
  unsafeMarshalFromGConfValue value = do
    valueType <- gconfValueGetType value
    case valueType of
      GconfValueString -> liftM GConfValueString $ unsafeMarshalFromGConfValue value
      GconfValueInt    -> liftM GConfValueInt    $ unsafeMarshalFromGConfValue value
      GconfValueFloat  -> liftM GConfValueFloat  $ unsafeMarshalFromGConfValue value
      GconfValueBool   -> liftM GConfValueBool   $ unsafeMarshalFromGConfValue value
      GconfValueSchema -> return GConfValueSchema
      GconfValueList   -> liftM GConfValueList   $ unsafeMarshalGConfValueDynListFromGConfValue value
      GconfValuePair   -> liftM GConfValuePair   $ unsafeMarshalGConfValueDynPairFromGConfValue value

  marshalFromGConfValue value@(GConfValue ptr) = do
    when (ptr == nullPtr) $ fail "GConf: cannot get value of key, key is unset"
    unsafeMarshalFromGConfValue value

  marshalToGConfValue v = case v of
    (GConfValueString v') -> marshalToGConfValue v'
    (GConfValueInt    v') -> marshalToGConfValue v'
    (GConfValueFloat  v') -> marshalToGConfValue v'
    (GConfValueBool   v') -> marshalToGConfValue v'
    (GConfValueSchema   ) -> fail "GConf: setting schema types not supported"
    (GConfValueList   v') -> marshalGConfValueDynListToGConfValue v'
    (GConfValuePair   v') -> marshalGConfValueDynPairToGConfValue v'

gconfValueDynGetType :: GConfValueDyn -> GConfValueType
gconfValueDynGetType (GConfValueString _) = GconfValueString
gconfValueDynGetType (GConfValueInt    _) = GconfValueInt
gconfValueDynGetType (GConfValueFloat  _) = GconfValueFloat
gconfValueDynGetType (GConfValueBool   _) = GconfValueBool
gconfValueDynGetType (GConfValueList   _) = GconfValueList
gconfValueDynGetType (GConfValuePair   _) = GconfValuePair