[project @ 2002-07-12 13:09:23 by dg22]

[project @ 2002-07-12 13:09:23 by dg22]

Fixed references that used the old names for packing widgets.

darcs-hash:20020712130923-18bf1-3b992b25f0ac7dc810b7992244436a98548ba4a6.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/12 13:09:23 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackGrow else
             (if expand then PackRepel else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackGrow)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.2 $ from $Date: 2002/05/24 09:43:25 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackFill else
             (if expand then PackExpand else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackFill)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))


add launchKernel', which passes kernel arguments directly

{-# LANGUAGE GADTs, CPP, ForeignFunctionInterface, EmptyDataDecls #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) [2009..2011] Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec (

  -- * Kernel Execution
  Fun(Fun), FunParam(..), FunAttribute(..), CacheConfig(..),
  requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun,
  launch, launchKernel, launchKernel'

) where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))
import Foreign.CUDA.Driver.Texture              (Texture(..))

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM_)

#if CUDA_VERSION >= 3020
{-# DEPRECATED TArg "as of CUDA version 3.2" #-}
#endif
#if CUDA_VERSION >= 4000
{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch
      "use launchKernel instead" #-}
#endif

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Cache configuration preference
--
#if CUDA_VERSION < 3000
data CacheConfig
#else
{# enum CUfunc_cache_enum as CacheConfig
    { underscoreToCase }
    with prefix="CU_FUNC_CACHE_PREFER" deriving (Eq, Show) #}
#endif

-- |
-- Kernel function parameters
--
data FunParam where
  IArg :: Int             -> FunParam
  FArg :: Float           -> FunParam
  TArg :: Texture         -> FunParam
  VArg :: Storable a => a -> FunParam

instance Storable FunParam where
  sizeOf (IArg _)       = sizeOf (undefined :: CUInt)
  sizeOf (FArg _)       = sizeOf (undefined :: CFloat)
  sizeOf (VArg v)       = sizeOf v
  sizeOf (TArg _)       = 0

  alignment (IArg _)    = alignment (undefined :: CUInt)
  alignment (FArg _)    = alignment (undefined :: CFloat)
  alignment (VArg v)    = alignment v
  alignment (TArg _)    = 0

  poke p (IArg i)       = poke (castPtr p) i
  poke p (FArg f)       = poke (castPtr p) f
  poke p (VArg v)       = poke (castPtr p) v
  poke _ (TArg _)       = return ()

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when
-- the given kernel function is launched.
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- On devices where the L1 cache and shared memory use the same hardware
-- resources, this sets the preferred cache configuration for the given device
-- function. This is only a preference; the driver is free to choose a different
-- configuration as required to execute the function.
--
-- Switching between configuration modes may insert a device-side
-- synchronisation point for streamed kernel launches.
--
setCacheConfigFun :: Fun -> CacheConfig -> IO ()
#if CUDA_VERSION < 3000
setCacheConfigFun _  _    = requireSDK 3.0 "setCacheConfigFun"
#else
setCacheConfigFun fn pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref

{# fun unsafe cuFuncSetCacheConfig
  { useFun    `Fun'
  , cFromEnum `CacheConfig' } -> `Status' cToEnum #}
#endif

-- |
-- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the
-- number of threads specified by a previous call to 'setBlockShape'. The launch
-- may also be associated with a specific 'Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block
-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes
-- of shared memory. The launch may also be associated with a specific 'Stream'.
--
-- In 'launchKernel', the number of kernel parameters and their offsets and
-- sizes do not need to be specified, as this information is retrieved directly
-- from the kernel's image. This requires the kernel to have been compiled with
-- toolchain version 3.2 or later.
--
-- The alternative 'launchKernel'' will pass the arguments in directly,
-- requiring the application to know the size and alignment/padding of each
-- kernel parameter.
--
launchKernel, launchKernel'
    :: Fun                      -- ^ function to execute
    -> (Int,Int,Int)            -- ^ block grid dimension
    -> (Int,Int,Int)            -- ^ thread block shape
    -> Int                      -- ^ shared memory (bytes)
    -> Maybe Stream             -- ^ (optional) stream to execute in
    -> [FunParam]               -- ^ list of function parameters
    -> IO ()
#if CUDA_VERSION >= 4000
launchKernel fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ withMany withFP args
  $ \pa -> withArray pa
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr
  where
    st = fromMaybe (Stream nullPtr) mst

    withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b
    withFP p f = case p of
      IArg v -> with v (f . castPtr)
      FArg v -> with v (f . castPtr)
      VArg v -> with v (f . castPtr)
      TArg _ -> error "launchKernel: TArg is deprecated"

launchKernel' fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ with bytes
  $ \pb -> withArray' args
  $ \pa -> withArray0 nullPtr [buffer, castPtr pa, size, castPtr pb]
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st nullPtr pp
  where
    buffer      = wordPtrToPtr 0x01     -- CU_LAUNCH_PARAM_BUFFER_POINTER
    size        = wordPtrToPtr 0x02     -- CU_LAUNCH_PARAM_BUFFER_SIZE
    bytes       = foldl (\a x -> a + sizeOf x) 0 args
    st          = fromMaybe (Stream nullPtr) mst

    -- can't use the standard 'withArray' because 'mallocArray' will pass
    -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but
    -- our Storable instance for FunParam needs to dispatch on each constructor,
    -- hence evaluating the undefined.
    --
    withArray' vals f =
      allocaBytes bytes $ \ptr -> do
        pokeArray ptr vals
        f ptr

{# fun unsafe cuLaunchKernel
  { useFun    `Fun'
  ,           `Int', `Int', `Int'
  ,           `Int', `Int', `Int'
  ,           `Int'
  , useStream `Stream'
  , castPtr   `Ptr (Ptr FunParam)'
  , castPtr   `Ptr (Ptr ())'       } -> `Status' cToEnum #}

#else
launchKernel fn (gx,gy,_) (tx,ty,tz) sm mst args = do
  setParams     fn args
  setSharedSize fn (toInteger sm)
  setBlockShape fn (tx,ty,tz)
  launch        fn (gx,gy) mst

launchKernel' = launchKernel
#endif

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Fun -> [FunParam] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg _)    = sizeOf (undefined :: CUInt)
    size (FArg _)    = sizeOf (undefined :: CFloat)
    size (TArg _)    = 0
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f _ (TArg v) = nothingIfOk =<< cuParamSetTexRef f (-1) v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}

{# fun unsafe cuParamSetTexRef
  { useFun     `Fun'
  ,            `Int'    -- must be CU_PARAM_TR_DEFAULT (-1)
  , useTexture `Texture' } -> `Status' cToEnum #}

{-# LANGUAGE GADTs, CPP, ForeignFunctionInterface, EmptyDataDecls #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) [2009..2011] Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec (

  -- * Kernel Execution
  Fun(Fun), FunParam(..), FunAttribute(..), CacheConfig(..),
  requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun,
  launch, launchKernel

) where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))
import Foreign.CUDA.Driver.Texture              (Texture(..))

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM_)

#if CUDA_VERSION >= 3020
{-# DEPRECATED TArg "as of CUDA version 3.2" #-}
#endif
#if CUDA_VERSION >= 4000
{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch
      "use launchKernel instead" #-}
#endif

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Cache configuration preference
--
#if CUDA_VERSION < 3000
data CacheConfig
#else
{# enum CUfunc_cache_enum as CacheConfig
    { underscoreToCase }
    with prefix="CU_FUNC_CACHE_PREFER" deriving (Eq, Show) #}
#endif

-- |
-- Kernel function parameters
--
data FunParam where
  IArg :: Int             -> FunParam
  FArg :: Float           -> FunParam
  TArg :: Texture         -> FunParam
  VArg :: Storable a => a -> FunParam

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when
-- the given kernel function is launched.
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- On devices where the L1 cache and shared memory use the same hardware
-- resources, this sets the preferred cache configuration for the given device
-- function. This is only a preference; the driver is free to choose a different
-- configuration as required to execute the function.
--
-- Switching between configuration modes may insert a device-side
-- synchronisation point for streamed kernel launches.
--
setCacheConfigFun :: Fun -> CacheConfig -> IO ()
#if CUDA_VERSION < 3000
setCacheConfigFun _  _    = requireSDK 3.0 "setCacheConfigFun"
#else
setCacheConfigFun fn pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref

{# fun unsafe cuFuncSetCacheConfig
  { useFun    `Fun'
  , cFromEnum `CacheConfig' } -> `Status' cToEnum #}
#endif

-- |
-- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the
-- number of threads specified by a previous call to 'setBlockShape'. The launch
-- may also be associated with a specific 'Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block
-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes
-- of shared memory. The launch may also be associated with a specific 'Stream'.
--
launchKernel
    :: Fun                      -- ^ function to execute
    -> (Int,Int,Int)            -- ^ block grid dimension
    -> (Int,Int,Int)            -- ^ thread block shape
    -> Int                      -- ^ shared memory (bytes)
    -> Maybe Stream             -- ^ (optional) stream to execute in
    -> [FunParam]               -- ^ list of function parameters
    -> IO ()
#if CUDA_VERSION >= 4000
launchKernel fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ withMany withFP args
  $ \pa -> withArray pa
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr
  where
    st = fromMaybe (Stream nullPtr) mst

    withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b
    withFP p f = case p of
      IArg v -> with v (f . castPtr)
      FArg v -> with v (f . castPtr)
      VArg v -> with v (f . castPtr)
      TArg _ -> error "launchKernel: TArg is deprecated"

{# fun unsafe cuLaunchKernel
  { useFun    `Fun'
  ,           `Int', `Int', `Int'
  ,           `Int', `Int', `Int'
  ,           `Int'
  , useStream `Stream'
  , castPtr   `Ptr (Ptr FunParam)'
  , castPtr   `Ptr (Ptr ())'       } -> `Status' cToEnum #}

#else
launchKernel fn (gx,gy,_) (tx,ty,tz) sm mst args = do
  setParams     fn args
  setSharedSize fn (toInteger sm)
  setBlockShape fn (tx,ty,tz)
  launch        fn (gx,gy) mst
#endif

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Fun -> [FunParam] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg _)    = sizeOf (undefined::CUInt)
    size (FArg _)    = sizeOf (undefined::CFloat)
    size (TArg _)    = 0
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f _ (TArg v) = nothingIfOk =<< cuParamSetTexRef f (-1) v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}

{# fun unsafe cuParamSetTexRef
  { useFun     `Fun'
  ,            `Int'    -- must be CU_PARAM_TR_DEFAULT (-1)
  , useTexture `Texture' } -> `Status' cToEnum #}


sourceMarkNext/Prev should use 'Maybe'

sourceMarkNext/Prev should use 'Maybe'

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceMark
--
--  Author : Duncan Coutts, Andy Stewart
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 26 October 2003
--
--  Copyright (C) 2003-2005 Duncan Coutts, Axel Simon
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceMark (
-- * Description
-- | A 'SourceMark' marks a position in the text where you want to display additional info. It is based
-- on 'TextMark' and thus is still valid after the text has changed though its position may change.
--
-- 'SourceMarks' are organised in categories which you have to set when you create the mark. Each
-- category can have a pixbuf and a priority associated using @gtkSourceViewSetMarkCategoryPixbuf@
-- and @gtkSourceViewSetMarkCategoryPriority@. The pixbuf will be displayed in the margin at the
-- line where the mark residents if the 'showLineMarks' property is set to 'True'. If there are
-- multiple marks in the same line, the pixbufs will be drawn on top of each other. The mark with the
-- highest priority will be drawn on top.

-- * Types
  SourceMark,

-- * Methods
  castToSourceMark,
  sourceMarkGetCategory,
  sourceMarkNext,
  sourceMarkPrev
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- methods

-- | Returns the mark category
--
sourceMarkGetCategory :: SourceMark
                      -> IO String -- ^ returns the category of the 'SourceMark'
sourceMarkGetCategory mark = do
  strPtr <- {#call unsafe source_mark_get_category#} mark
  markType <- peekUTFString strPtr
  {#call unsafe g_free#} (castPtr strPtr)
  return markType

-- | Returns the next 'SourceMark' in the buffer or 'Nothing' if the mark was not added to a buffer. If there
-- is no next mark, 'Nothing' will be returned.
--
-- If category is 'Nothing', looks for marks of any category
--
sourceMarkNext :: SourceMark
               -> Maybe String  -- ^ @category@ a string specifying the mark category or 'Nothing'
               -> IO (Maybe SourceMark) -- ^ returns  the next 'SourceMark' or 'Nothing'
sourceMarkNext mark category =
    maybeNull (makeNewGObject mkSourceMark) $
    maybeWith withUTFString category $ {#call unsafe source_mark_next#} mark

-- | Returns the previous 'SourceMark' in the buffer or 'Nothing' if the mark was not added to a buffer. If
-- there is no previous mark, 'Nothing' is returned.
--
-- If category is 'Nothing', looks for marks of any category
--
sourceMarkPrev :: SourceMark
               -> Maybe String  -- ^ @category@ a string specifying the mark category or 'Nothing'
               -> IO (Maybe SourceMark) -- ^ returns  the previous 'SourceMark' or 'Nothing'
sourceMarkPrev mark category =
    maybeNull (makeNewGObject mkSourceMark) $
    maybeWith withUTFString category $ {#call unsafe source_mark_prev#} mark

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceMark
--
--  Author : Duncan Coutts, Andy Stewart
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 26 October 2003
--
--  Copyright (C) 2003-2005 Duncan Coutts, Axel Simon
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceMark (
-- * Description
-- | A 'SourceMark' marks a position in the text where you want to display additional info. It is based
-- on 'TextMark' and thus is still valid after the text has changed though its position may change.
--
-- 'SourceMarks' are organised in categories which you have to set when you create the mark. Each
-- category can have a pixbuf and a priority associated using @gtkSourceViewSetMarkCategoryPixbuf@
-- and @gtkSourceViewSetMarkCategoryPriority@. The pixbuf will be displayed in the margin at the
-- line where the mark residents if the 'showLineMarks' property is set to 'True'. If there are
-- multiple marks in the same line, the pixbufs will be drawn on top of each other. The mark with the
-- highest priority will be drawn on top.

-- * Types
  SourceMark,

-- * Methods
  castToSourceMark,
  sourceMarkGetCategory,
  sourceMarkNext,
  sourceMarkPrev
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- methods

-- | Returns the mark category
--
sourceMarkGetCategory :: SourceMark
                      -> IO String -- ^ returns the category of the 'SourceMark'
sourceMarkGetCategory mark = do
  strPtr <- {#call unsafe source_mark_get_category#} mark
  markType <- peekUTFString strPtr
  {#call unsafe g_free#} (castPtr strPtr)
  return markType

-- | Returns the next 'SourceMark' in the buffer or 'Nothing' if the mark was not added to a buffer. If there
-- is no next mark, 'Nothing' will be returned.
--
-- If category is 'Nothing', looks for marks of any category
--
sourceMarkNext :: SourceMark
               -> String  -- ^ @category@ a string specifying the mark category or 'Nothing'
               -> IO SourceMark -- ^ returns  the next 'SourceMark' or 'Nothing'
sourceMarkNext mark category = makeNewGObject mkSourceMark $
  withUTFString category $ {#call unsafe source_mark_next#} mark

-- | Returns the previous 'SourceMark' in the buffer or 'Nothing' if the mark was not added to a buffer. If
-- there is no previous mark, 'Nothing' is returned.
--
-- If category is 'Nothing', looks for marks of any category
--
sourceMarkPrev :: SourceMark
               -> String  -- ^ @category@ a string specifying the mark category or 'Nothing'
               -> IO SourceMark -- ^ returns  the previous 'SourceMark' or 'Nothing'
sourceMarkPrev mark category = makeNewGObject mkSourceMark $
  withUTFString category $ {#call unsafe source_mark_prev#} mark


Fix hierarchy docs for 'DoubleWindow'.

Fix hierarchy docs for 'DoubleWindow'.

{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.DoubleWindow
where
#include "Fl_C.h"
#include "Fl_Double_WindowC.h"
import Foreign
import Foreign.C
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Hierarchy

{# fun Fl_DerivedDouble_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) DoubleWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr

{# fun Fl_DerivedDouble_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> hide' windowPtr

{# fun Fl_DerivedDouble_Window_show as windowShow' {id `Ptr ()'} -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (ShowWidget ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window (\p -> windowShow' p)

{#fun Fl_DerivedDouble_Window_handle as windowHandle'
      { id `Ptr ()', id `CInt' } -> `Int' #}
instance (impl ~ (Event -> IO (Either UnknownEvent ()))) => Op (Handle ()) DoubleWindow orig impl where
  runOp _ _ window event = withRef window (\p -> windowHandle' p (fromIntegral . fromEnum $ event)) >>= return  . successOrUnknownEvent

{# fun Fl_DerivedDouble_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle -> IO ())) => Op (Resize ()) DoubleWindow orig impl where
  runOp _ _ window rectangle = withRef window $ \windowPtr -> do
                                 let (x_pos,y_pos,w_pos,h_pos) = fromRectangle rectangle
                                 resize' windowPtr x_pos y_pos w_pos h_pos
{# fun Fl_DerivedDouble_Window_flush as flush' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (Flush ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> flush' windowPtr

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Base.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Window"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.DoubleWindow"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.DoubleWindow"
-- @

-- $functions
-- @
-- destroy :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- flush :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- handle :: 'Ref' 'DoubleWindow' -> 'Event' -> 'IO' ('Either' 'UnknownEvent' ())
--
-- hide :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- resize :: 'Ref' 'DoubleWindow' -> 'Rectangle' -> 'IO' ()
--
-- showWidget :: 'Ref' 'DoubleWindow' -> 'IO' ()
-- @

{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.DoubleWindow
where
#include "Fl_C.h"
#include "Fl_Double_WindowC.h"
import Foreign
import Foreign.C
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Hierarchy

{# fun Fl_DerivedDouble_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) DoubleWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr

{# fun Fl_DerivedDouble_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> hide' windowPtr

{# fun Fl_DerivedDouble_Window_show as windowShow' {id `Ptr ()'} -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (ShowWidget ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window (\p -> windowShow' p)

{#fun Fl_DerivedDouble_Window_handle as windowHandle'
      { id `Ptr ()', id `CInt' } -> `Int' #}
instance (impl ~ (Event -> IO (Either UnknownEvent ()))) => Op (Handle ()) DoubleWindow orig impl where
  runOp _ _ window event = withRef window (\p -> windowHandle' p (fromIntegral . fromEnum $ event)) >>= return  . successOrUnknownEvent

{# fun Fl_DerivedDouble_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle -> IO ())) => Op (Resize ()) DoubleWindow orig impl where
  runOp _ _ window rectangle = withRef window $ \windowPtr -> do
                                 let (x_pos,y_pos,w_pos,h_pos) = fromRectangle rectangle
                                 resize' windowPtr x_pos y_pos w_pos h_pos
{# fun Fl_DerivedDouble_Window_flush as flush' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (Flush ()) DoubleWindow orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> flush' windowPtr

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Base.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Window"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.DoubleWindow"
-- @

-- $functions
-- @
-- destroy :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- flush :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- handle :: 'Ref' 'DoubleWindow' -> 'Event' -> 'IO' ('Either' 'UnknownEvent' ())
--
-- hide :: 'Ref' 'DoubleWindow' -> 'IO' ()
--
-- resize :: 'Ref' 'DoubleWindow' -> 'Rectangle' -> 'IO' ()
--
-- showWidget :: 'Ref' 'DoubleWindow' -> 'IO' ()
-- @


[project @ 2003-11-02 23:57:07 by as49]

[project @ 2003-11-02 23:57:07 by as49]

Added marshalling functions to create GLists and GSLists.

darcs-hash:20031102235707-d90cf-a474609cf76d924c74e02aa158d9d652ed3f6a03.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Axel Simon
--
--  Created: 19 March 2002
--
--  Version $Revision: 1.8 $ from $Date: 2003/11/02 23:57:07 $
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * Defines functions to extract data from a GList and to produce a GList from
--   a list of pointers.
--
-- * The same for GSList.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--
module GList(
  ptrToInt,
  GList,
  fromGList,
  toGList,
  GSList,
  readGSList,
  fromGSList,
  fromGSListRev,
  toGSList
  ) where

import Monad	(liftM)
import FFI
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

{#pointer * GList#}
{#pointer * GSList#}

-- methods

-- Convert a pointer to an Int.
--
ptrToInt :: Ptr a -> Int
ptrToInt ptr = minusPtr ptr nullPtr

-- Turn a GList into a list of pointers.
--
fromGList :: GList -> IO [Ptr a]
fromGList glist = do
    glist' <- {#call unsafe list_reverse#} glist
    extractList glist' []
  where
    extractList gl xs
      | gl==nullPtr = return xs
      | otherwise   = do
	x <- {#get GList.data#} gl
	gl' <- {#call unsafe list_delete_link#} gl gl
	extractList gl' (castPtr x:xs)

-- Turn a GSList into a list of pointers but don't destroy the list.
--
readGSList :: GSList -> IO [Ptr a]
readGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#get GSList->next#} gslist
    xs <- readGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers.
--
fromGSList :: GSList -> IO [Ptr a]
fromGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#call unsafe slist_delete_link#} gslist gslist
    xs <- fromGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers and reverse it.
--
fromGSListRev :: GSList -> IO [Ptr a]
fromGSListRev gslist =
  extractList gslist []
  where
    extractList gslist xs
      | gslist==nullPtr = return xs
      | otherwise	= do
	x <- {#get GSList->data#} gslist
	gslist' <- {#call unsafe slist_delete_link#} gslist gslist
	extractList gslist' (castPtr x:xs)

-- Convert an Int into a pointer.
--
intToPtr :: Int -> Ptr a
intToPtr int = plusPtr nullPtr int

-- Turn a list of something into a GList.
--
toGList :: [Ptr a] -> IO GList
toGList xs = makeList nullPtr xs
  where
    -- makeList :: GList -> [Ptr a] -> IO GList
    makeList current (x:xs) = do
      newHead <- {#call unsafe list_prepend#} current (castPtr x)
      makeList newHead xs
    makeList current [] = return current

-- Turn a list of something into a GSList.
--
toGSList :: [Ptr a] -> IO GSList
toGSList xs = makeList nullPtr xs
  where
    -- makeList :: GSList -> [Ptr a] -> IO GSList
    makeList current (x:xs) = do
      newHead <- {#call unsafe slist_prepend#} current (castPtr x)
      makeList newHead xs
    makeList current [] = return current

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Axel Simon
--
--  Created: 19 March 2002
--
--  Version $Revision: 1.7 $ from $Date: 2003/07/09 22:42:44 $
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * Define functions to extract data from a GList and to produce a GList from
--   a list of pointers.
--
-- * Define functions to extract data from a GSList.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * Figure out if we ever need to generate a GList.
--
module GList(
  ptrToInt,
  GList,
  fromGList,
  -- toGList,
  GSList,
  readGSList,
  fromGSList,
  fromGSListRev
  ) where

import Monad	(liftM)
import FFI
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

{#pointer * GList#}
{#pointer * GSList#}

-- methods

-- Convert a pointer to an Int.
--
ptrToInt :: Ptr a -> Int
ptrToInt ptr = minusPtr ptr nullPtr

-- Turn a GList into a list of pointers.
--
fromGList :: GList -> IO [Ptr a]
fromGList glist = do
    glist' <- {#call unsafe list_reverse#} glist
    extractList glist' []
  where
    extractList gl xs
      | gl==nullPtr = return xs
      | otherwise   = do
	x <- {#get GList.data#} gl
	gl' <- {#call unsafe list_delete_link#} gl gl
	extractList gl' (castPtr x:xs)

-- Turn a GSList into a list of pointers but don't destroy the list.
--
readGSList :: GSList -> IO [Ptr a]
readGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#get GSList->next#} gslist
    xs <- readGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers.
--
fromGSList :: GSList -> IO [Ptr a]
fromGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#call unsafe slist_delete_link#} gslist gslist
    xs <- fromGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers and reverse it.
--
fromGSListRev :: GSList -> IO [Ptr a]
fromGSListRev gslist =
  extractList gslist []
  where
    extractList gslist xs
      | gslist==nullPtr = return xs
      | otherwise	= do
	x <- {#get GSList->data#} gslist
	gslist' <- {#call unsafe slist_delete_link#} gslist gslist
	extractList gslist' (castPtr x:xs)

-- Convert an Int into a pointer.
--
intToPtr :: Int -> Ptr a
intToPtr int = plusPtr nullPtr int

-- Turn a list of something into a GList.
--
toGList :: [a] -> (a -> Ptr b) -> IO GList
toGList xs conv = makeList nullPtr xs
  where
    -- makeList :: GList -> [a] -> IO GList
    makeList current (x:xs) = do
      newHead <- {#call unsafe list_prepend#} current ((castPtr.conv) x)
      makeList newHead xs
    makeList current [] = return current


Cleaned up description of the Matrix datatype.

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation.
--
--  The Matrix type represents a 2x2 transformation matrix along with a
--  translation vector. @Matrix a1 a2 b1 b2 c1 c2@ describes the
--  transformation of a point with coordinates x,y that is defined by
--
--  >   / x' \  =  / a1 b1 \  / x \  + / c1 \
--  >   \ y' /     \ a2 b2 /  \ y /    \ c2 /
--
--  or
--
--  >   x' =  a1 * x + b1 * y + c1
--  >   y' =  a2 * x + b2 * y + c2

data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yy - yx*xy

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yy - yx*xy