Fix gtksourceview2

Fix gtksourceview2

{-# 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
--  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.SourceView (
-- * Description
-- | 'SourceView' is the main object of the gtksourceview library. It provides a text view which syntax
-- highlighting, undo/redo and text marks. Use a 'SourceBuffer' to display text with a 'SourceView'.

-- * Types
  SourceView,
  SourceViewClass,

-- * Enums
  SourceSmartHomeEndType(..),
  SourceDrawSpacesFlags(..),
  SourceViewGutterPosition (..),

-- * Methods
  castToSourceView,
  gTypeSourceView,
  toSourceView,
  sourceViewNew,
  sourceViewNewWithBuffer,
  sourceViewSetAutoIndent,
  sourceViewGetAutoIndent,
  sourceViewSetIndentOnTab,
  sourceViewGetIndentOnTab,
  sourceViewSetIndentWidth,
  sourceViewGetIndentWidth,
  sourceViewSetInsertSpacesInsteadOfTabs,
  sourceViewGetInsertSpacesInsteadOfTabs,
  sourceViewSetSmartHomeEnd,
  sourceViewGetSmartHomeEnd,
#if GTK_MAJOR_VERSION < 3
  sourceViewSetMarkCategoryPriority,
  sourceViewGetMarkCategoryPriority,
  sourceViewSetMarkCategoryIconFromPixbuf,
  sourceViewSetMarkCategoryIconFromStock,
  sourceViewSetMarkCategoryIconFromIconName,
  sourceViewSetMarkCategoryBackground,
  sourceViewGetMarkCategoryBackground,
#endif
  sourceViewSetHighlightCurrentLine,
  sourceViewGetHighlightCurrentLine,
  sourceViewSetShowLineMarks,
  sourceViewGetShowLineMarks,
  sourceViewSetShowLineNumbers,
  sourceViewGetShowLineNumbers,
  sourceViewSetShowRightMargin,
  sourceViewGetShowRightMargin,
  sourceViewSetRightMarginPosition,
  sourceViewGetRightMarginPosition,
  sourceViewSetTabWidth,
  sourceViewGetTabWidth,
  sourceViewSetDrawSpaces,
  sourceViewGetDrawSpaces,
  sourceViewGetGutter,

#if GTK_MAJOR_VERSION >= 3
#if MIN_VERSION_gtksourceview_3_0(3, 16, 0)
  sourceViewIndentLines,
  sourceViewUnindentLines,
#endif
  sourceViewGetVisualColumn,
  sourceViewSetMarkAttributes,
  sourceViewGetMarkAttributes,
#endif

-- * Attributes
  sourceViewAutoIndent,
  sourceViewCompletion,
  sourceViewDrawSpaces,
  sourceViewHighlightCurrentLine,
  sourceViewIndentOnTab,
  sourceViewIndentWidth,
  sourceViewInsertSpacesInsteadOfTabs,
  sourceViewRightMarginPosition,
  sourceViewShowLineNumbers,
  sourceViewShowRightMargin,
  sourceViewSmartHomeEnd,
  sourceViewTabWidth,

-- * Signals
  sourceViewUndo,
  sourceViewRedo,
  sourceViewMoveLines,
  sourceViewShowCompletion,
  sourceViewLineMarkActivated,

-- * Deprecated
#if GTK_MAJOR_VERSION < 3
#ifndef DISABLE_DEPRECATED
  sourceViewSetMarkCategoryPixbuf,
  sourceViewGetMarkCategoryPixbuf,
#endif
#endif
  ) where

import Control.Applicative
import Prelude
import Control.Monad    (liftM)
import Control.Monad.Reader ( runReaderT )
import Data.Maybe    (fromMaybe)

import Graphics.UI.Gtk.Abstract.Object (makeNewObject)
import Graphics.UI.Gtk.Abstract.Widget (Color)
import Graphics.UI.Gtk.Gdk.EventM (EventM, EAny)
import Graphics.UI.Gtk.Multiline.TextView (TextWindowType (..))
import Graphics.UI.Gtk.SourceView.Enums
import Graphics.UI.GtkInternals  ( TextIter, mkTextIterCopy )
import System.Glib.GObject      (wrapNewGObject, makeNewGObject)
import System.Glib.Attributes
import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Flags (toFlags, fromFlags)

{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import System.Glib.Properties#}

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

-- | Create a new 'SourceView' widget with a default 'SourceBuffer'.
--
sourceViewNew :: IO SourceView
sourceViewNew = makeNewObject mkSourceView $ liftM castPtr
  {#call unsafe source_view_new#}

-- | Create a new 'SourceView'
-- widget with the given 'SourceBuffer'.
--
sourceViewNewWithBuffer :: SourceBuffer -> IO SourceView
sourceViewNewWithBuffer sb = makeNewObject mkSourceView $ liftM castPtr $
  {#call source_view_new_with_buffer#} sb

-- | If 'True' auto indentation of text is enabled.
--
sourceViewSetAutoIndent :: SourceViewClass sv => sv
                        -> Bool  -- ^ @enable@ whether to enable auto indentation.
                        -> IO ()
sourceViewSetAutoIndent sv enable =
  {#call source_view_set_auto_indent#} (toSourceView sv) (fromBool enable)

-- | Returns whether auto indentation of text is enabled.
--
sourceViewGetAutoIndent :: SourceViewClass sv => sv
                        -> IO Bool  -- ^ returns 'True' if auto indentation is enabled.
sourceViewGetAutoIndent sv = liftM toBool $
  {#call unsafe source_view_get_auto_indent#} (toSourceView sv)

-- | If 'True', when the tab key is pressed and there is a selection, the selected text is indented of one
-- level instead of being replaced with the \t characters. Shift+Tab unindents the selection.
--
sourceViewSetIndentOnTab :: SourceViewClass sv => sv
                         -> Bool  -- ^ @enable@ whether to indent a block when tab is pressed.
                         -> IO ()
sourceViewSetIndentOnTab sv enable =
  {#call source_view_set_indent_on_tab#} (toSourceView sv) (fromBool enable)

-- | Returns whether when the tab key is pressed the current selection should get indented instead of
-- replaced with the \t character.
--
sourceViewGetIndentOnTab :: SourceViewClass sv => sv
                         -> IO Bool  -- ^ returns 'True' if the selection is indented when tab is pressed.
sourceViewGetIndentOnTab sv = liftM toBool $
  {#call unsafe source_view_get_indent_on_tab#} (toSourceView sv)

-- | Sets the number of spaces to use for each step of indent. If width is -1, the value of the
-- 'tabWidth' property will be used.
--
sourceViewSetIndentWidth :: SourceViewClass sv => sv
                         -> Int  -- ^ @width@ indent width in characters.
                         -> IO ()
sourceViewSetIndentWidth sv width =
  {#call source_view_set_indent_width#} (toSourceView sv) (fromIntegral width)

-- | Returns the number of spaces to use for each step of indent. See 'sourceViewSetIndentWidth'
-- for details.
--
sourceViewGetIndentWidth :: SourceViewClass sv => sv
                         -> IO Int -- ^ returns indent width.
sourceViewGetIndentWidth sv = liftM fromIntegral $
  {#call unsafe source_view_get_indent_width#} (toSourceView sv)

-- | If 'True' any tabulator character inserted is replaced by a group of space characters.
--
sourceViewSetInsertSpacesInsteadOfTabs :: SourceViewClass sv => sv
                                       -> Bool  -- ^ @enable@ whether to insert spaces instead of tabs.
                                       -> IO ()
sourceViewSetInsertSpacesInsteadOfTabs sv enable =
  {#call source_view_set_insert_spaces_instead_of_tabs#} (toSourceView sv) (fromBool enable)

-- | Returns whether when inserting a tabulator character it should be replaced by a group of space
-- characters.
--
sourceViewGetInsertSpacesInsteadOfTabs :: SourceViewClass sv => sv
                                       -> IO Bool  -- ^ returns 'True' if spaces are inserted instead of tabs.
sourceViewGetInsertSpacesInsteadOfTabs sv = liftM toBool $
  {#call unsafe source_view_get_insert_spaces_instead_of_tabs#} (toSourceView sv)

-- | Set the desired movement of the cursor when HOME and END keys are pressed.
--
sourceViewSetSmartHomeEnd :: SourceViewClass sv => sv
                          -> SourceSmartHomeEndType  -- ^ @smartHe@ the desired behavior among 'SourceSmartHomeEndType'.
                          -> IO ()
sourceViewSetSmartHomeEnd sv newVal =
  {#call source_view_set_smart_home_end#} (toSourceView sv) (fromIntegral $ fromEnum newVal)

-- | Returns a 'SourceSmartHomeEndType' end value specifying how the cursor will move when HOME and END
-- keys are pressed.
--
sourceViewGetSmartHomeEnd :: SourceViewClass sv => sv
                          -> IO SourceSmartHomeEndType -- ^ returns a 'SourceSmartHomeEndTypeend' value.
sourceViewGetSmartHomeEnd sv = liftM (toEnum . fromIntegral) $
  {#call unsafe source_view_get_smart_home_end#} (toSourceView sv)

-- | If show is 'True' the current line is highlighted.
--
sourceViewSetHighlightCurrentLine :: SourceViewClass sv => sv
                                  -> Bool  -- ^ @show@ whether to highlight the current line
                                  -> IO ()
sourceViewSetHighlightCurrentLine sv newVal =
  {#call source_view_set_highlight_current_line#} (toSourceView sv) (fromBool newVal)

-- | Returns whether the current line is highlighted
--
sourceViewGetHighlightCurrentLine :: SourceViewClass sv => sv
                                  -> IO Bool  -- ^ returns 'True' if the current line is highlighted.
sourceViewGetHighlightCurrentLine sv = liftM toBool $
  {#call unsafe source_view_get_highlight_current_line#} (toSourceView sv)

-- | If 'True' line marks will be displayed beside the text.
--
sourceViewSetShowLineMarks :: SourceViewClass sv => sv
                           -> Bool  -- ^ @show@ whether line marks should be displayed.
                           -> IO ()
sourceViewSetShowLineMarks sv newVal =
  {#call source_view_set_show_line_marks#} (toSourceView sv) (fromBool newVal)

-- | Returns whether line marks are displayed beside the text.
--
sourceViewGetShowLineMarks :: SourceViewClass sv => sv
                           -> IO Bool  -- ^ returns 'True' if the line marks are displayed.
sourceViewGetShowLineMarks sv = liftM toBool $
  {#call unsafe source_view_get_show_line_marks#} (toSourceView sv)

-- | If 'True' line numbers will be displayed beside the text.
--
sourceViewSetShowLineNumbers :: SourceViewClass sv => sv
                             -> Bool  -- ^ @show@ whether line numbers should be displayed.
                             -> IO ()
sourceViewSetShowLineNumbers sv newVal =
  {#call source_view_set_show_line_numbers#} (toSourceView sv) (fromBool newVal)

-- | Returns whether line numbers are displayed beside the text.
--
sourceViewGetShowLineNumbers :: SourceViewClass sv => sv
                             -> IO Bool  -- ^ returns 'True' if the line numbers are displayed.
sourceViewGetShowLineNumbers sv = liftM toBool $
  {#call unsafe source_view_get_show_line_numbers#} (toSourceView sv)

-- | If 'True' a right margin is displayed
--
sourceViewSetShowRightMargin :: SourceViewClass sv => sv
                             -> Bool  -- ^ @show@ whether to show a right margin.
                             -> IO ()
sourceViewSetShowRightMargin sv newVal =
  {#call source_view_set_show_right_margin#} (toSourceView sv) (fromBool newVal)

-- | Returns whether a right margin is displayed.
--
sourceViewGetShowRightMargin :: SourceViewClass sv => sv
                             -> IO Bool -- ^ returns 'True' if the right margin is shown.
sourceViewGetShowRightMargin sv = liftM toBool $
  {#call source_view_get_show_right_margin#} (toSourceView sv)

-- | Sets the position of the right margin in the given view.
--
sourceViewSetRightMarginPosition :: SourceViewClass sv => sv
                                 -> Word -- ^ @pos@  the width in characters where to position the right margin.
                                 -> IO ()
sourceViewSetRightMarginPosition sv margin =
  {#call source_view_set_right_margin_position#} (toSourceView sv) (fromIntegral margin)

-- | Gets the position of the right margin in the given view.
--
sourceViewGetRightMarginPosition :: SourceViewClass sv => sv
                                 -> IO Int  -- ^ returns the position of the right margin.
sourceViewGetRightMarginPosition sv = liftM fromIntegral $
  {#call unsafe source_view_get_right_margin_position#} (toSourceView sv)

-- | Sets the width of tabulation in characters.
--
sourceViewSetTabWidth :: SourceViewClass sv => sv
                      -> Int  -- ^ @width@ width of tab in characters.
                      -> IO ()
sourceViewSetTabWidth sv width =
  {#call source_view_set_tab_width#} (toSourceView sv) (fromIntegral width)

-- | Returns the width of tabulation in characters.
--
sourceViewGetTabWidth :: SourceViewClass sv => sv
                      -> IO Int -- ^ returns width of tab.
sourceViewGetTabWidth sv = liftM fromIntegral $
  {#call unsafe source_view_get_tab_width#} (toSourceView sv)

-- | Set if and how the spaces should be visualized. Specifying flags as [] will disable display of
-- spaces.
sourceViewSetDrawSpaces :: SourceViewClass sv => sv
                        -> [SourceDrawSpacesFlags] -- ^ @flags@ 'SourceDrawSpacesFlags' specifing how white spaces should be displayed
                        -> IO ()
sourceViewSetDrawSpaces view flags =
  {#call gtk_source_view_set_draw_spaces #}
    (toSourceView view)
    (fromIntegral $ fromFlags flags)

-- | Returns the 'SourceDrawSpacesFlags' specifying if and how spaces should be displayed for this view.
sourceViewGetDrawSpaces :: SourceViewClass sv => sv
                        -> IO [SourceDrawSpacesFlags] -- ^ returns the 'SourceDrawSpacesFlags', [] if no spaces should be drawn.
sourceViewGetDrawSpaces view =
  liftM (toFlags . fromIntegral) $
  {#call gtk_source_view_get_draw_spaces #}
     (toSourceView view)

-- | Returns the 'SourceGutter' object associated with @windowType@ for view. Only 'TextWindowLeft'
-- and 'TextWindowRight' are supported, respectively corresponding to the left and right
-- gutter. The line numbers and mark category icons are rendered in the gutter corresponding to
-- 'TextWindowLeft'.
sourceViewGetGutter :: SourceViewClass sv => sv
                    -> TextWindowType  -- ^ @windowType@ the gutter window type
                    -> IO SourceGutter
sourceViewGetGutter sv windowType =
  makeNewGObject mkSourceGutter $
  {#call gtk_source_view_get_gutter #}
    (toSourceView sv)
    (fromIntegral $ fromEnum windowType)

#if GTK_MAJOR_VERSION < 3
-- | Set the priority for the given mark category. When there are multiple marks on the same line, marks
-- of categories with higher priorities will be drawn on top.
--
sourceViewSetMarkCategoryPriority :: (SourceViewClass sv, GlibString string) => sv
                                  -> string  -- ^ @category@ a mark category.
                                  -> Int  -- ^ @priority@ the priority for the category
                                  -> IO ()
sourceViewSetMarkCategoryPriority sv markerType priority = withUTFString markerType $ \strPtr ->
  {#call source_view_set_mark_category_priority#} (toSourceView sv) strPtr (fromIntegral priority)

-- | Gets the priority which is associated with the given category.
--
sourceViewGetMarkCategoryPriority :: (SourceViewClass sv, GlibString string) => sv
                                  -> string  -- ^ @category@ a mark category.
                                  -> IO Int -- ^ returns  the priority or if category exists but no priority was set, it defaults to 0.
sourceViewGetMarkCategoryPriority sv markerType = withUTFString markerType $ \strPtr ->
  liftM fromIntegral $
  {#call unsafe source_view_get_mark_category_priority#} (toSourceView sv) strPtr

-- | Sets the icon to be used for category to pixbuf. If pixbuf is 'Nothing', the icon is unset.
sourceViewSetMarkCategoryIconFromPixbuf :: (SourceViewClass sv, GlibString string) => sv
                                        -> string -- ^ @category@ a mark category.
                                        -> Maybe Pixbuf -- ^ @pixbuf@   a 'Pixbuf' or 'Nothing'.
                                        -> IO ()
sourceViewSetMarkCategoryIconFromPixbuf sv category pixbuf =
  withUTFString category $ \categoryPtr ->
  {#call gtk_source_view_set_mark_category_icon_from_pixbuf #}
     (toSourceView sv)
     categoryPtr
     (fromMaybe (Pixbuf nullForeignPtr) pixbuf)

-- | Sets the icon to be used for category to the stock item @stockId@. If @stockId@ is 'Nothing', the icon is
-- unset.
sourceViewSetMarkCategoryIconFromStock :: (SourceViewClass sv, GlibString string) => sv
                                       -> string -- ^ @category@ a mark category.
                                       -> Maybe string -- ^ @stockId@ the stock id or 'Nothing'.
                                       -> IO ()
sourceViewSetMarkCategoryIconFromStock sv category stockId =
  withUTFString category $ \categoryPtr ->
  maybeWith withUTFString stockId $ \stockIdPtr ->
  {#call gtk_source_view_set_mark_category_icon_from_stock #}
    (toSourceView sv)
    categoryPtr
    stockIdPtr

-- | Sets the icon to be used for category to the named theme item name. If name is 'Nothing', the icon is
-- unset.
sourceViewSetMarkCategoryIconFromIconName :: (SourceViewClass sv, GlibString string) => sv
                                       -> string -- ^ @category@ a mark category.
                                       -> Maybe string -- ^ @name@     the themed icon name or 'Nothing'.
                                       -> IO ()
sourceViewSetMarkCategoryIconFromIconName sv category name =
  withUTFString category $ \categoryPtr ->
  maybeWith withUTFString name $ \namePtr ->
  {#call gtk_source_view_set_mark_category_icon_from_icon_name #}
    (toSourceView sv)
    categoryPtr
    namePtr

-- | Sets given background color for mark category. If color is 'Nothing', the background color is unset.
sourceViewSetMarkCategoryBackground :: (SourceViewClass sv, GlibString string) => sv
                                    -> string -- ^ @category@ a mark category.
                                    -> Maybe Color  -- ^ @color@    background color or 'Nothing' to unset it.
                                    -> IO ()
sourceViewSetMarkCategoryBackground sv category color =
  let withMB :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
      withMB Nothing f = f nullPtr
      withMB (Just x) f = with x f
  in withUTFString category $ \categoryPtr ->
     withMB color $ \colorPtr ->
     {#call gtk_source_view_set_mark_category_background #}
       (toSourceView sv)
       categoryPtr
       (castPtr colorPtr)

-- | Gets the background color associated with given category.
sourceViewGetMarkCategoryBackground :: (SourceViewClass sv, GlibString string) => sv
                                    -> string -- ^ @category@ a mark category.
                                    -> Color -- ^ @dest@     destination 'Color' structure to fill in.
                                    -> IO Bool -- ^ returns  'True' if background color for category was set and dest is set to a valid color, or 'False' otherwise.
sourceViewGetMarkCategoryBackground sv category color =
    liftM toBool $
    withUTFString category $ \ categoryPtr ->
    with color $ \ colorPtr ->
    {#call gtk_source_view_get_mark_category_background #}
      (toSourceView sv)
      categoryPtr
      (castPtr colorPtr)
#endif

#if GTK_MAJOR_VERSION >= 3
#if MIN_VERSION_gtksourceview_3_0(3, 16, 0)
-- | Insert one indentation level at the beginning of the specified lines.
--
sourceViewIndentLines :: SourceViewClass sv
                      => sv
                      -> TextIter -- ^ @start@ the first line to indent.
                      -> TextIter -- ^ @end@ the last line to indent.
                      -> IO ()
sourceViewIndentLines sv start end =
    {# call gtk_source_view_indent_lines #}
      (toSourceView sv)
      start
      end

-- | Removes one indentation level at the beginning of the specified lines.
--
sourceViewUnindentLines :: SourceViewClass sv
                        => sv
                        -> TextIter -- ^ @start@ the first line to indent.
                        -> TextIter -- ^ @end@ the last line to indent.
                        -> IO ()
sourceViewUnindentLines sv start end =
    {# call gtk_source_view_unindent_lines #}
      (toSourceView sv)
      start
      end
#endif

-- | Determines the visual column at iter taking into consideration the `tabWidth` of the view.
--
sourceViewGetVisualColumn :: SourceViewClass sv
                          => sv
                          -> TextIter -- ^ @iter@ a position in view.
                          -> IO Word
sourceViewGetVisualColumn sv iter = fromIntegral <$>
    {# call gtk_source_view_get_visual_column #}
      (toSourceView sv)
      iter

-- | Sets attributes and priority for the category.
--
sourceViewSetMarkAttributes :: (SourceViewClass sv, GlibString category, SourceMarkAttributesClass attributes)
                            => sv
                            -> category
                            -> Maybe attributes
                            -> Int
                            -> IO ()
sourceViewSetMarkAttributes sv category attributes priority =
  withUTFString category $ \categoryPtr ->
    {# call gtk_source_view_set_mark_attributes #}
      (toSourceView sv)
      categoryPtr
      (maybe (SourceMarkAttributes nullForeignPtr) toSourceMarkAttributes attributes)
      (fromIntegral priority)

-- | Gets attributes and priority for the category
--
sourceViewGetMarkAttributes :: (SourceViewClass sv, GlibString category)
                            => sv
                            -> category
                            -> IO (Maybe (SourceMarkAttributes, Int))
sourceViewGetMarkAttributes sv category =
  withUTFString category $ \categoryPtr ->
  alloca $ \ priority -> do
    attributes <- maybeNull (makeNewObject mkSourceMarkAttributes) $
                        {# call gtk_source_view_get_mark_attributes #}
                          (toSourceView sv)
                          categoryPtr
                          priority
    case attributes of
        Just a -> do
            p <- peek priority
            return $ Just (a, fromIntegral p)
        Nothing -> return Nothing
#endif

-- | Whether to enable auto indentation.
--
-- Default value: 'False'
--
sourceViewAutoIndent :: SourceViewClass sv => Attr sv Bool
sourceViewAutoIndent = newAttrFromBoolProperty "auto-indent"

-- | The completion object associated with the view.
--
sourceViewCompletion :: SourceViewClass sv => ReadAttr sv SourceCompletion
sourceViewCompletion = readAttrFromObjectProperty "completion"
                       {#call pure unsafe gtk_source_completion_get_type #}

-- | Set if and how the spaces should be visualized.
--
sourceViewDrawSpaces :: SourceViewClass sv => Attr sv [SourceDrawSpacesFlags]
sourceViewDrawSpaces = newAttrFromFlagsProperty "draw-spaces" {#call fun gtk_source_draw_spaces_flags_get_type#}

-- | Whether to highlight the current line.
--
-- Default value: 'False'
--
sourceViewHighlightCurrentLine :: SourceViewClass sv => Attr sv Bool
sourceViewHighlightCurrentLine = newAttrFromBoolProperty "highlight-current-line"

-- | Whether to indent the selected text when the tab key is pressed.
--
-- Default value: 'True'
--
sourceViewIndentOnTab :: SourceViewClass sv => Attr sv Bool
sourceViewIndentOnTab = newAttrFromBoolProperty "indent-on-tab"

-- | Width of an indentation step expressed in number of spaces.
--
-- Allowed values: [GMaxulong,32]
--
-- Default value: -1
--
sourceViewIndentWidth :: SourceViewClass sv => Attr sv Int
sourceViewIndentWidth = newAttrFromIntProperty "indent-width"

-- | Whether to insert spaces instead of tabs.
--
-- Default value: 'False'
--
sourceViewInsertSpacesInsteadOfTabs :: SourceViewClass sv => Attr sv Bool
sourceViewInsertSpacesInsteadOfTabs = newAttrFromBoolProperty "insert-spaces-instead-of-tabs"

-- | Position of the right margin.
--
-- Allowed values: [1,200]
--
-- Default value: 80
--
sourceViewRightMarginPosition :: SourceViewClass sv => Attr sv Int
sourceViewRightMarginPosition = newAttrFromUIntProperty "right-margin-position"

-- | Whether to display line numbers
--
-- Default value: 'False'
--
sourceViewShowLineNumbers :: SourceViewClass sv => Attr sv Bool
sourceViewShowLineNumbers = newAttrFromBoolProperty "show-line-numbers"

-- | Whether to display line mark pixbufs
--
-- Default value: 'False'
--
sourceViewShowRightMargin :: SourceViewClass sv => Attr sv Bool
sourceViewShowRightMargin = newAttrFromBoolProperty "show-right-margin"

-- | Set the behavior of the HOME and END keys.
--
-- Default value: 'SourceSmartHomeEndDisabled'
--
-- Since 2.0
--
sourceViewSmartHomeEnd :: SourceViewClass sv => Attr sv SourceSmartHomeEndType
sourceViewSmartHomeEnd = newAttrFromEnumProperty "smart-home-end" {#call fun gtk_source_smart_home_end_type_get_type#}

-- | Width of an tab character expressed in number of spaces.
--
-- Allowed values: [1,32]
--
-- Default value: 8
--
sourceViewTabWidth :: SourceViewClass sv => Attr sv Int
sourceViewTabWidth = newAttrFromUIntProperty "tab-width"

-- |
--
sourceViewUndo :: SourceViewClass sv => Signal sv (IO ())
sourceViewUndo = Signal $ connect_NONE__NONE "undo"

-- |
--
sourceViewRedo :: SourceViewClass sv => Signal sv (IO ())
sourceViewRedo = Signal $ connect_NONE__NONE "redo"

-- | The 'moveLines' signal is a keybinding which gets emitted when the user initiates moving a
-- line. The default binding key is Alt+Up/Down arrow. And moves the currently selected lines, or the
-- current line by count. For the moment, only count of -1 or 1 is valid.
sourceViewMoveLines :: SourceViewClass sv => Signal sv (Bool -> Int -> IO ())
sourceViewMoveLines = Signal $ connect_BOOL_INT__NONE "move-lines"

-- | The 'showCompletion' signal is a keybinding signal which gets emitted when the user initiates a
-- completion in default mode.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the default mode completion activation.
sourceViewShowCompletion :: SourceViewClass sv => Signal sv (IO ())
sourceViewShowCompletion = Signal $ connect_NONE__NONE "show-completion"

-- | Emitted when a line mark has been activated (for instance when there was a button press in the line
-- marks gutter). You can use iter to determine on which line the activation took place.
sourceViewLineMarkActivated :: SourceViewClass sv => Signal sv (TextIter -> EventM EAny ())
sourceViewLineMarkActivated =
  Signal (\after obj fun ->
           connect_BOXED_PTR__NONE "line-mark-activated" mkTextIterCopy after obj
                                   (\iter eventPtr -> runReaderT (fun iter) eventPtr)
         )

#if GTK_MAJOR_VERSION < 3
-- * Deprecated
#ifndef DISABLE_DEPRECATED
-- | 'sourceViewSetMarkCategoryPixbuf' is deprecated and should not be used in newly-written
-- code. Use 'sourceViewSetMarkCategoryIconFromPixbuf' instead
--
sourceViewSetMarkCategoryPixbuf :: (SourceViewClass sv, GlibString string) => sv -> string -> Pixbuf -> IO ()
sourceViewSetMarkCategoryPixbuf sv markerType marker = withUTFString markerType $ \strPtr ->
  {#call source_view_set_mark_category_pixbuf#} (toSourceView sv) strPtr marker

-- | 'sourceViewGetMarkCategoryPixbuf' is deprecated and should not be used in newly-written code.
--
sourceViewGetMarkCategoryPixbuf :: (SourceViewClass sv, GlibString string) => sv -> string -> IO Pixbuf
sourceViewGetMarkCategoryPixbuf sv markerType = withUTFString markerType $ \strPtr ->
  wrapNewGObject mkPixbuf $
  {#call unsafe source_view_get_mark_category_pixbuf#} (toSourceView sv) strPtr
#endif
#endif

{-# 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
--  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.SourceView (
-- * Description
-- | 'SourceView' is the main object of the gtksourceview library. It provides a text view which syntax
-- highlighting, undo/redo and text marks. Use a 'SourceBuffer' to display text with a 'SourceView'.

-- * Types
  SourceView,
  SourceViewClass,

-- * Enums
  SourceSmartHomeEndType(..),
  SourceDrawSpacesFlags(..),
  SourceViewGutterPosition (..),

-- * Methods
  castToSourceView,
  gTypeSourceView,
  toSourceView,
  sourceViewNew,
  sourceViewNewWithBuffer,
  sourceViewSetAutoIndent,
  sourceViewGetAutoIndent,
  sourceViewSetIndentOnTab,
  sourceViewGetIndentOnTab,
  sourceViewSetIndentWidth,
  sourceViewGetIndentWidth,
  sourceViewSetInsertSpacesInsteadOfTabs,
  sourceViewGetInsertSpacesInsteadOfTabs,
  sourceViewSetSmartHomeEnd,
  sourceViewGetSmartHomeEnd,
#if GTK_MAJOR_VERSION < 3
  sourceViewSetMarkCategoryPriority,
  sourceViewGetMarkCategoryPriority,
  sourceViewSetMarkCategoryIconFromPixbuf,
  sourceViewSetMarkCategoryIconFromStock,
  sourceViewSetMarkCategoryIconFromIconName,
  sourceViewSetMarkCategoryBackground,
  sourceViewGetMarkCategoryBackground,
#endif
  sourceViewSetHighlightCurrentLine,
  sourceViewGetHighlightCurrentLine,
  sourceViewSetShowLineMarks,
  sourceViewGetShowLineMarks,
  sourceViewSetShowLineNumbers,
  sourceViewGetShowLineNumbers,
  sourceViewSetShowRightMargin,
  sourceViewGetShowRightMargin,
  sourceViewSetRightMarginPosition,
  sourceViewGetRightMarginPosition,
  sourceViewSetTabWidth,
  sourceViewGetTabWidth,
  sourceViewSetDrawSpaces,
  sourceViewGetDrawSpaces,
  sourceViewGetGutter,

#if GTK_MAJOR_VERSION >= 3
#if MIN_VERSION_gtksourceview_3_0(3, 16, 0)
  sourceViewIndentLines,
  sourceViewUnindentLines,
#endif
  sourceViewGetVisualColumn,
  sourceViewSetMarkAttributes,
  sourceViewGetMarkAttributes,
#endif

-- * Attributes
  sourceViewAutoIndent,
  sourceViewCompletion,
  sourceViewDrawSpaces,
  sourceViewHighlightCurrentLine,
  sourceViewIndentOnTab,
  sourceViewIndentWidth,
  sourceViewInsertSpacesInsteadOfTabs,
  sourceViewRightMarginPosition,
  sourceViewShowLineNumbers,
  sourceViewShowRightMargin,
  sourceViewSmartHomeEnd,
  sourceViewTabWidth,

-- * Signals
  sourceViewUndo,
  sourceViewRedo,
  sourceViewMoveLines,
  sourceViewShowCompletion,
  sourceViewLineMarkActivated,

-- * Deprecated
#if GTK_MAJOR_VERSION < 3
#ifndef DISABLE_DEPRECATED
  sourceViewSetMarkCategoryPixbuf,
  sourceViewGetMarkCategoryPixbuf,
#endif
#endif
  ) where

import Control.Applicative
import Prelude
import Control.Monad    (liftM)
import Control.Monad.Reader ( runReaderT )
import Data.Maybe    (fromMaybe)

import Graphics.UI.Gtk.Abstract.Object (makeNewObject)
import Graphics.UI.Gtk.Abstract.Widget (Color)
import Graphics.UI.Gtk.Gdk.EventM (EventM, EAny)
import Graphics.UI.Gtk.Multiline.TextView (TextWindowType (..))
import Graphics.UI.Gtk.SourceView.Enums
import Graphics.UI.GtkInternals  ( TextIter, mkTextIterCopy )
import System.Glib.GObject      (wrapNewGObject, makeNewGObject)
import System.Glib.Attributes
import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Flags (toFlags, fromFlags)

{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import System.Glib.Properties#}

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

-- | Create a new 'SourceView' widget with a default 'SourceBuffer'.
--
sourceViewNew :: IO SourceView
sourceViewNew = makeNewObject mkSourceView $ liftM castPtr
  {#call unsafe source_view_new#}

-- | Create a new 'SourceView'
-- widget with the given 'SourceBuffer'.
--
sourceViewNewWithBuffer :: SourceBuffer -> IO SourceView
sourceViewNewWithBuffer sb = makeNewObject mkSourceView $ liftM castPtr $
  {#call source_view_new_with_buffer#} sb

-- | If 'True' auto indentation of text is enabled.
--
sourceViewSetAutoIndent :: SourceViewClass sv => sv
                        -> Bool  -- ^ @enable@ whether to enable auto indentation.
                        -> IO ()
sourceViewSetAutoIndent sv enable =
  {#call source_view_set_auto_indent#} (toSourceView sv) (fromBool enable)

-- | Returns whether auto indentation of text is enabled.
--
sourceViewGetAutoIndent :: SourceViewClass sv => sv
                        -> IO Bool  -- ^ returns 'True' if auto indentation is enabled.
sourceViewGetAutoIndent sv = liftM toBool $
  {#call unsafe source_view_get_auto_indent#} (toSourceView sv)

-- | If 'True', when the tab key is pressed and there is a selection, the selected text is indented of one
-- level instead of being replaced with the \t characters. Shift+Tab unindents the selection.
--
sourceViewSetIndentOnTab :: SourceViewClass sv => sv
                         -> Bool  -- ^ @enable@ whether to indent a block when tab is pressed.
                         -> IO ()
sourceViewSetIndentOnTab sv enable =
  {#call source_view_set_indent_on_tab#} (toSourceView sv) (fromBool enable)

-- | Returns whether when the tab key is pressed the current selection should get indented instead of
-- replaced with the \t character.
--
sourceViewGetIndentOnTab :: SourceViewClass sv => sv
                         -> IO Bool  -- ^ returns 'True' if the selection is indented when tab is pressed.
sourceViewGetIndentOnTab sv = liftM toBool $
  {#call unsafe source_view_get_indent_on_tab#} (toSourceView sv)

-- | Sets the number of spaces to use for each step of indent. If width is -1, the value of the
-- 'tabWidth' property will be used.
--
sourceViewSetIndentWidth :: SourceViewClass sv => sv
                         -> Int  -- ^ @width@ indent width in characters.
                         -> IO ()
sourceViewSetIndentWidth sv width =
  {#call source_view_set_indent_width#} (toSourceView sv) (fromIntegral width)

-- | Returns the number of spaces to use for each step of indent. See 'sourceViewSetIndentWidth'
-- for details.
--
sourceViewGetIndentWidth :: SourceViewClass sv => sv
                         -> IO Int -- ^ returns indent width.
sourceViewGetIndentWidth sv = liftM fromIntegral $
  {#call unsafe source_view_get_indent_width#} (toSourceView sv)

-- | If 'True' any tabulator character inserted is replaced by a group of space characters.
--
sourceViewSetInsertSpacesInsteadOfTabs :: SourceViewClass sv => sv
                                       -> Bool  -- ^ @enable@ whether to insert spaces instead of tabs.
                                       -> IO ()
sourceViewSetInsertSpacesInsteadOfTabs sv enable =
  {#call source_view_set_insert_spaces_instead_of_tabs#} (toSourceView sv) (fromBool enable)

-- | Returns whether when inserting a tabulator character it should be replaced by a group of space
-- characters.
--
sourceViewGetInsertSpacesInsteadOfTabs :: SourceViewClass sv => sv
                                       -> IO Bool  -- ^ returns 'True' if spaces are inserted instead of tabs.
sourceViewGetInsertSpacesInsteadOfTabs sv = liftM toBool $
  {#call unsafe source_view_get_insert_spaces_instead_of_tabs#} (toSourceView sv)

-- | Set the desired movement of the cursor when HOME and END keys are pressed.
--
sourceViewSetSmartHomeEnd :: SourceViewClass sv => sv
                          -> SourceSmartHomeEndType  -- ^ @smartHe@ the desired behavior among 'SourceSmartHomeEndType'.
                          -> IO ()
sourceViewSetSmartHomeEnd sv newVal =
  {#call source_view_set_smart_home_end#} (toSourceView sv) (fromIntegral $ fromEnum newVal)

-- | Returns a 'SourceSmartHomeEndType' end value specifying how the cursor will move when HOME and END
-- keys are pressed.
--
sourceViewGetSmartHomeEnd :: SourceViewClass sv => sv
                          -> IO SourceSmartHomeEndType -- ^ returns a 'SourceSmartHomeEndTypeend' value.
sourceViewGetSmartHomeEnd sv = liftM (toEnum . fromIntegral) $
  {#call unsafe source_view_get_smart_home_end#} (toSourceView sv)

-- | If show is 'True' the current line is highlighted.
--
sourceViewSetHighlightCurrentLine :: SourceViewClass sv => sv
                                  -> Bool  -- ^ @show@ whether to highlight the current line
                                  -> IO ()
sourceViewSetHighlightCurrentLine sv newVal =
  {#call source_view_set_highlight_current_line#} (toSourceView sv) (fromBool newVal)

-- | Returns whether the current line is highlighted
--
sourceViewGetHighlightCurrentLine :: SourceViewClass sv => sv
                                  -> IO Bool  -- ^ returns 'True' if the current line is highlighted.
sourceViewGetHighlightCurrentLine sv = liftM toBool $
  {#call unsafe source_view_get_highlight_current_line#} (toSourceView sv)

-- | If 'True' line marks will be displayed beside the text.
--
sourceViewSetShowLineMarks :: SourceViewClass sv => sv
                           -> Bool  -- ^ @show@ whether line marks should be displayed.
                           -> IO ()
sourceViewSetShowLineMarks sv newVal =
  {#call source_view_set_show_line_marks#} (toSourceView sv) (fromBool newVal)

-- | Returns whether line marks are displayed beside the text.
--
sourceViewGetShowLineMarks :: SourceViewClass sv => sv
                           -> IO Bool  -- ^ returns 'True' if the line marks are displayed.
sourceViewGetShowLineMarks sv = liftM toBool $
  {#call unsafe source_view_get_show_line_marks#} (toSourceView sv)

-- | If 'True' line numbers will be displayed beside the text.
--
sourceViewSetShowLineNumbers :: SourceViewClass sv => sv
                             -> Bool  -- ^ @show@ whether line numbers should be displayed.
                             -> IO ()
sourceViewSetShowLineNumbers sv newVal =
  {#call source_view_set_show_line_numbers#} (toSourceView sv) (fromBool newVal)

-- | Returns whether line numbers are displayed beside the text.
--
sourceViewGetShowLineNumbers :: SourceViewClass sv => sv
                             -> IO Bool  -- ^ returns 'True' if the line numbers are displayed.
sourceViewGetShowLineNumbers sv = liftM toBool $
  {#call unsafe source_view_get_show_line_numbers#} (toSourceView sv)

-- | If 'True' a right margin is displayed
--
sourceViewSetShowRightMargin :: SourceViewClass sv => sv
                             -> Bool  -- ^ @show@ whether to show a right margin.
                             -> IO ()
sourceViewSetShowRightMargin sv newVal =
  {#call source_view_set_show_right_margin#} (toSourceView sv) (fromBool newVal)

-- | Returns whether a right margin is displayed.
--
sourceViewGetShowRightMargin :: SourceViewClass sv => sv
                             -> IO Bool -- ^ returns 'True' if the right margin is shown.
sourceViewGetShowRightMargin sv = liftM toBool $
  {#call source_view_get_show_right_margin#} (toSourceView sv)

-- | Sets the position of the right margin in the given view.
--
sourceViewSetRightMarginPosition :: SourceViewClass sv => sv
                                 -> Word -- ^ @pos@  the width in characters where to position the right margin.
                                 -> IO ()
sourceViewSetRightMarginPosition sv margin =
  {#call source_view_set_right_margin_position#} (toSourceView sv) (fromIntegral margin)

-- | Gets the position of the right margin in the given view.
--
sourceViewGetRightMarginPosition :: SourceViewClass sv => sv
                                 -> IO Int  -- ^ returns the position of the right margin.
sourceViewGetRightMarginPosition sv = liftM fromIntegral $
  {#call unsafe source_view_get_right_margin_position#} (toSourceView sv)

-- | Sets the width of tabulation in characters.
--
sourceViewSetTabWidth :: SourceViewClass sv => sv
                      -> Int  -- ^ @width@ width of tab in characters.
                      -> IO ()
sourceViewSetTabWidth sv width =
  {#call source_view_set_tab_width#} (toSourceView sv) (fromIntegral width)

-- | Returns the width of tabulation in characters.
--
sourceViewGetTabWidth :: SourceViewClass sv => sv
                      -> IO Int -- ^ returns width of tab.
sourceViewGetTabWidth sv = liftM fromIntegral $
  {#call unsafe source_view_get_tab_width#} (toSourceView sv)

-- | Set if and how the spaces should be visualized. Specifying flags as [] will disable display of
-- spaces.
sourceViewSetDrawSpaces :: SourceViewClass sv => sv
                        -> [SourceDrawSpacesFlags] -- ^ @flags@ 'SourceDrawSpacesFlags' specifing how white spaces should be displayed
                        -> IO ()
sourceViewSetDrawSpaces view flags =
  {#call gtk_source_view_set_draw_spaces #}
    (toSourceView view)
    (fromIntegral $ fromFlags flags)

-- | Returns the 'SourceDrawSpacesFlags' specifying if and how spaces should be displayed for this view.
sourceViewGetDrawSpaces :: SourceViewClass sv => sv
                        -> IO [SourceDrawSpacesFlags] -- ^ returns the 'SourceDrawSpacesFlags', [] if no spaces should be drawn.
sourceViewGetDrawSpaces view =
  liftM (toFlags . fromIntegral) $
  {#call gtk_source_view_get_draw_spaces #}
     (toSourceView view)

-- | Returns the 'SourceGutter' object associated with @windowType@ for view. Only 'TextWindowLeft'
-- and 'TextWindowRight' are supported, respectively corresponding to the left and right
-- gutter. The line numbers and mark category icons are rendered in the gutter corresponding to
-- 'TextWindowLeft'.
sourceViewGetGutter :: SourceViewClass sv => sv
                    -> TextWindowType  -- ^ @windowType@ the gutter window type
                    -> IO SourceGutter
sourceViewGetGutter sv windowType =
  makeNewGObject mkSourceGutter $
  {#call gtk_source_view_get_gutter #}
    (toSourceView sv)
    (fromIntegral $ fromEnum windowType)

#if GTK_MAJOR_VERSION < 3
-- | Set the priority for the given mark category. When there are multiple marks on the same line, marks
-- of categories with higher priorities will be drawn on top.
--
sourceViewSetMarkCategoryPriority :: (SourceViewClass sv, GlibString string) => sv
                                  -> string  -- ^ @category@ a mark category.
                                  -> Int  -- ^ @priority@ the priority for the category
                                  -> IO ()
sourceViewSetMarkCategoryPriority sv markerType priority = withUTFString markerType $ \strPtr ->
  {#call source_view_set_mark_category_priority#} (toSourceView sv) strPtr (fromIntegral priority)

-- | Gets the priority which is associated with the given category.
--
sourceViewGetMarkCategoryPriority :: (SourceViewClass sv, GlibString string) => sv
                                  -> string  -- ^ @category@ a mark category.
                                  -> IO Int -- ^ returns  the priority or if category exists but no priority was set, it defaults to 0.
sourceViewGetMarkCategoryPriority sv markerType = withUTFString markerType $ \strPtr ->
  liftM fromIntegral $
  {#call unsafe source_view_get_mark_category_priority#} (toSourceView sv) strPtr

-- | Sets the icon to be used for category to pixbuf. If pixbuf is 'Nothing', the icon is unset.
sourceViewSetMarkCategoryIconFromPixbuf :: (SourceViewClass sv, GlibString string) => sv
                                        -> string -- ^ @category@ a mark category.
                                        -> Maybe Pixbuf -- ^ @pixbuf@   a 'Pixbuf' or 'Nothing'.
                                        -> IO ()
sourceViewSetMarkCategoryIconFromPixbuf sv category pixbuf =
  withUTFString category $ \categoryPtr ->
  {#call gtk_source_view_set_mark_category_icon_from_pixbuf #}
     (toSourceView sv)
     categoryPtr
     (fromMaybe (Pixbuf nullForeignPtr) pixbuf)

-- | Sets the icon to be used for category to the stock item @stockId@. If @stockId@ is 'Nothing', the icon is
-- unset.
sourceViewSetMarkCategoryIconFromStock :: (SourceViewClass sv, GlibString string) => sv
                                       -> string -- ^ @category@ a mark category.
                                       -> Maybe string -- ^ @stockId@ the stock id or 'Nothing'.
                                       -> IO ()
sourceViewSetMarkCategoryIconFromStock sv category stockId =
  withUTFString category $ \categoryPtr ->
  maybeWith withUTFString stockId $ \stockIdPtr ->
  {#call gtk_source_view_set_mark_category_icon_from_stock #}
    (toSourceView sv)
    categoryPtr
    stockIdPtr

-- | Sets the icon to be used for category to the named theme item name. If name is 'Nothing', the icon is
-- unset.
sourceViewSetMarkCategoryIconFromIconName :: (SourceViewClass sv, GlibString string) => sv
                                       -> string -- ^ @category@ a mark category.
                                       -> Maybe string -- ^ @name@     the themed icon name or 'Nothing'.
                                       -> IO ()
sourceViewSetMarkCategoryIconFromIconName sv category name =
  withUTFString category $ \categoryPtr ->
  maybeWith withUTFString name $ \namePtr ->
  {#call gtk_source_view_set_mark_category_icon_from_icon_name #}
    (toSourceView sv)
    categoryPtr
    namePtr

-- | Sets given background color for mark category. If color is 'Nothing', the background color is unset.
sourceViewSetMarkCategoryBackground :: (SourceViewClass sv, GlibString string) => sv
                                    -> string -- ^ @category@ a mark category.
                                    -> Maybe Color  -- ^ @color@    background color or 'Nothing' to unset it.
                                    -> IO ()
sourceViewSetMarkCategoryBackground sv category color =
  let withMB :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
      withMB Nothing f = f nullPtr
      withMB (Just x) f = with x f
  in withUTFString category $ \categoryPtr ->
     withMB color $ \colorPtr ->
     {#call gtk_source_view_set_mark_category_background #}
       (toSourceView sv)
       categoryPtr
       (castPtr colorPtr)

-- | Gets the background color associated with given category.
sourceViewGetMarkCategoryBackground :: (SourceViewClass sv, GlibString string) => sv
                                    -> string -- ^ @category@ a mark category.
                                    -> Color -- ^ @dest@     destination 'Color' structure to fill in.
                                    -> IO Bool -- ^ returns  'True' if background color for category was set and dest is set to a valid color, or 'False' otherwise.
sourceViewGetMarkCategoryBackground sv category color =
    liftM toBool $
    withUTFString category $ \ categoryPtr ->
    with color $ \ colorPtr ->
    {#call gtk_source_view_get_mark_category_background #}
      (toSourceView sv)
      categoryPtr
      (castPtr colorPtr)
#endif

#if MIN_VERSION_gtksourceview_3_0(3, 16, 0)
-- | Insert one indentation level at the beginning of the specified lines.
--
sourceViewIndentLines :: SourceViewClass sv
                      => sv
                      -> TextIter -- ^ @start@ the first line to indent.
                      -> TextIter -- ^ @end@ the last line to indent.
                      -> IO ()
sourceViewIndentLines sv start end =
    {# call gtk_source_view_indent_lines #}
      (toSourceView sv)
      start
      end

-- | Removes one indentation level at the beginning of the specified lines.
--
sourceViewUnindentLines :: SourceViewClass sv
                        => sv
                        -> TextIter -- ^ @start@ the first line to indent.
                        -> TextIter -- ^ @end@ the last line to indent.
                        -> IO ()
sourceViewUnindentLines sv start end =
    {# call gtk_source_view_unindent_lines #}
      (toSourceView sv)
      start
      end
#endif

-- | Determines the visual column at iter taking into consideration the `tabWidth` of the view.
--
sourceViewGetVisualColumn :: SourceViewClass sv
                          => sv
                          -> TextIter -- ^ @iter@ a position in view.
                          -> IO Word
sourceViewGetVisualColumn sv iter = fromIntegral <$>
    {# call gtk_source_view_get_visual_column #}
      (toSourceView sv)
      iter

-- | Sets attributes and priority for the category.
--
sourceViewSetMarkAttributes :: (SourceViewClass sv, GlibString category, SourceMarkAttributesClass attributes)
                            => sv
                            -> category
                            -> Maybe attributes
                            -> Int
                            -> IO ()
sourceViewSetMarkAttributes sv category attributes priority =
  withUTFString category $ \categoryPtr ->
    {# call gtk_source_view_set_mark_attributes #}
      (toSourceView sv)
      categoryPtr
      (maybe (SourceMarkAttributes nullForeignPtr) toSourceMarkAttributes attributes)
      (fromIntegral priority)

-- | Gets attributes and priority for the category
--
sourceViewGetMarkAttributes :: (SourceViewClass sv, GlibString category)
                            => sv
                            -> category
                            -> IO (Maybe (SourceMarkAttributes, Int))
sourceViewGetMarkAttributes sv category =
  withUTFString category $ \categoryPtr ->
  alloca $ \ priority -> do
    attributes <- maybeNull (makeNewObject mkSourceMarkAttributes) $
                        {# call gtk_source_view_get_mark_attributes #}
                          (toSourceView sv)
                          categoryPtr
                          priority
    case attributes of
        Just a -> do
            p <- peek priority
            return $ Just (a, fromIntegral p)
        Nothing -> return Nothing

-- | Whether to enable auto indentation.
--
-- Default value: 'False'
--
sourceViewAutoIndent :: SourceViewClass sv => Attr sv Bool
sourceViewAutoIndent = newAttrFromBoolProperty "auto-indent"

-- | The completion object associated with the view.
--
sourceViewCompletion :: SourceViewClass sv => ReadAttr sv SourceCompletion
sourceViewCompletion = readAttrFromObjectProperty "completion"
                       {#call pure unsafe gtk_source_completion_get_type #}

-- | Set if and how the spaces should be visualized.
--
sourceViewDrawSpaces :: SourceViewClass sv => Attr sv [SourceDrawSpacesFlags]
sourceViewDrawSpaces = newAttrFromFlagsProperty "draw-spaces" {#call fun gtk_source_draw_spaces_flags_get_type#}

-- | Whether to highlight the current line.
--
-- Default value: 'False'
--
sourceViewHighlightCurrentLine :: SourceViewClass sv => Attr sv Bool
sourceViewHighlightCurrentLine = newAttrFromBoolProperty "highlight-current-line"

-- | Whether to indent the selected text when the tab key is pressed.
--
-- Default value: 'True'
--
sourceViewIndentOnTab :: SourceViewClass sv => Attr sv Bool
sourceViewIndentOnTab = newAttrFromBoolProperty "indent-on-tab"

-- | Width of an indentation step expressed in number of spaces.
--
-- Allowed values: [GMaxulong,32]
--
-- Default value: -1
--
sourceViewIndentWidth :: SourceViewClass sv => Attr sv Int
sourceViewIndentWidth = newAttrFromIntProperty "indent-width"

-- | Whether to insert spaces instead of tabs.
--
-- Default value: 'False'
--
sourceViewInsertSpacesInsteadOfTabs :: SourceViewClass sv => Attr sv Bool
sourceViewInsertSpacesInsteadOfTabs = newAttrFromBoolProperty "insert-spaces-instead-of-tabs"

-- | Position of the right margin.
--
-- Allowed values: [1,200]
--
-- Default value: 80
--
sourceViewRightMarginPosition :: SourceViewClass sv => Attr sv Int
sourceViewRightMarginPosition = newAttrFromUIntProperty "right-margin-position"

-- | Whether to display line numbers
--
-- Default value: 'False'
--
sourceViewShowLineNumbers :: SourceViewClass sv => Attr sv Bool
sourceViewShowLineNumbers = newAttrFromBoolProperty "show-line-numbers"

-- | Whether to display line mark pixbufs
--
-- Default value: 'False'
--
sourceViewShowRightMargin :: SourceViewClass sv => Attr sv Bool
sourceViewShowRightMargin = newAttrFromBoolProperty "show-right-margin"

-- | Set the behavior of the HOME and END keys.
--
-- Default value: 'SourceSmartHomeEndDisabled'
--
-- Since 2.0
--
sourceViewSmartHomeEnd :: SourceViewClass sv => Attr sv SourceSmartHomeEndType
sourceViewSmartHomeEnd = newAttrFromEnumProperty "smart-home-end" {#call fun gtk_source_smart_home_end_type_get_type#}

-- | Width of an tab character expressed in number of spaces.
--
-- Allowed values: [1,32]
--
-- Default value: 8
--
sourceViewTabWidth :: SourceViewClass sv => Attr sv Int
sourceViewTabWidth = newAttrFromUIntProperty "tab-width"

-- |
--
sourceViewUndo :: SourceViewClass sv => Signal sv (IO ())
sourceViewUndo = Signal $ connect_NONE__NONE "undo"

-- |
--
sourceViewRedo :: SourceViewClass sv => Signal sv (IO ())
sourceViewRedo = Signal $ connect_NONE__NONE "redo"

-- | The 'moveLines' signal is a keybinding which gets emitted when the user initiates moving a
-- line. The default binding key is Alt+Up/Down arrow. And moves the currently selected lines, or the
-- current line by count. For the moment, only count of -1 or 1 is valid.
sourceViewMoveLines :: SourceViewClass sv => Signal sv (Bool -> Int -> IO ())
sourceViewMoveLines = Signal $ connect_BOOL_INT__NONE "move-lines"

-- | The 'showCompletion' signal is a keybinding signal which gets emitted when the user initiates a
-- completion in default mode.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the default mode completion activation.
sourceViewShowCompletion :: SourceViewClass sv => Signal sv (IO ())
sourceViewShowCompletion = Signal $ connect_NONE__NONE "show-completion"

-- | Emitted when a line mark has been activated (for instance when there was a button press in the line
-- marks gutter). You can use iter to determine on which line the activation took place.
sourceViewLineMarkActivated :: SourceViewClass sv => Signal sv (TextIter -> EventM EAny ())
sourceViewLineMarkActivated =
  Signal (\after obj fun ->
           connect_BOXED_PTR__NONE "line-mark-activated" mkTextIterCopy after obj
                                   (\iter eventPtr -> runReaderT (fun iter) eventPtr)
         )

#if GTK_MAJOR_VERSION < 3
-- * Deprecated
#ifndef DISABLE_DEPRECATED
-- | 'sourceViewSetMarkCategoryPixbuf' is deprecated and should not be used in newly-written
-- code. Use 'sourceViewSetMarkCategoryIconFromPixbuf' instead
--
sourceViewSetMarkCategoryPixbuf :: (SourceViewClass sv, GlibString string) => sv -> string -> Pixbuf -> IO ()
sourceViewSetMarkCategoryPixbuf sv markerType marker = withUTFString markerType $ \strPtr ->
  {#call source_view_set_mark_category_pixbuf#} (toSourceView sv) strPtr marker

-- | 'sourceViewGetMarkCategoryPixbuf' is deprecated and should not be used in newly-written code.
--
sourceViewGetMarkCategoryPixbuf :: (SourceViewClass sv, GlibString string) => sv -> string -> IO Pixbuf
sourceViewGetMarkCategoryPixbuf sv markerType = withUTFString markerType $ \strPtr ->
  wrapNewGObject mkPixbuf $
  {#call unsafe source_view_get_mark_category_pixbuf#} (toSourceView sv) strPtr
#endif
#endif


storable instance for the state

storable instance for the state

{-# LANGUAGE ForeignFunctionInterface,
             EmptyDataDecls
 #-}
module Network.LibRSync.Internal where

import Control.Applicative((<$>),(<*>))
import Control.Monad

import Data.ByteString
import Data.Conduit

import System.IO
import GHC.IO.Handle
import System.Posix.IO
import System.Posix.Types

import Foreign
import Foreign.Marshal.Alloc
-- import Foreign.Ptr
import Foreign.C.String
import Foreign.C.Types
-- import Foreign.Storable

#include "internal.h"

-- #include "../../../c_src/internal.h"

--------------------------------------------------------------------------------
-- | The CTypes

data CInMemoryBuffer = CInMemoryBuffer (Ptr CChar) CSize CSize

{#pointer *inMemoryBuffer_t as CInMemoryBufferPtr -> CInMemoryBuffer #}

instance Storable CInMemoryBuffer where
    sizeOf    = const {#sizeof inMemoryBuffer_t #}
    alignment = const 4
    peek p    = CInMemoryBuffer
                <$> {#get inMemoryBuffer_t->buffer #} p
                <*> liftM fromIntegral ({#get inMemoryBuffer_t->size #}   p)
                <*> liftM fromIntegral ({#get inMemoryBuffer_t->inUse #}  p)
    poke      = undefined

getData                          :: CInMemoryBuffer -> IO ByteString
getData (CInMemoryBuffer xs _ s) = packCStringLen (xs,fromIntegral s)

-- data CRSFileBuf = CRSFileBuf (Ptr CFile) CSize

-- {#pointer *rs_filebuf_t as CRSFileBufPtr -> CRSFileBuf #}

data CJob
data CBuffers
data CRSFileBuf

data CRSyncSourceState = CRSyncSourceState { f :: Ptr CFile
                                           , job :: Ptr CJob
                                           , buf :: Ptr CBuffers
                                           , inBuf :: Ptr CRSFileBuf
                                           , outputBuf' :: CInMemoryBufferPtr
                                           }

{#pointer *rsyncSourceState_t as CRSyncSourceStatePtr -> CRSyncSourceState #}

instance Storable CRSyncSourceState where
    sizeOf    = const {#sizeof rsyncSourceState_t #}
    alignment = const 4
               -- We can only access the output buffer and the return state
    peek p    = CRSyncSourceState undefined undefined undefined undefined
                <$> {#get rsyncSourceState_t->outputBuf #} p
    poke      = undefined

-- data BlockSig
-- {#pointer *rs_block_sig_t as BlockSigPtr -> BlockSig #}

-- type CSignature = Ptr CFile

-- -- | The Signature type
-- {#pointer *rs_signature_t as SignaturePtr -> CSignature #}

-- | The results type
{#enum rs_result as Result {underscoreToCase} deriving (Eq, Show)#}

--------------------------------------------------------------------------------
-- | Generating Signatures

type RSyncSourceState = CRSyncSourceStatePtr

outputBuf   :: RSyncSourceState -> IO CInMemoryBuffer
outputBuf p = (outputBuf' <$> peek p) >>= peek

type Signature = ByteString

startSignature :: FilePath -> IO RSyncSourceState
startSignature path = do
  state <- malloc :: IO (Ptr CRSyncSourceState)
  rsres  <- cStartSignature path state
  return state
  -- TODO: check what to do with rsres
  -- case rsres of
  --   RsDone ->

endSignature :: RSyncSourceState -> IO ()
endSignature state = cEndSignature state >> free state

signatureSource :: MonadResource m => RSyncSourceState -> Source m Signature
signatureSource state = undefined -- do
    -- (CInMemoryBuffer xs size inUse) <- {#get inMemorybuffer->outputBuf-> state

{#fun unsafe startSignature as cStartSignature
      { `String' -- FilePath
      , id `CRSyncSourceStatePtr'
      } -> `Result' cIntToEnum
 #}

{#fun unsafe signatureChunk as cSignatureChunk
      { id `CRSyncSourceStatePtr'
      , `Bool'
      } -> `Result' cIntToEnum
 #}

{#fun unsafe endSignature as cEndSignature
      { id `CRSyncSourceStatePtr'
      } -> `()'
 #}

-- type Signature = ByteString

--------------------------------------------------------------------------------
-- | Delta

--------------------------------------------------------------------------------
-- | Patch

--------------------------------------------------------------------------------
-- | Helper functions

cIntToEnum :: Enum a => CInt -> a
cIntToEnum = toEnum . fromIntegral

{-# LANGUAGE ForeignFunctionInterface,
             EmptyDataDecls
 #-}
module Network.LibRSync.Internal where

import Control.Applicative((<$>),(<*>))
import Control.Monad

import Data.ByteString
import Data.Conduit

import System.IO
import GHC.IO.Handle
import System.Posix.IO
import System.Posix.Types

import Foreign
import Foreign.Marshal.Alloc
-- import Foreign.Ptr
import Foreign.C.String
import Foreign.C.Types
-- import Foreign.Storable

#include "internal.h"

-- #include "../../../c_src/internal.h"

--------------------------------------------------------------------------------
-- | The CTypes

data CInMemoryBuffer = CInMemoryBuffer (Ptr CChar) CSize CSize

{#pointer *inMemoryBuffer_t as CInMemoryBufferPtr -> CInMemoryBuffer #}

instance Storable CInMemoryBuffer where
    sizeOf    = const {#sizeof inMemoryBuffer_t #}
    alignment = const 4
    peek p    = CInMemoryBuffer
                <$> {#get inMemoryBuffer_t->buffer #} p
                <*> liftM fromIntegral ({#get inMemoryBuffer_t->size #}   p)
                <*> liftM fromIntegral ({#get inMemoryBuffer_t->inUse #}  p)
   poke       = undefined

getData                          :: CInMemoryBuffer -> IO ByteString
getData (CInMemoryBuffer xs _ s) = packCStringLen (xs,fromIntegral s)

-- data CRSFileBuf = CRSFileBuf (Ptr CFile) CSize

-- {#pointer *rs_filebuf_t as CRSFileBufPtr -> CRSFileBuf #}

data CJob
data CBuffers
data CRSFileBuf

data CRSyncSourceState = CRSyncSourceState { f :: Ptr CFile
                                           , job :: Ptr CJob
                                           , buf :: Ptr CBuffers
                                           , inBuf :: Ptr CRSFileBuf
                                           , outputBuf :: CInMemoryBufferPtr
                                           }

instance Storable CRSyncSourceState where
    sizeOf    = const {#sizeof rsyncSourceState_t #}
    alignment = const 4
    peek      = undefined
    poke      = undefined

{#pointer *rsyncSourceState_t as CRSyncSourceStatePtr -> CRSyncSourceState #}

-- data BlockSig
-- {#pointer *rs_block_sig_t as BlockSigPtr -> BlockSig #}

-- type CSignature = Ptr CFile

-- -- | The Signature type
-- {#pointer *rs_signature_t as SignaturePtr -> CSignature #}

-- | The results type
{#enum rs_result as Result {underscoreToCase} deriving (Eq, Show)#}

--------------------------------------------------------------------------------
-- | Generating Signatures

type RSyncSourceState = CRSyncSourceStatePtr

type Signature = ByteString

startSignature :: FilePath -> IO RSyncSourceState
startSignature path = do
  state <- malloc :: IO (Ptr CRSyncSourceState)
  rsres  <- cStartSignature path state
  return state
  -- TODO: check what to do with rsres
  -- case rsres of
  --   RsDone ->

endSignature :: RSyncSourceState -> IO ()
endSignature state = cEndSignature state >> free state

signatureSource :: MonadResource m => RSyncSourceState -> Source m Signature
signatureSource state = undefined -- do
    -- (CInMemoryBuffer xs size inUse) <- {#get inMemorybuffer->outputBuf-> state

{#fun unsafe startSignature as cStartSignature
      { `String' -- FilePath
      , id `CRSyncSourceStatePtr'
      } -> `Result' cIntToEnum
 #}

{#fun unsafe signatureChunk as cSignatureChunk
      { id `CRSyncSourceStatePtr'
      , `Bool'
      } -> `Result' cIntToEnum
 #}

{#fun unsafe endSignature as cEndSignature
      { id `CRSyncSourceStatePtr'
      } -> `()'
 #}

-- type Signature = ByteString

--------------------------------------------------------------------------------
-- | Delta

--------------------------------------------------------------------------------
-- | Patch

--------------------------------------------------------------------------------
-- | Helper functions

cIntToEnum :: Enum a => CInt -> a
cIntToEnum = toEnum . fromIntegral


doc comment

doc comment

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}

--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2014 Ricky Elrod
-- License : BSD2
--
-- Maintainer : Ricky Elrod <ricky@elrod.me>
-- Stability : experimental
--
-- Provides a Haskell interface to hamlib's @rig.h@.
--------------------------------------------------------------------------------

module Communication.Hamlib.Rig where

import Control.Lens hiding (Setting)
import Foreign.Ptr
import Foreign.C.Types

#include <hamlib/rig.h>

-- Macro-defined constants
{#enum define Consts {
    RIGNAMSIZ      as RigNameSize
  , FILPATHLEN     as FilePathLength
  , FRQRANGESIZ    as FrequencyRangeSize
  , MAXCHANDESC    as MaxChannelDescription
  , TSLSTSIZ       as TuningStepListSize
  , FLTLSTSIZ      as FilterListSize
  , MAXDBLSTSIZ    as MaxDBListSize
  , CHANLSTSIZ     as ChannelListSize
  , MAX_CAL_LENGTH as MaxClibrationPlots
  } deriving (Eq, Ord, Show)#}

{#enum rig_errcode_e as RigError {underscoreToCase}#}
{#enum rig_debug_level_e as RigDebugLevel {underscoreToCase}#}
{#enum rig_level_e as RigLevel {underscoreToCase}#}
{#enum rig_port_e as RigPort {underscoreToCase}#}
{#enum serial_parity_e as SerialParity {underscoreToCase}#}
{#enum serial_handshake_e as SerialHandshake {underscoreToCase}#}
{#enum serial_control_state_e as SerialControlState {underscoreToCase}#}
{#enum rmode_t as Rmode {underscoreToCase}#}
{#enum split_t as Split {underscoreToCase}#}
{#enum rptr_shift_t as RptrShift {underscoreToCase}#}
{#enum rig_type_t as RigType {underscoreToCase}#}
{#enum rig_status_e as RigStatus {underscoreToCase}#}
{#enum dcd_e as Dcd {underscoreToCase}#}
{#enum dcd_type_t as DcdType {underscoreToCase}#}
{#enum ptt_t as Ptt {underscoreToCase}#}
{#enum powerstat_t as Powerstat {underscoreToCase}#}
{#enum reset_t as Reset {underscoreToCase}#}
{#enum vfo_op_t as VfoOp {underscoreToCase}#}
{#enum scan_t as Scan {underscoreToCase}#}
{#enum rig_conf_e as RigConf {underscoreToCase}#}
{#enum ann_t as Announce {underscoreToCase}#}
{#enum agc_level_e as AgcLevel {underscoreToCase}#}
{#enum meter_level_e as MeterLevel {underscoreToCase}#}
{#enum rig_parm_e as RigParm {underscoreToCase}#}
{#enum rig_func_e as RigFunc {underscoreToCase}#}
{#enum chan_type_t as ChanType {underscoreToCase}#}

data Value = I Int | F Float | S String | Cs String

type Vfo = Int
type Freq = Double
type ShortFreq = Integer
type Pbwidth = ShortFreq
type Setting = Integer
type Tone = Int
type Ant = Int
type Token = Integer

data Channel =
  Channel {
      channelNum   :: Int
    , bankNum      :: Int
    , channelVfo   :: Vfo
    , channelAnt   :: Int
    , freq         :: Freq
    , mode         :: Rmode
    , channelWidth :: Pbwidth
    , txFreq       :: Freq
    , txMode       :: Rmode
    , txWidth      :: Pbwidth
    , split        :: Split
    , txVfo        :: Vfo
    , rptrShift    :: RptrShift
    , rptrOffs     :: ShortFreq
    , tuningStep   :: ShortFreq
    , rit          :: ShortFreq
    , xit          :: ShortFreq
    , funcs        :: Setting
    , levels       :: [Value]
    , ctcssTone    :: Tone
    , ctcssSql     :: Tone
    , dcsCode      :: Tone
    , dcsSql       :: Tone
    , scanGroup    :: Int
    , flags        :: Int
    , channelDesc  :: String
    }

{#pointer *channel as ChannelPtr -> Channel #}

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

data FreqRangeList =
  FreqRangeList {
      _freqrangeStart          :: Freq
    , _freqrangeEnd            :: Freq
    , _freqrangeFreqRangemodes :: Rmode
    , _freqrangeLowPower       :: Int
    , _freqrangeHighPower      :: Int
    , _freqrangeVfo            :: Vfo
    , _freqrangeAnt            :: Ant
    }

{#pointer *freq_range_list as FreqRangeListPtr -> FreqRangeList #}

makeFields ''FreqRangeList

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

data TuningStepList =
  TuningStepList {
      _tuningstepModes :: Rmode
    , _tuningstepTs    :: ShortFreq
    }

{#pointer *tuning_step_list as TuningStepListPtr -> TuningStepList #}

makeFields ''TuningStepList

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

data FilterList =
  FilterList {
      _filterModes :: Rmode
    , _filterWidth :: Pbwidth
    }

{#pointer *filter_list as FilterListPtr -> FilterList #}

makeFields ''FilterList

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

data ExtList =
  ExtList {
      _extToken :: Token
    , _extVal   :: Value
    }

{#pointer *ext_list as ExtListPtr -> ExtList #}

makeFields ''ExtList

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Communication.Hamlib.Rig where

import Control.Lens hiding (Setting)
import Foreign.Ptr
import Foreign.C.Types

#include <hamlib/rig.h>

-- Macro-defined constants
{#enum define Consts {
    RIGNAMSIZ      as RigNameSize
  , FILPATHLEN     as FilePathLength
  , FRQRANGESIZ    as FrequencyRangeSize
  , MAXCHANDESC    as MaxChannelDescription
  , TSLSTSIZ       as TuningStepListSize
  , FLTLSTSIZ      as FilterListSize
  , MAXDBLSTSIZ    as MaxDBListSize
  , CHANLSTSIZ     as ChannelListSize
  , MAX_CAL_LENGTH as MaxClibrationPlots
  } deriving (Eq, Ord, Show)#}

{#enum rig_errcode_e as RigError {underscoreToCase}#}
{#enum rig_debug_level_e as RigDebugLevel {underscoreToCase}#}
{#enum rig_level_e as RigLevel {underscoreToCase}#}
{#enum rig_port_e as RigPort {underscoreToCase}#}
{#enum serial_parity_e as SerialParity {underscoreToCase}#}
{#enum serial_handshake_e as SerialHandshake {underscoreToCase}#}
{#enum serial_control_state_e as SerialControlState {underscoreToCase}#}
{#enum rmode_t as Rmode {underscoreToCase}#}
{#enum split_t as Split {underscoreToCase}#}
{#enum rptr_shift_t as RptrShift {underscoreToCase}#}
{#enum rig_type_t as RigType {underscoreToCase}#}
{#enum rig_status_e as RigStatus {underscoreToCase}#}
{#enum dcd_e as Dcd {underscoreToCase}#}
{#enum dcd_type_t as DcdType {underscoreToCase}#}
{#enum ptt_t as Ptt {underscoreToCase}#}
{#enum powerstat_t as Powerstat {underscoreToCase}#}
{#enum reset_t as Reset {underscoreToCase}#}
{#enum vfo_op_t as VfoOp {underscoreToCase}#}
{#enum scan_t as Scan {underscoreToCase}#}
{#enum rig_conf_e as RigConf {underscoreToCase}#}
{#enum ann_t as Announce {underscoreToCase}#}
{#enum agc_level_e as AgcLevel {underscoreToCase}#}
{#enum meter_level_e as MeterLevel {underscoreToCase}#}
{#enum rig_parm_e as RigParm {underscoreToCase}#}
{#enum rig_func_e as RigFunc {underscoreToCase}#}
{#enum chan_type_t as ChanType {underscoreToCase}#}

data Value = I Int | F Float | S String | Cs String

type Vfo = Int
type Freq = Double
type ShortFreq = Integer
type Pbwidth = ShortFreq
type Setting = Integer
type Tone = Int
type Ant = Int
type Token = Integer

data Channel =
  Channel {
      channelNum   :: Int
    , bankNum      :: Int
    , channelVfo   :: Vfo
    , channelAnt   :: Int
    , freq         :: Freq
    , mode         :: Rmode
    , channelWidth :: Pbwidth
    , txFreq       :: Freq
    , txMode       :: Rmode
    , txWidth      :: Pbwidth
    , split        :: Split
    , txVfo        :: Vfo
    , rptrShift    :: RptrShift
    , rptrOffs     :: ShortFreq
    , tuningStep   :: ShortFreq
    , rit          :: ShortFreq
    , xit          :: ShortFreq
    , funcs        :: Setting
    , levels       :: [Value]
    , ctcssTone    :: Tone
    , ctcssSql     :: Tone
    , dcsCode      :: Tone
    , dcsSql       :: Tone
    , scanGroup    :: Int
    , flags        :: Int
    , channelDesc  :: String
    }

{#pointer *channel as ChannelPtr -> Channel #}

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

data FreqRangeList =
  FreqRangeList {
      _freqrangeStart          :: Freq
    , _freqrangeEnd            :: Freq
    , _freqrangeFreqRangemodes :: Rmode
    , _freqrangeLowPower       :: Int
    , _freqrangeHighPower      :: Int
    , _freqrangeVfo            :: Vfo
    , _freqrangeAnt            :: Ant
    }

{#pointer *freq_range_list as FreqRangeListPtr -> FreqRangeList #}

makeFields ''FreqRangeList

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

data TuningStepList =
  TuningStepList {
      _tuningstepModes :: Rmode
    , _tuningstepTs    :: ShortFreq
    }

{#pointer *tuning_step_list as TuningStepListPtr -> TuningStepList #}

makeFields ''TuningStepList

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

data FilterList =
  FilterList {
      _filterModes :: Rmode
    , _filterWidth :: Pbwidth
    }

{#pointer *filter_list as FilterListPtr -> FilterList #}

makeFields ''FilterList

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

data ExtList =
  ExtList {
      _extToken :: Token
    , _extVal   :: Value
    }

{#pointer *ext_list as ExtListPtr -> ExtList #}

makeFields ''ExtList


Added NFData instances for ErrorType and ErrorNum

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GDAL.Internal.CPLError (
    GDALException (..)
  , ErrorType (..)
  , ErrorNum (..)
  , isGDALException
  , isBindingException
  , throwBindingException
  , bindingExceptionToException
  , bindingExceptionFromException
  , checkCPLError
  , checkGDALCall
  , checkGDALCall_
  , withQuietErrorHandler
) where

{# context lib = "gdal" prefix = "CPL" #}

import Control.Monad (void, liftM)
import Control.DeepSeq (NFData(..))
import Control.Monad.Catch (MonadThrow(throwM))
import Control.Exception (
    Exception (..)
  , SomeException
  , throw
  , finally
  )
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Typeable (Typeable, cast)

import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.Storable (peekByteOff, peek)
import Foreign.Marshal.Utils (with)

-- work around  https://github.com/haskell/c2hs/issues/151
import qualified Foreign.C.Types as C2HSImp

import GDAL.Internal.Util (toEnumC, runBounded)
import GDAL.Internal.CPLString (peekEncodedCString)

#include "cpl_error.h"
#include "errorhandler.h"

{# enum CPLErr as ErrorType {upcaseFirstLetter} deriving (Eq, Show) #}

instance NFData ErrorType where
  rnf e = seq e ()

data GDALException
  = forall e. Exception e =>
    GDALBindingException !e
  | GDALException        { gdalErrType :: !ErrorType
                         , gdalErrNum  :: !ErrorNum
                         , gdalErrMsg  :: !Text}
  deriving Typeable

deriving instance Show GDALException

instance Exception GDALException

bindingExceptionToException :: Exception e=> e -> SomeException
bindingExceptionToException = toException . GDALBindingException

bindingExceptionFromException :: Exception e => SomeException -> Maybe e
bindingExceptionFromException x = do
  GDALBindingException a <- fromException x
  cast a

throwBindingException :: (MonadThrow m, Exception e) => e -> m a
throwBindingException = throwM . bindingExceptionToException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

isBindingException :: SomeException -> Bool
isBindingException e
  = case fromException e of
      Just (GDALBindingException _) -> True
      _                             -> False

{#enum define ErrorNum {
    CPLE_None            as None
  , CPLE_AppDefined      as AppDefined
  , CPLE_OutOfMemory     as OutOfMemory
  , CPLE_FileIO          as FileIO
  , CPLE_OpenFailed      as OpenFailed
  , CPLE_IllegalArg      as IllegalArg
  , CPLE_NotSupported    as NotSupported
  , CPLE_AssertionFailed as AssertionFailed
  , CPLE_NoWriteAccess   as NoWriteAccess
  , CPLE_UserInterrupt   as UserInterrupt
  , CPLE_ObjectNull      as ObjectNull
  } deriving (Eq, Bounded, Show) #}

instance NFData ErrorNum where
  rnf e = seq e ()

checkGDALCall
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO a
checkGDALCall isOk act = withErrorHandler $ \ stack -> do
  a <- act
  err <- peekLastError stack
  case isOk err a of
    Nothing -> return a
    Just e  -> throw e
{-# INLINE checkGDALCall #-}

checkGDALCall_
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO ()
{-# INLINE checkGDALCall_ #-}
checkGDALCall_ isOk = void . checkGDALCall isOk

checkCPLError :: Text -> IO CInt -> IO ()
checkCPLError msg = checkGDALCall_ $ \mExc r ->
  case (mExc, toEnumC r) of
    (Nothing, CE_None) -> Nothing
    (Nothing, e)       -> Just (GDALException e AssertionFailed msg)
    (e, _)             -> e
{-# INLINE checkCPLError #-}

{#pointer ErrorCell #}
type ErrorStack = Ptr ErrorCell

peekLastError :: ErrorStack -> IO (Maybe GDALException)
peekLastError stack = do
  ec <- peek stack
  if ec == nullPtr
    then return Nothing
    else do
      msg <- peekEncodedCString =<< {#get ErrorCell->msg #} ec
      errClass <- liftM toEnumC ({#get ErrorCell->errClass#} ec)
      errNo <- liftM toEnumC ({#get ErrorCell->errNo#} ec)
      return (Just (GDALException errClass errNo msg))

withErrorHandler :: (ErrorStack -> IO a) -> IO a
withErrorHandler act = runBounded $ with nullPtr $ \stack ->
  ({#call unsafe push_error_handler as ^#} stack >> act stack)
    `finally` ({#call unsafe pop_error_handler as ^#} stack)
{-# INLINE withErrorHandler #-}

withQuietErrorHandler :: IO a -> IO a
withQuietErrorHandler a = runBounded ((pushIt >> a) `finally` popIt)
  where
    pushIt = {#call unsafe CPLPushErrorHandler as ^#} c_quietErrorHandler
    popIt  = {#call unsafe CPLPopErrorHandler as ^#}

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr (CInt -> CInt -> Ptr CChar -> IO ())

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GDAL.Internal.CPLError (
    GDALException (..)
  , ErrorType (..)
  , ErrorNum (..)
  , isGDALException
  , isBindingException
  , throwBindingException
  , bindingExceptionToException
  , bindingExceptionFromException
  , checkCPLError
  , checkGDALCall
  , checkGDALCall_
  , withQuietErrorHandler
) where

{# context lib = "gdal" prefix = "CPL" #}

import Control.Monad (void, liftM)
import Control.Monad.Catch (MonadThrow(throwM))
import Control.Exception (
    Exception (..)
  , SomeException
  , throw
  , finally
  )
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Typeable (Typeable, cast)

import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.Storable (peekByteOff, peek)
import Foreign.Marshal.Utils (with)

-- work around  https://github.com/haskell/c2hs/issues/151
import qualified Foreign.C.Types as C2HSImp

import GDAL.Internal.Util (toEnumC, runBounded)
import GDAL.Internal.CPLString (peekEncodedCString)

#include "cpl_error.h"
#include "errorhandler.h"

{# enum CPLErr as ErrorType {upcaseFirstLetter} deriving (Eq, Show) #}

data GDALException
  = forall e. Exception e =>
    GDALBindingException !e
  | GDALException        { gdalErrType :: !ErrorType
                         , gdalErrNum  :: !ErrorNum
                         , gdalErrMsg  :: !Text}
  deriving Typeable

deriving instance Show GDALException

instance Exception GDALException

bindingExceptionToException :: Exception e=> e -> SomeException
bindingExceptionToException = toException . GDALBindingException

bindingExceptionFromException :: Exception e => SomeException -> Maybe e
bindingExceptionFromException x = do
  GDALBindingException a <- fromException x
  cast a

throwBindingException :: (MonadThrow m, Exception e) => e -> m a
throwBindingException = throwM . bindingExceptionToException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

isBindingException :: SomeException -> Bool
isBindingException e
  = case fromException e of
      Just (GDALBindingException _) -> True
      _                             -> False

{#enum define ErrorNum {
    CPLE_None            as None
  , CPLE_AppDefined      as AppDefined
  , CPLE_OutOfMemory     as OutOfMemory
  , CPLE_FileIO          as FileIO
  , CPLE_OpenFailed      as OpenFailed
  , CPLE_IllegalArg      as IllegalArg
  , CPLE_NotSupported    as NotSupported
  , CPLE_AssertionFailed as AssertionFailed
  , CPLE_NoWriteAccess   as NoWriteAccess
  , CPLE_UserInterrupt   as UserInterrupt
  , CPLE_ObjectNull      as ObjectNull
  } deriving (Eq, Bounded, Show) #}

checkGDALCall
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO a
checkGDALCall isOk act = withErrorHandler $ \ stack -> do
  a <- act
  err <- peekLastError stack
  case isOk err a of
    Nothing -> return a
    Just e  -> throw e
{-# INLINE checkGDALCall #-}

checkGDALCall_
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO ()
{-# INLINE checkGDALCall_ #-}
checkGDALCall_ isOk = void . checkGDALCall isOk

checkCPLError :: Text -> IO CInt -> IO ()
checkCPLError msg = checkGDALCall_ $ \mExc r ->
  case (mExc, toEnumC r) of
    (Nothing, CE_None) -> Nothing
    (Nothing, e)       -> Just (GDALException e AssertionFailed msg)
    (e, _)             -> e
{-# INLINE checkCPLError #-}

{#pointer ErrorCell #}
type ErrorStack = Ptr ErrorCell

peekLastError :: ErrorStack -> IO (Maybe GDALException)
peekLastError stack = do
  ec <- peek stack
  if ec == nullPtr
    then return Nothing
    else do
      msg <- peekEncodedCString =<< {#get ErrorCell->msg #} ec
      errClass <- liftM toEnumC ({#get ErrorCell->errClass#} ec)
      errNo <- liftM toEnumC ({#get ErrorCell->errNo#} ec)
      return (Just (GDALException errClass errNo msg))

withErrorHandler :: (ErrorStack -> IO a) -> IO a
withErrorHandler act = runBounded $ with nullPtr $ \stack ->
  ({#call unsafe push_error_handler as ^#} stack >> act stack)
    `finally` ({#call unsafe pop_error_handler as ^#} stack)
{-# INLINE withErrorHandler #-}

withQuietErrorHandler :: IO a -> IO a
withQuietErrorHandler a = runBounded ((pushIt >> a) `finally` popIt)
  where
    pushIt = {#call unsafe CPLPushErrorHandler as ^#} c_quietErrorHandler
    popIt  = {#call unsafe CPLPopErrorHandler as ^#}

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr (CInt -> CInt -> Ptr CChar -> IO ())


Fix memory leak.

Fix memory leak.

darcs-hash:20090201203541-ed7c9-b3b21c584d51a4662ca5126d9b025541c60ef94a.gz

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- |This module wraps the Expat API directly with IO operations
-- everywhere.  Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True
-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.  @parse@ returns @False@ on a parse error.
parseChunk :: Parser
              -> BS.ByteString
              -> Bool
              -> IO Bool
parseChunk parser@(Parser fp startRef endRef charRef) xml final = do
    bracket
        (do
            cStartH <- mkCStartElementHandler =<< readIORef startRef
            cEndH   <- mkCEndElementHandler =<< readIORef endRef
            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
            withParser parser $ \p -> do
                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
            return (cStartH, cEndH, cCharH))
        (\(cStartH, cEndH, cCharH) -> do
            freeHaskellFunPtr cStartH
            freeHaskellFunPtr cEndH
            freeHaskellFunPtr cCharH)
        (\_ -> doParseChunk parser xml final)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- |@parse data@ feeds /lazy/ bytestring data into a parser and returns
-- @True@ if there was no parse error.
parse :: Parser -> BSL.ByteString -> IO Bool
parse parser bs = feedChunk (BSL.toChunks bs) where
  feedChunk []      = return True
  feedChunk [chunk] = parseChunk parser chunk True
  feedChunk (c:cs)  = do ok <- parseChunk parser c False
                         if ok then feedChunk cs
                               else return False

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs.
type StartElementHandler  = String -> [(String,String)] -> IO ()
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name.
type EndElementHandler    = String -> IO ()
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text.
type CharacterDataHandler = String -> IO ()

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)
wrapStartElementHandler :: StartElementHandler -> CStartElementHandler
wrapStartElementHandler handler = h where
  h ptr cname cattrs = do
    name <- peekCString cname
    cattrlist <- peekArray0 nullPtr cattrs
    attrlist <- mapM peekCString cattrlist
    handler name (pairwise attrlist)
-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler = do
  withParser parser $ \p -> do
  writeIORef startRef $ wrapStartElementHandler handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: EndElementHandler -> CEndElementHandler
wrapEndElementHandler handler = h where
  h ptr cname = do
    name <- peekCString cname
    handler name

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler = do
  withParser parser $ \p -> do
  writeIORef endRef $ wrapEndElementHandler handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler handler = h where
  h ptr cdata len = do
    data_ <- peekCStringLen (cdata, fromIntegral len)
    handler data_
-- |Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do
  withParser parser $ \p -> do
  writeIORef charRef $ wrapCharacterDataHandler handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- |This module wraps the Expat API directly with IO operations
-- everywhere.  Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
newtype Parser = Parser (ForeignPtr ())

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  return $ Parser fptr

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True
-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.  @parse@ returns @False@ on a parse error.
{#fun XML_Parse as parseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- |@parse data@ feeds /lazy/ bytestring data into a parser and returns
-- @True@ if there was no parse error.
parse :: Parser -> BSL.ByteString -> IO Bool
parse parser bs = feedChunk (BSL.toChunks bs) where
  feedChunk []      = return True
  feedChunk [chunk] = parseChunk parser chunk True
  feedChunk (c:cs)  = do ok <- parseChunk parser c False
                         if ok then feedChunk cs
                               else return False

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs.
type StartElementHandler  = String -> [(String,String)] -> IO ()
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name.
type EndElementHandler    = String -> IO ()
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text.
type CharacterDataHandler = String -> IO ()

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
foreign import ccall "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)
wrapStartElementHandler :: StartElementHandler
                        -> IO (FunPtr CStartElementHandler)
wrapStartElementHandler handler = mkCStartElementHandler h where
  h ptr cname cattrs = do
    name <- peekCString cname
    cattrlist <- peekArray0 nullPtr cattrs
    attrlist <- mapM peekCString cattrlist
    handler name (pairwise attrlist)
-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser handler = do
  withParser parser $ \p -> do
  handler' <- wrapStartElementHandler handler
  {#call unsafe XML_SetStartElementHandler as ^#} p handler'

type CEndElementHandler = Ptr () -> CString -> IO ()
foreign import ccall "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: EndElementHandler
                      -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler handler = mkCEndElementHandler h where
  h ptr cname = do
    name <- peekCString cname
    handler name
-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser handler = do
  withParser parser $ \p -> do
  handler' <- wrapEndElementHandler handler
  {#call unsafe XML_SetEndElementHandler as ^#} p handler'

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
foreign import ccall "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: CharacterDataHandler
                      -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler handler = mkCCharacterDataHandler h where
  h ptr cdata len = do
    data_ <- peekCStringLen (cdata, fromIntegral len)
    handler data_
-- |Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser handler = do
  withParser parser $ \p -> do
  handler' <- wrapCharacterDataHandler handler
  {#call unsafe XML_SetCharacterDataHandler as ^#} p handler'

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []