pango-0.11.0: Graphics/Rendering/Pango/Attributes.chs

{-# LANGUAGE CPP #-}
{-# 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#}
import Data.List ( sortBy )
import Data.Char ( ord, chr )
import Control.Monad ( liftM )

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

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 <- {#call unsafe attr_list_new#}
  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
	   {#call unsafe 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 $ {#call unsafe attr_language_new#} lang
crAttr c AttrFamily { paStart=s, paEnd=e, paFamily = fam } =
  setAttrPos c s e $ withUTFString fam $ {#call unsafe attr_family_new#}
crAttr c AttrStyle { paStart=s, paEnd=e, paStyle = style } =
  setAttrPos c s e $
  {#call unsafe attr_style_new#} (fromIntegral (fromEnum style))
crAttr c AttrWeight { paStart=s, paEnd=e, paWeight = weight } =
  setAttrPos c s e $
  {#call unsafe attr_weight_new#} (fromIntegral (fromEnum weight))
crAttr c AttrVariant { paStart=s, paEnd=e, paVariant = variant } =
  setAttrPos c s e $
  {#call unsafe attr_variant_new#} (fromIntegral (fromEnum variant))
crAttr c AttrStretch { paStart=s, paEnd=e, paStretch = stretch } =
  setAttrPos c s e $
  {#call unsafe attr_stretch_new#} (fromIntegral (fromEnum stretch))
crAttr c AttrSize { paStart=s, paEnd=e, paSize = pu } =
  setAttrPos c s e $ {#call unsafe attr_size_new#} (puToInt pu)
#if PANGO_VERSION_CHECK(1,8,0)
crAttr c AttrAbsSize { paStart=s, paEnd=e, paSize = pu } =
  setAttrPos c s e $ {#call unsafe attr_size_new_absolute#} (puToInt pu)
#endif
crAttr c AttrFontDescription { paStart=s, paEnd=e, paFontDescription = fd } =
  setAttrPos c s e $ {#call unsafe attr_font_desc_new#} fd
crAttr c AttrForeground { paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ {#call unsafe attr_foreground_new#}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
crAttr c AttrBackground { paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ {#call unsafe attr_background_new#}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
crAttr c AttrUnderline { paStart=s, paEnd=e, paUnderline = underline } =
  setAttrPos c s e $ do
  {#call unsafe attr_underline_new#} (fromIntegral (fromEnum underline))
#if  (defined (WIN32) && PANGO_VERSION_CHECK(1,10,0)) \
 || (!defined (WIN32) && PANGO_VERSION_CHECK(1,8,0))
crAttr c AttrUnderlineColor {paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ {#call unsafe attr_underline_color_new#}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
#endif
crAttr c AttrStrikethrough { paStart=s, paEnd=e, paStrikethrough = st } =
  setAttrPos c s e $ do
  {#call unsafe attr_strikethrough_new#} (fromIntegral (fromEnum st))
#if  (defined (WIN32) && PANGO_VERSION_CHECK(1,10,0)) \
 || (!defined (WIN32) && PANGO_VERSION_CHECK(1,8,0))
crAttr c AttrStrikethroughColor {paStart=s, paEnd=e, paColor = Color r g b } =
  setAttrPos c s e $ {#call unsafe attr_strikethrough_color_new#}
  (fromIntegral r) (fromIntegral g) (fromIntegral b)
#endif
crAttr c AttrRise { paStart=s, paEnd=e, paRise = pu } =
  setAttrPos c s e $ {#call unsafe attr_rise_new#} (puToInt pu)
#if PANGO_VERSION_CHECK(1,8,0)
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
    {#call unsafe attr_shape_new#} (castPtr rect1Ptr) (castPtr rect2Ptr)
#endif
crAttr c AttrScale { paStart=s, paEnd=e, paScale = scale } =
  setAttrPos c s e $ 
  {#call unsafe attr_scale_new#} (realToFrac scale)
#if PANGO_VERSION_CHECK(1,4,0)
crAttr c AttrFallback { paStart=s, paEnd=e, paFallback = fb } =
  setAttrPos c s e $
  {#call unsafe attr_fallback_new#} (fromBool fb)
#endif
#if PANGO_VERSION_CHECK(1,6,0)
crAttr c AttrLetterSpacing { paStart=s, paEnd=e, paLetterSpacing = pu } =
  setAttrPos c s e $
  {#call unsafe attr_letter_spacing_new#} (puToInt pu)
#endif
#if PANGO_VERSION_CHECK(1,16,0)
crAttr c AttrGravity { paStart=s, paEnd=e, paGravity = g } =
  setAttrPos c s e $
  {#call unsafe attr_gravity_new#} (fromIntegral (fromEnum g))
crAttr c AttrGravityHint { paStart=s, paEnd=e, paGravityHint = g } =
  setAttrPos c s e $
  {#call unsafe attr_gravity_hint_new#} (fromIntegral (fromEnum g))
#endif

-- | Parse the marked-up text (see 'Graphics.UI.Gtk.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 :: 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 <- {#call unsafe 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
      {#call unsafe g_free#} (castPtr strPtr)
      attrList <- peek attrListPtr
      attrs <- fromAttrList (genUTFOfs str) attrList
      return (attrs, chr (fromIntegral accel), str)

{#pointer *PangoAttrIterator #}

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