{-# LINE 2 "./Graphics/Rendering/Pango/Attributes.chs" #-}
{-# OPTIONS_HADDOCK hide #-}
-- -*-haskell-*-
-- GIMP Toolkit (GTK) - pango text attributes
--
-- Author : Axel Simon
--
-- Created: 20 October 2005
--
-- Copyright (C) 1999-2005 Axel Simon
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer : gtk2hs-users@lists.sourceforge.net
-- Stability : provisional
-- Portability : portable (depends on GHC)
--
-- Defines text attributes.
--
module Graphics.Rendering.Pango.Attributes (
  withAttrList,
  parseMarkup,
  fromAttrList,
  readAttrList
  ) where

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GError
import System.Glib.GList
import Graphics.Rendering.Pango.Structs
import Graphics.Rendering.Pango.BasicTypes
{-# LINE 44 "./Graphics/Rendering/Pango/Attributes.chs" #-}
import Data.List ( sortBy )
import Data.Char ( ord, chr )
import Control.Monad ( liftM )


{-# LINE 49 "./Graphics/Rendering/Pango/Attributes.chs" #-}

foreign import ccall unsafe "pango_attr_list_unref"
  pango_attr_list_unref :: PangoAttrList -> IO ()

-- Create an attribute list.
withAttrList :: PangoString -> [PangoAttribute] -> (Ptr () -> IO a) -> IO a
withAttrList _ [] act = act nullPtr
withAttrList (PangoString correct _ _) pas act = do
  alPtr <- pango_attr_list_new
{-# LINE 58 "./Graphics/Rendering/Pango/Attributes.chs" #-}
  let pas' = sortBy (\pa1 pa2 -> case compare (paStart pa1) (paStart pa2) of
                     EQ -> compare (paEnd pa1) (paEnd pa2)
                     other -> other) pas
  mapM_ (\pa -> do
           paPtr <- crAttr correct pa
           pango_attr_list_insert alPtr (castPtr paPtr)) pas'
  res <- act alPtr
  pango_attr_list_unref alPtr
  return res

-- Create a PangoAttribute.
crAttr :: UTFCorrection -> PangoAttribute -> IO CPangoAttribute
crAttr c AttrLanguage { paStart=s, paEnd=e, paLang = lang } =
  setAttrPos c s e $ (\(Language arg1) -> pango_attr_language_new arg1) lang
crAttr c AttrFamily { paStart=s, paEnd=e, paFamily = fam } =
  setAttrPos c s e $ withUTFString fam $ pango_attr_family_new
{-# LINE 74 "./Graphics/Rendering/Pango/Attributes.chs" #-}
crAttr c AttrStyle { paStart=s, paEnd=e, paStyle = style } =
  setAttrPos c s e $
  pango_attr_style_new (fromIntegral (fromEnum style))
crAttr c AttrWeight { paStart=s, paEnd=e, paWeight = weight } =
  setAttrPos c s e $
  pango_attr_weight_new (fromIntegral (fromEnum weight))
crAttr c AttrVariant { paStart=s, paEnd=e, paVariant = variant } =
  setAttrPos c s e $
  pango_attr_variant_new (fromIntegral (fromEnum variant))
crAttr c AttrStretch { paStart=s, paEnd=e, paStretch = stretch } =
  setAttrPos c s e $
  pango_attr_stretch_new (fromIntegral (fromEnum stretch))
crAttr c AttrSize { paStart=s, paEnd=e, paSize = pu } =
  setAttrPos c s e $ pango_attr_size_new (puToInt pu)

crAttr c AttrAbsSize { paStart=s, paEnd=e, paSize = pu } =
  setAttrPos c s e $ pango_attr_size_new_absolute (puToInt pu)

crAttr c AttrFontDescription { paStart=s, paEnd=e, paFontDescription = fd } =
  setAttrPos c s e $ (\(FontDescription arg1) -> withForeignPtr arg1 $ \argPtr1 ->pango_attr_font_desc_new argPtr1) fd
crAttr c AttrForeground { paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ pango_attr_foreground_new
{-# LINE 96 "./Graphics/Rendering/Pango/Attributes.chs" #-}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
crAttr c AttrBackground { paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ pango_attr_background_new
{-# LINE 99 "./Graphics/Rendering/Pango/Attributes.chs" #-}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
crAttr c AttrUnderline { paStart=s, paEnd=e, paUnderline = underline } =
  setAttrPos c s e $ do
  pango_attr_underline_new (fromIntegral (fromEnum underline))


crAttr c AttrUnderlineColor {paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ pango_attr_underline_color_new
{-# LINE 107 "./Graphics/Rendering/Pango/Attributes.chs" #-}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)

crAttr c AttrStrikethrough { paStart=s, paEnd=e, paStrikethrough = st } =
  setAttrPos c s e $ do
  pango_attr_strikethrough_new (fromIntegral (fromEnum st))


crAttr c AttrStrikethroughColor {paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ pango_attr_strikethrough_color_new
{-# LINE 116 "./Graphics/Rendering/Pango/Attributes.chs" #-}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)

crAttr c AttrRise { paStart=s, paEnd=e, paRise = pu } =
  setAttrPos c s e $ pango_attr_rise_new (puToInt pu)

crAttr c AttrShape { paStart=s, paEnd=e, paInk = rect1, paLogical = rect2 } =
  setAttrPos c s e $ alloca $ \rect1Ptr -> alloca $ \rect2Ptr -> do
    poke rect1Ptr rect1
    poke rect2Ptr rect2
    pango_attr_shape_new (castPtr rect1Ptr) (castPtr rect2Ptr)

crAttr c AttrScale { paStart=s, paEnd=e, paScale = scale } =
  setAttrPos c s e $
  pango_attr_scale_new (realToFrac scale)

crAttr c AttrFallback { paStart=s, paEnd=e, paFallback = fb } =
  setAttrPos c s e $
  pango_attr_fallback_new (fromBool fb)


crAttr c AttrLetterSpacing { paStart=s, paEnd=e, paLetterSpacing = pu } =
  setAttrPos c s e $
  pango_attr_letter_spacing_new (puToInt pu)


crAttr c AttrGravity { paStart=s, paEnd=e, paGravity = g } =
  setAttrPos c s e $
  pango_attr_gravity_new (fromIntegral (fromEnum g))
crAttr c AttrGravityHint { paStart=s, paEnd=e, paGravityHint = g } =
  setAttrPos c s e $
  pango_attr_gravity_hint_new (fromIntegral (fromEnum g))


-- | Parse the marked-up text (see 'Graphics.Rendering.Pango.Markup.Markup'
-- format) to create a plain-text string and an attribute list.
--
-- * The attribute list is a list of lists of attribute. Each list describes
-- the attributes for the same span.
--
-- * If @accelMarker@ is not @'\0'@ (a zero character), the given character
-- will mark the character following it as an accelerator. For example,
-- @accelMarker@ might be an ampersand or underscore. All characters marked
-- as an accelerator will receive a 'UnderlineLow' attribute, and the
-- first character so marked will be returned as @accelChar@. If no
-- accelerator character is found, the @accelMarker@ character itself is
-- returned. Two @accelMarker@ characters following each other produce a
-- single literal @accelMarker@ character.
--
-- * If a parsing error occurs a 'System.Glib.GError.GError' is thrown.
--
parseMarkup ::
     (GlibString markup, GlibString string)
  => markup -- ^ the string containing markup
  -> Char -- ^ @accelMarker@ - the character that prefixes an accelerator
  -> IO ([[PangoAttribute]], Char, string) -- ^ list of attributes, the accelerator character found and the input string
  -- without markup
parseMarkup markup accelMarker = propagateGError $ \errPtr ->
  withUTFStringLen markup $ \(markupPtr,markupLen) ->
  alloca $ \attrListPtr ->
  alloca $ \strPtrPtr ->
  alloca $ \accelPtr -> do
    poke accelPtr (fromIntegral (ord accelMarker))
    success <- pango_parse_markup markupPtr
      (fromIntegral markupLen) (fromIntegral (ord accelMarker))
      (castPtr attrListPtr) strPtrPtr accelPtr errPtr
    if not (toBool success) then return undefined else do
      accel <- peek accelPtr
      strPtr <- peek strPtrPtr
      str <- peekUTFString strPtr
      g_free (castPtr strPtr)
      attrList <- peek attrListPtr
      attrs <- fromAttrList (genUTFOfs str) attrList
      return (attrs, chr (fromIntegral accel), str)

type PangoAttrIterator = Ptr (())
{-# LINE 191 "./Graphics/Rendering/Pango/Attributes.chs" #-}

-- | Convert an attribute list into a list of attributes.
fromAttrList :: UTFCorrection -> PangoAttrList -> IO [[PangoAttribute]]
fromAttrList correct attrListPtr = do
  iter <- pango_attr_list_get_iterator attrListPtr
  let readIter = do
        list <- pango_attr_iterator_get_attrs iter
        attrs <- if list==nullPtr then return [] else do
          attrPtrs <- fromGSList list
          mapM (fromAttr correct) attrPtrs
        more <- pango_attr_iterator_next iter
        if toBool more then liftM ((:) attrs) $ readIter else return []
  elems <- readIter
  pango_attr_iterator_destroy iter
  return elems

-- | Extract and delete an attribute.
--
fromAttr :: UTFCorrection -> CPangoAttribute -> IO PangoAttribute
fromAttr correct attrPtr = do
  attr <- readAttr correct attrPtr
  pango_attribute_destroy attrPtr
  return attr

readAttrList :: UTFCorrection -> PangoAttrList -> IO [[PangoAttribute]]
readAttrList correct attrListPtr = do
  elems <- fromAttrList correct attrListPtr
  pango_attr_list_unref attrListPtr
  return elems

foreign import ccall unsafe "pango_attr_list_new"
  pango_attr_list_new :: (IO (Ptr ()))

foreign import ccall unsafe "pango_attr_list_insert"
  pango_attr_list_insert :: ((Ptr ()) -> ((Ptr ()) -> (IO ())))

foreign import ccall unsafe "pango_attr_language_new"
  pango_attr_language_new :: ((Ptr Language) -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_family_new"
  pango_attr_family_new :: ((Ptr CChar) -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_style_new"
  pango_attr_style_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_weight_new"
  pango_attr_weight_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_variant_new"
  pango_attr_variant_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_stretch_new"
  pango_attr_stretch_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_size_new"
  pango_attr_size_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_size_new_absolute"
  pango_attr_size_new_absolute :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_font_desc_new"
  pango_attr_font_desc_new :: ((Ptr FontDescription) -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_foreground_new"
  pango_attr_foreground_new :: (CUShort -> (CUShort -> (CUShort -> (IO (Ptr ())))))

foreign import ccall unsafe "pango_attr_background_new"
  pango_attr_background_new :: (CUShort -> (CUShort -> (CUShort -> (IO (Ptr ())))))

foreign import ccall unsafe "pango_attr_underline_new"
  pango_attr_underline_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_underline_color_new"
  pango_attr_underline_color_new :: (CUShort -> (CUShort -> (CUShort -> (IO (Ptr ())))))

foreign import ccall unsafe "pango_attr_strikethrough_new"
  pango_attr_strikethrough_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_strikethrough_color_new"
  pango_attr_strikethrough_color_new :: (CUShort -> (CUShort -> (CUShort -> (IO (Ptr ())))))

foreign import ccall unsafe "pango_attr_rise_new"
  pango_attr_rise_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_shape_new"
  pango_attr_shape_new :: ((Ptr ()) -> ((Ptr ()) -> (IO (Ptr ()))))

foreign import ccall unsafe "pango_attr_scale_new"
  pango_attr_scale_new :: (CDouble -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_fallback_new"
  pango_attr_fallback_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_letter_spacing_new"
  pango_attr_letter_spacing_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_gravity_new"
  pango_attr_gravity_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_gravity_hint_new"
  pango_attr_gravity_hint_new :: (CInt -> (IO (Ptr ())))

foreign import ccall unsafe "pango_parse_markup"
  pango_parse_markup :: ((Ptr CChar) -> (CInt -> (CUInt -> ((Ptr ()) -> ((Ptr (Ptr CChar)) -> ((Ptr CUInt) -> ((Ptr (Ptr ())) -> (IO CInt))))))))

foreign import ccall unsafe "g_free"
  g_free :: ((Ptr ()) -> (IO ()))

foreign import ccall unsafe "pango_attr_list_get_iterator"
  pango_attr_list_get_iterator :: ((Ptr ()) -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_iterator_get_attrs"
  pango_attr_iterator_get_attrs :: ((Ptr ()) -> (IO (Ptr ())))

foreign import ccall unsafe "pango_attr_iterator_next"
  pango_attr_iterator_next :: ((Ptr ()) -> (IO CInt))

foreign import ccall unsafe "pango_attr_iterator_destroy"
  pango_attr_iterator_destroy :: ((Ptr ()) -> (IO ()))

foreign import ccall unsafe "pango_attribute_destroy"
  pango_attribute_destroy :: ((Ptr ()) -> (IO ()))