diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for simple-pango + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yoshikuni Jujo (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yoshikuni Jujo nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# simple-pango diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/csrc/pango_log_attr.c b/csrc/pango_log_attr.c new file mode 100644 --- /dev/null +++ b/csrc/pango_log_attr.c @@ -0,0 +1,20 @@ +#include +#include "pango_log_attr.h" + +void +pango_log_attr_to_struct(PangoLogAttr *src, PangoLogAttrStr *dst) +{ + dst->is_line_break = src->is_line_break; + dst->is_mandatory_break = src->is_mandatory_break; + dst->is_char_break = src->is_char_break; + dst->is_white = src->is_white; + dst->is_cursor_position = src->is_cursor_position; + dst->is_word_start = src->is_word_start; + dst->is_word_end = src->is_word_end; + dst->is_sentence_boundary = src->is_sentence_boundary; + dst->is_sentence_start = src->is_sentence_end; + dst->is_sentence_end = src->is_sentence_end; + dst->backspace_deletes_character = src->backspace_deletes_character; + dst->is_expandable_space = src->is_expandable_space; + dst->is_word_boundary = src->is_word_boundary; +} diff --git a/include/pango_log_attr.h b/include/pango_log_attr.h new file mode 100644 --- /dev/null +++ b/include/pango_log_attr.h @@ -0,0 +1,23 @@ +#ifndef _PANGO_LOG_ATTR_H +#define _PANGO_LOG_ATTR_H + +#include + +typedef struct { + guint is_line_break; + guint is_mandatory_break; + guint is_char_break; + guint is_white; + guint is_cursor_position; + guint is_word_start; + guint is_word_end; + guint is_sentence_boundary; + guint is_sentence_start; + guint is_sentence_end; + guint backspace_deletes_character; + guint is_expandable_space; + guint is_word_boundary; + } PangoLogAttrStr; + +#endif + diff --git a/simple-pango.cabal b/simple-pango.cabal new file mode 100644 --- /dev/null +++ b/simple-pango.cabal @@ -0,0 +1,115 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: simple-pango +version: 0.1.0.1 +synopsis: Binding to Pango library +description: Please see the README on GitHub at +category: Graphics +homepage: https://github.com/githubuser/simple-pango#readme +bug-reports: https://github.com/githubuser/simple-pango/issues +author: Author name here +maintainer: example@example.com +copyright: 2021 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + include/pango_log_attr.h + +source-repository head + type: git + location: https://github.com/githubuser/simple-pango + +library + exposed-modules: + Data.Font.VariationAxis + Data.Font.VariationAxis.Internal + Data.Text.CString + Data.Text.Foreign.StringPartial + Foreign.C.String.ForeignCStringLen + Foreign.C.String.Misc + Foreign.C.String.Utf8 + Foreign.Ptr.Misc + Graphics.Pango.Basic.BidirectionalText + Graphics.Pango.Basic.Fonts.PangoFontDescription + Graphics.Pango.Basic.Fonts.PangoFontDescription.Type + Graphics.Pango.Basic.Fonts.PangoFontDescription.Variations + Graphics.Pango.Basic.GlyphStorage + Graphics.Pango.Basic.GlyphStorage.Internal + Graphics.Pango.Basic.GlyphStorage.PangoMatrix + Graphics.Pango.Basic.GlyphStorage.PangoMatrix.Internal + Graphics.Pango.Basic.LayoutObjects.PangoLayout + Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal + Graphics.Pango.Basic.LayoutObjects.PangoLayoutIter + Graphics.Pango.Basic.LayoutObjects.PangoLayoutIter.Internal + Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine + Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine.Internal + Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage + Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage.Internal + Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript + Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum + Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Internal + Graphics.Pango.Basic.TextAttributes + Graphics.Pango.Basic.TextAttributes.Internal + Graphics.Pango.Basic.VerticalText + Graphics.Pango.LowLevel.Contexts + Graphics.Pango.LowLevel.Contexts.Internal + Graphics.Pango.LowLevel.TabStops + Graphics.Pango.LowLevel.TabStops.Internal + Graphics.Pango.Rendering.Cairo + other-modules: + Paths_simple_pango + hs-source-dirs: + src + include-dirs: + include + c-sources: + csrc/pango_log_attr.c + pkgconfig-depends: + pangocairo + build-depends: + array + , base >=4.7 && <5 + , bytestring + , c-enum + , c-struct + , containers + , glib-stopgap + , primitive + , simple-cairo + , template-haskell + , text + , union-angle + , union-color + default-language: Haskell2010 + +test-suite simple-pango-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_simple_pango + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + array + , base >=4.7 && <5 + , bytestring + , c-enum + , c-struct + , containers + , glib-stopgap + , primitive + , simple-cairo + , simple-pango + , template-haskell + , text + , union-angle + , union-color + default-language: Haskell2010 diff --git a/src/Data/Font/VariationAxis.hs b/src/Data/Font/VariationAxis.hs new file mode 100644 --- /dev/null +++ b/src/Data/Font/VariationAxis.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Data.Font.VariationAxis ( + -- * AXIS CLASS + FontDescriptionAxis, + -- * ADD AXIS + fontDescriptionAddAxis, + -- * SET AND GET AXIS + Variations, variationsEmpty, variationsSetAxis, variationsGetAxis, + -- * SHOW AND READ VARIATIONS + showVariations, readVariations, + -- * DEFAULT AXES + Weight(..), Width(..), Slant(..), Italic(..), OpticalSize(..) + ) where + +import Data.Font.VariationAxis.Internal + +fontDescriptionAddAxis "Weight" "wght" +fontDescriptionAddAxis "Width" "wdth" +fontDescriptionAddAxis "Italic" "ital" +fontDescriptionAddAxis "OpticalSize" "opsz" +fontDescriptionAddAxis "Slant" "slnt" diff --git a/src/Data/Font/VariationAxis/Internal.hs b/src/Data/Font/VariationAxis/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Font/VariationAxis/Internal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Data.Font.VariationAxis.Internal ( + -- * AXIS CLASS + FontDescriptionAxis, + -- * ADD AXIS + fontDescriptionAddAxis, + -- * SET AND GET AXIS + Variations, variationsEmpty, variationsSetAxis, variationsGetAxis, + -- * SHOW AND READ VARIATIONS + showVariations, readVariations ) where + +import Control.Arrow + +import qualified Data.Map as M +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +import Language.Haskell.TH + +class FontDescriptionAxis a where + fontDescriptionAxisTag :: BS.ByteString + fontDescriptionAxisToDouble :: a -> Double + fontDescriptionAxisFromDouble :: Double -> a + +newtype Variations = Variations { getVariations :: M.Map BS.ByteString Double } + deriving Show + +variationsEmpty :: Variations +variationsEmpty = Variations M.empty + +fontDescriptionAddAxis :: String -> String -> DecsQ +fontDescriptionAddAxis a t = (\n i -> [n, i]) + <$> fontDescriptionAddAxisNewtype a + <*> fontDescriptionAddAxisInstance a t + +fontDescriptionAddAxisNewtype :: String -> DecQ +fontDescriptionAddAxisNewtype a = + newtypeD (cxt []) + (mkName a) [] Nothing (recC (mkName a) [ + varBangType (mkName $ "get" ++ a) + $ bangType (bang noSourceUnpackedness noSourceStrictness) (conT ''Double) ]) + [derivClause Nothing [conT ''Show]] + +fontDescriptionAddAxisInstance :: String -> String -> DecQ +fontDescriptionAddAxisInstance a t = instanceD (cxt []) (conT ''FontDescriptionAxis `appT` conT (mkName a)) [ + valD (varP 'fontDescriptionAxisTag) (normalB . litE $ StringL t) [], + valD (varP 'fontDescriptionAxisToDouble) (normalB . varE . mkName $ "get" ++ a) [], + valD (varP 'fontDescriptionAxisFromDouble) (normalB . conE $ mkName a) [] + ] + +showVariations :: Variations -> BS.ByteString +showVariations = BS.intercalate "," . ((\(a, v) -> a <> "=" <> v) . (id *** BSC.pack . show) <$>) . M.toList . getVariations + +readVariations :: BS.ByteString -> Variations +readVariations = Variations . M.fromList . ((\[a, v] -> (a, read $ BSC.unpack v)) . BSC.split '=' <$>) . BSC.split ',' + +variationsSetAxis :: forall a . FontDescriptionAxis a => a -> Variations -> Variations +variationsSetAxis a = Variations . M.insert + (fontDescriptionAxisTag @a) + (fontDescriptionAxisToDouble a) . getVariations + +variationsGetAxis :: + forall a . FontDescriptionAxis a => Variations -> Maybe a +variationsGetAxis (Variations as) = fontDescriptionAxisFromDouble + <$> M.lookup (fontDescriptionAxisTag @a) as diff --git a/src/Data/Text/CString.hs b/src/Data/Text/CString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/CString.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LambdaCase, TupleSections #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Data.Text.CString (peekCStringText) where + +import Foreign.C.String +import Foreign.C.String.Misc +import Control.Monad + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +peekCStringText :: CString -> IO T.Text +peekCStringText = T.peekCStringLen <=< toCStringLen diff --git a/src/Data/Text/Foreign/StringPartial.hs b/src/Data/Text/Foreign/StringPartial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Foreign/StringPartial.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Data.Text.Foreign.StringPartial ( + CStringPart, emptyOrCStringPart, peekCStringPart, withCStringPart + ) where + +import Foreign.Ptr +import Foreign.C.Types + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +type CStringPart = (Ptr CChar, Ptr CChar) + +emptyOrCStringPart :: a -> a -> CStringPart -> a +emptyOrCStringPart d f (s, e) | s == e = d | otherwise = f + +peekCStringPart :: CStringPart -> IO T.Text +peekCStringPart (s, e) = T.peekCStringLen (s, e `minusPtr` s) + +withCStringPart :: T.Text -> (CStringPart -> IO a) -> IO a +withCStringPart t f = T.withCStringLen t \(p, l) -> f (p, p `plusPtr` l) diff --git a/src/Foreign/C/String/ForeignCStringLen.hs b/src/Foreign/C/String/ForeignCStringLen.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String/ForeignCStringLen.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LambdaCase, TupleSections #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Foreign.C.String.ForeignCStringLen ( + ForeignCStringLen, copyToForeignCStringLen, withForeignCStringLen + ) where + +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.C.String +import Foreign.C.Types + +type ForeignCStringLen = (ForeignPtr CChar, Int) + +copyToForeignCStringLen :: CStringLen -> IO ForeignCStringLen +copyToForeignCStringLen (cs, n) = do + p <- mallocBytes n + copyBytes p cs n + newForeignCStringLen (p, n) (free p) + +newForeignCStringLen :: CStringLen -> IO () -> IO ForeignCStringLen +newForeignCStringLen (p, l) fr = (, l) <$> newForeignPtr p fr + +withForeignCStringLen :: ForeignCStringLen -> (CStringLen -> IO a) -> IO a +withForeignCStringLen (fp, l) f = withForeignPtr fp $ f . (, l) diff --git a/src/Foreign/C/String/Misc.hs b/src/Foreign/C/String/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String/Misc.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LambdaCase, TupleSections #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Foreign.C.String.Misc (toCStringLen, copyCString) where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.String + +toCStringLen :: CString -> IO CStringLen +toCStringLen cs = (cs ,) <$> cStringLength cs + +cStringLength :: CString -> IO Int +cStringLength p = peek p >>= \case + 0 -> pure 0 + _ -> (+ 1) <$> cStringLength (p `plusPtr` 1) + +copyCString :: CString -> Int -> IO CString +copyCString cs n = do + cs' <- mallocBytes n + cs' <$ copyBytes cs' cs n diff --git a/src/Foreign/C/String/Utf8.hs b/src/Foreign/C/String/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String/Utf8.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Foreign.C.String.Utf8 (byteIndices) where + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Data.Bits + +byteIndices :: CStringLen -> IO [Int] +byteIndices = ((0 :) <$>) . go + where + go (_, n) | n <= 0 = pure [] + go (p, n) = do + d <- byteToLen <$> peek p + (d :) . ((+ d) <$>) <$> go (p `plusPtr` d, n - d) + +byteToLen :: Num n => CChar -> n +byteToLen c + | c .&. 0x80 == 0 = 1 + | c .&. 0xe0 == 0xc0 = 2 + | c .&. 0xf0 == 0xe0 = 3 + | c .&. 0xf8 == 0xf0 = 4 + | otherwise = error "Invalid UTF-8" diff --git a/src/Foreign/Ptr/Misc.hs b/src/Foreign/Ptr/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Ptr/Misc.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Foreign.Ptr.Misc (pattern NullPtr) where + +import Foreign.Ptr + +pattern NullPtr :: Ptr a +pattern NullPtr <- ((== nullPtr) -> True) where NullPtr = nullPtr diff --git a/src/Graphics/Pango/Basic/BidirectionalText.hsc b/src/Graphics/Pango/Basic/BidirectionalText.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/BidirectionalText.hsc @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.BidirectionalText ( + -- * ENUM + -- ** PangoDirection + PangoDirection, + pattern PangoDirectionLtr, pattern PangoDirectionRtl, + pattern PangoDirectionTtbLtr, pattern PangoDirectionTtbRtl, + pattern PangoDirectionWeakLtr, pattern PangoDirectionWeakRtl, + pattern PangoDirectionNeutral, + + -- ** PangoBidiType + PangoBidiType, + pattern PangoBidiTypeL, pattern PangoBidiTypeLre, + pattern PangoBidiTypeLro, pattern PangoBidiTypeR, + pattern PangoBidiTypeAl, pattern PangoBidiTypeRle, + pattern PangoBidiTypeRlo, pattern PangoBidiTypePdf, + pattern PangoBidiTypeEn, pattern PangoBidiTypeEs, + pattern PangoBidiTypeEt, pattern PangoBidiTypeAn, + pattern PangoBidiTypeCs, pattern PangoBidiTypeNsm, + pattern PangoBidiTypeBn, pattern PangoBidiTypeB, + pattern PangoBidiTypeS, pattern PangoBidiTypeWs, + pattern PangoBidiTypeOn, + + -- * FUNCTION + pangoUnicharDirection, pangoFindBaseDir, pangoBidiTypeForUnichar ) where + +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Enum +import Data.Word +import Data.Char +import System.IO.Unsafe + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +#include + +enum "PangoDirection" ''#{type PangoDirection} [''Show, ''Read] [ + ("PangoDirectionLtr", #{const PANGO_DIRECTION_LTR}), + ("PangoDirectionRtl", #{const PANGO_DIRECTION_RTL}), + ("PangoDirectionTtbLtr", #{const PANGO_DIRECTION_TTB_LTR}), + ("PangoDirectionTtbRtl", #{const PANGO_DIRECTION_TTB_RTL}), + ("PangoDirectionWeakLtr", #{const PANGO_DIRECTION_WEAK_LTR}), + ("PangoDirectionWeakRtl", #{const PANGO_DIRECTION_WEAK_RTL}), + ("PangoDirectionNeutral", #{const PANGO_DIRECTION_NEUTRAL}) ] + +enum "PangoBidiType" ''#{type PangoBidiType} [''Show, ''Read] [ + ("PangoBidiTypeL", #{const PANGO_BIDI_TYPE_L}), + ("PangoBidiTypeLre", #{const PANGO_BIDI_TYPE_LRE}), + ("PangoBidiTypeLro", #{const PANGO_BIDI_TYPE_LRO}), + ("PangoBidiTypeR", #{const PANGO_BIDI_TYPE_R}), + ("PangoBidiTypeAl", #{const PANGO_BIDI_TYPE_AL}), + ("PangoBidiTypeRle", #{const PANGO_BIDI_TYPE_RLE}), + ("PangoBidiTypeRlo", #{const PANGO_BIDI_TYPE_RLO}), + ("PangoBidiTypePdf", #{const PANGO_BIDI_TYPE_PDF}), + ("PangoBidiTypeEn", #{const PANGO_BIDI_TYPE_EN}), + ("PangoBidiTypeEs", #{const PANGO_BIDI_TYPE_ES}), + ("PangoBidiTypeEt", #{const PANGO_BIDI_TYPE_ET}), + ("PangoBidiTypeAn", #{const PANGO_BIDI_TYPE_AN}), + ("PangoBidiTypeCs", #{const PANGO_BIDI_TYPE_CS}), + ("PangoBidiTypeNsm", #{const PANGO_BIDI_TYPE_NSM}), + ("PangoBidiTypeBn", #{const PANGO_BIDI_TYPE_BN}), + ("PangoBidiTypeB", #{const PANGO_BIDI_TYPE_B}), + ("PangoBidiTypeS", #{const PANGO_BIDI_TYPE_S}), + ("PangoBidiTypeWs", #{const PANGO_BIDI_TYPE_WS}), + ("PangoBidiTypeOn", #{const PANGO_BIDI_TYPE_ON}) ] + +pangoUnicharDirection :: Char -> PangoDirection +pangoUnicharDirection = + unsafePerformIO . c_pango_unichar_direction . fromIntegral . ord + +foreign import ccall "pango_unichar_direction" c_pango_unichar_direction :: + #{type gunichar} -> IO PangoDirection + +pangoFindBaseDir :: T.Text -> PangoDirection +pangoFindBaseDir t = unsafePerformIO + $ T.withCStringLen t \(cs, l) -> c_pango_find_base_dir cs $ fromIntegral l + +foreign import ccall "pango_find_base_dir" c_pango_find_base_dir :: + CString -> CInt -> IO PangoDirection + +pangoBidiTypeForUnichar :: Char -> PangoBidiType +pangoBidiTypeForUnichar = + unsafePerformIO . c_pango_bidi_type_for_unichar . fromIntegral . ord + +foreign import ccall "pango_bidi_type_for_unichar" + c_pango_bidi_type_for_unichar :: #{type gunichar} -> IO PangoBidiType diff --git a/src/Graphics/Pango/Basic/Fonts/PangoFontDescription.hsc b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription.hsc @@ -0,0 +1,398 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.Fonts.PangoFontDescription ( + -- * TYPE + -- ** PangoFontDescription + PangoFontDescription, + + -- ** PangoFontDescriptionNullable + PangoFontDescriptionNullable, + pangoFontDescriptionFromNullable, pangoFontDescriptionToNullable, + + -- ** PangoFontDescriptionPrim + PangoFontDescriptionPrim, + PangoFontDescriptionST, PangoFontDescriptionIO, + pangoFontDescriptionFreeze, pangoFontDescriptionThaw, + pangoFontDescriptionCopy, + + -- * FUNCTION + pangoFontDescriptionNew, + PangoFontDescriptionSetting, + pangoFontDescriptionSet, pangoFontDescriptionGet, + pangoFontDescriptionUnset, + pangoFontDescriptionMerge, pangoFontDescriptionBetterMatch, + pangoFontDescriptionToString, pangoFontDescriptionToFilename, + + -- * SETTING + -- ** Family + Family(..), + + -- ** Style + PangoStyle(..), + pattern PangoStyleNormal, pattern PangoStyleOblique, + pattern PangoStyleItalic, + + -- ** Variant + PangoVariant(..), + pattern PangoVariantNormal, pattern PangoVariantSmallCaps, + + -- ** Weight + PangoWeight(..), + pattern PangoWeightThin, pattern PangoWeightUltralight, + pattern PangoWeightLight, pattern PangoWeightSemilight, + pattern PangoWeightBook, pattern PangoWeightNormal, + pattern PangoWeightMedium, pattern PangoWeightSemibold, + pattern PangoWeightBold, pattern PangoWeightUltrabold, + pattern PangoWeightHeavy, pattern PangoWeightUltraheavy, + + -- ** Stretch + PangoStretch(..), + pattern PangoStretchUltraCondensed, pattern PangoStretchExtraCondensed, + pattern PangoStretchCondensed, pattern PangoStretchSemiCondensed, + pattern PangoStretchNormal, pattern PangoStretchSemiExpanded, + pattern PangoStretchExpanded, pattern PangoStretchExtraExpanded, + pattern PangoStretchUltraExpanded, + + -- ** Size + Size(..) + + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer) +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Enum +import Control.Monad.Primitive +import Data.Bits +import Data.Bool +import Data.Word +import Data.Int + +import System.GLib.Bool +import Graphics.Pango.Basic.Fonts.PangoFontDescription.Type +import Graphics.Pango.Basic.VerticalText + +import System.IO.Unsafe + +#include + +enum "PangoFontMask" ''#{type PangoFontMask} [''Show] [ + ("PangoFontMaskFamily", #{const PANGO_FONT_MASK_FAMILY}), + ("PangoFontMaskStyle", #{const PANGO_FONT_MASK_STYLE}), + ("PangoFontMaskVariant", #{const PANGO_FONT_MASK_VARIANT}), + ("PangoFontMaskWeight", #{const PANGO_FONT_MASK_WEIGHT}), + ("PangoFontMaskStretch", #{const PANGO_FONT_MASK_STRETCH}), + ("PangoFontMaskSize", #{const PANGO_FONT_MASK_SIZE}), + ("PangoFontMaskGravity", #{const PANGO_FONT_MASK_GRAVITY}), + ("PangoFontMaskVariations", #{const PANGO_FONT_MASK_VARIATIONS}) ] + +pangoFontDescriptionNew :: + PrimMonad m => m (PangoFontDescriptionPrim (PrimState m)) +pangoFontDescriptionNew = unsafeIOToPrim + $ mkPangoFontDescriptionPrim =<< c_pango_font_description_new + +foreign import ccall "pango_font_description_new" + c_pango_font_description_new :: IO (Ptr PangoFontDescription) + +class PangoFontDescriptionSetting s where + pangoFontDescriptionSet :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> s -> m () + pangoFontDescriptionGetUnsafe :: PangoFontDescription -> s + pangoFontDescriptionMaskBit :: PangoFontMask + +pangoFontDescriptionGet :: forall s . PangoFontDescriptionSetting s => + PangoFontDescription -> Maybe s +pangoFontDescriptionGet = \case + fd -> let + PangoFontMask fm = pangoFontDescriptionGetSetFields fd + PangoFontMask mb = pangoFontDescriptionMaskBit @s in + bool Nothing (Just $ pangoFontDescriptionGetUnsafe fd) $ fm .&. mb /= zeroBits + +pangoFontDescriptionGetSetFields :: PangoFontDescription -> PangoFontMask +pangoFontDescriptionGetSetFields (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + PangoFontMask <$> c_pango_font_description_get_set_fields pfd + +foreign import ccall "pango_font_description_get_set_fields" + c_pango_font_description_get_set_fields :: + Ptr PangoFontDescription -> IO #type PangoFontMask + +pangoFontDescriptionUnset :: forall s m . (PangoFontDescriptionSetting s, PrimMonad m) => + PangoFontDescriptionPrim (PrimState m) -> m () +pangoFontDescriptionUnset fd = pangoFontDescriptionUnsetFields fd (pangoFontDescriptionMaskBit @s) + +pangoFontDescriptionUnsetFields :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoFontMask -> m () +pangoFontDescriptionUnsetFields (PangoFontDescriptionPrim fpfd) (PangoFontMask msk) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> + c_pango_font_description_unset_fields pfd msk + +foreign import ccall "pango_font_description_unset_fields" + c_pango_font_description_unset_fields :: + Ptr PangoFontDescription -> #{type PangoFontMask} -> IO () + +newtype Family = Family String deriving Show + +instance PangoFontDescriptionSetting Family where + pangoFontDescriptionSet fd (Family f) = pangoFontDescriptionSetFamily fd f + pangoFontDescriptionGetUnsafe fd = Family $ pangoFontDescriptionGetFamily fd + pangoFontDescriptionMaskBit = PangoFontMaskFamily + +pangoFontDescriptionSetFamily :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> String -> m () +pangoFontDescriptionSetFamily (PangoFontDescriptionPrim fpfd) f = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> withCString f \cf -> + c_pango_font_description_set_family pfd cf + +foreign import ccall "pango_font_description_set_family" c_pango_font_description_set_family :: + Ptr PangoFontDescription -> CString -> IO () + +pangoFontDescriptionGetFamily :: PangoFontDescription -> String +pangoFontDescriptionGetFamily (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + peekCString =<< c_pango_font_description_get_family pfd + +foreign import ccall "pango_font_description_get_family" c_pango_font_description_get_family :: + Ptr PangoFontDescription -> IO CString + +enum "PangoStyle" ''#{type PangoStyle} [''Show] [ + ("PangoStyleNormal", #{const PANGO_STYLE_NORMAL}), + ("PangoStyleOblique", #{const PANGO_STYLE_OBLIQUE}), + ("PangoStyleItalic", #{const PANGO_STYLE_ITALIC}) ] + +instance PangoFontDescriptionSetting PangoStyle where + pangoFontDescriptionSet = pangoFontDescriptionSetStyle + pangoFontDescriptionGetUnsafe = pangoFontDescriptionGetStyle + pangoFontDescriptionMaskBit = PangoFontMaskStyle + +pangoFontDescriptionSetStyle :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoStyle -> m () +pangoFontDescriptionSetStyle (PangoFontDescriptionPrim fpfd) (PangoStyle s) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> c_pango_font_description_set_style pfd s + +foreign import ccall "pango_font_description_set_style" c_pango_font_description_set_style :: + Ptr PangoFontDescription -> #{type PangoStyle} -> IO () + +pangoFontDescriptionGetStyle :: PangoFontDescription -> PangoStyle +pangoFontDescriptionGetStyle (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> PangoStyle <$> c_pango_font_description_get_style pfd + +foreign import ccall "pango_font_description_get_style" c_pango_font_description_get_style :: + Ptr PangoFontDescription -> IO #type PangoStyle + +enum "PangoVariant" ''#{type PangoVariant} [''Show] [ + ("PangoVariantNormal", #{const PANGO_VARIANT_NORMAL}), + ("PangoVariantSmallCaps", #{const PANGO_VARIANT_SMALL_CAPS}) ] + +instance PangoFontDescriptionSetting PangoVariant where + pangoFontDescriptionSet = pangoFontDescriptionSetVariant + pangoFontDescriptionGetUnsafe = pangoFontDescriptionGetVariant + pangoFontDescriptionMaskBit = PangoFontMaskVariant + +pangoFontDescriptionSetVariant :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoVariant -> m () +pangoFontDescriptionSetVariant (PangoFontDescriptionPrim fpfd) (PangoVariant pv) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> c_pango_font_description_set_variant pfd pv + +foreign import ccall "pango_font_description_set_variant" c_pango_font_description_set_variant :: + Ptr PangoFontDescription -> #{type PangoVariant} -> IO () + +pangoFontDescriptionGetVariant :: PangoFontDescription -> PangoVariant +pangoFontDescriptionGetVariant (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + PangoVariant <$> c_pango_font_description_get_variant pfd + +foreign import ccall "pango_font_description_get_variant" c_pango_font_description_get_variant :: + Ptr PangoFontDescription -> IO #type PangoVariant + +enum "PangoWeight" ''#{type PangoWeight} [''Show] [ + ("PangoWeightThin", #{const PANGO_WEIGHT_THIN}), + ("PangoWeightUltralight", #{const PANGO_WEIGHT_ULTRALIGHT}), + ("PangoWeightLight", #{const PANGO_WEIGHT_LIGHT}), + ("PangoWeightSemilight", #{const PANGO_WEIGHT_SEMILIGHT}), + ("PangoWeightBook", #{const PANGO_WEIGHT_BOOK}), + ("PangoWeightNormal", #{const PANGO_WEIGHT_NORMAL}), + ("PangoWeightMedium", #{const PANGO_WEIGHT_MEDIUM}), + ("PangoWeightSemibold", #{const PANGO_WEIGHT_SEMIBOLD}), + ("PangoWeightBold", #{const PANGO_WEIGHT_BOLD}), + ("PangoWeightUltrabold", #{const PANGO_WEIGHT_ULTRABOLD}), + ("PangoWeightHeavy", #{const PANGO_WEIGHT_HEAVY}), + ("PangoWeightUltraheavy", #{const PANGO_WEIGHT_ULTRAHEAVY}) ] + +instance PangoFontDescriptionSetting PangoWeight where + pangoFontDescriptionSet = pangoFontDescriptionSetWeight + pangoFontDescriptionGetUnsafe = pangoFontDescriptionGetWeight + pangoFontDescriptionMaskBit = PangoFontMaskWeight + +pangoFontDescriptionSetWeight :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoWeight -> m () +pangoFontDescriptionSetWeight (PangoFontDescriptionPrim fpfd) (PangoWeight wt) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> c_pango_font_description_set_weight pfd wt + +foreign import ccall "pango_font_description_set_weight" c_pango_font_description_set_weight :: + Ptr PangoFontDescription -> #{type PangoWeight} -> IO () + +pangoFontDescriptionGetWeight :: PangoFontDescription -> PangoWeight +pangoFontDescriptionGetWeight (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + PangoWeight <$> c_pango_font_description_get_weight pfd + +foreign import ccall "pango_font_description_get_weight" c_pango_font_description_get_weight :: + Ptr PangoFontDescription -> IO #type PangoWeight + +enum "PangoStretch" ''#{type PangoStretch} [''Show] [ + ("PangoStretchUltraCondensed", #{const PANGO_STRETCH_ULTRA_CONDENSED}), + ("PangoStretchExtraCondensed", #{const PANGO_STRETCH_EXTRA_CONDENSED}), + ("PangoStretchCondensed", #{const PANGO_STRETCH_CONDENSED}), + ("PangoStretchSemiCondensed", #{const PANGO_STRETCH_SEMI_CONDENSED}), + ("PangoStretchNormal", #{const PANGO_STRETCH_NORMAL}), + ("PangoStretchSemiExpanded", #{const PANGO_STRETCH_SEMI_EXPANDED}), + ("PangoStretchExpanded", #{const PANGO_STRETCH_EXPANDED}), + ("PangoStretchExtraExpanded", #{const PANGO_STRETCH_EXTRA_EXPANDED}), + ("PangoStretchUltraExpanded", #{const PANGO_STRETCH_ULTRA_EXPANDED}) ] + +instance PangoFontDescriptionSetting PangoStretch where + pangoFontDescriptionSet = pangoFontDescriptionSetStretch + pangoFontDescriptionGetUnsafe = pangoFontDescriptionGetStretch + pangoFontDescriptionMaskBit = PangoFontMaskStretch + +pangoFontDescriptionSetStretch :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoStretch -> m () +pangoFontDescriptionSetStretch (PangoFontDescriptionPrim fpfd) (PangoStretch ps) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> c_pango_font_description_set_stretch pfd ps + +foreign import ccall "pango_font_description_set_stretch" c_pango_font_description_set_stretch :: + Ptr PangoFontDescription -> #{type PangoStretch} -> IO () + +pangoFontDescriptionGetStretch :: PangoFontDescription -> PangoStretch +pangoFontDescriptionGetStretch (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> PangoStretch <$> c_pango_font_description_get_stretch pfd + +foreign import ccall "pango_font_description_get_stretch" c_pango_font_description_get_stretch :: + Ptr PangoFontDescription -> IO #type PangoStretch + +data Size = Size CDouble | AbsoluteSize CDouble deriving Show + +instance PangoFontDescriptionSetting Size where + pangoFontDescriptionSet fd = \case + Size s -> pangoFontDescriptionSetSize fd . round $ s * #{const PANGO_SCALE} + AbsoluteSize as -> pangoFontDescriptionSetAbsoluteSize fd $ as * #{const PANGO_SCALE} + pangoFontDescriptionGetUnsafe fd = + let a = pangoFontDescriptionGetSizeIsAbsolute fd + s = pangoFontDescriptionGetSize fd in + bool (Size $ fromIntegral s / #{const PANGO_SCALE}) (AbsoluteSize $ fromIntegral s / #{const PANGO_SCALE}) a + pangoFontDescriptionMaskBit = PangoFontMaskSize + +pangoFontDescriptionSetSize :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> CInt -> m () +pangoFontDescriptionSetSize (PangoFontDescriptionPrim fpfd) n = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> + c_pango_font_description_set_size pfd n + +foreign import ccall "pango_font_description_set_size" c_pango_font_description_set_size :: + Ptr PangoFontDescription -> CInt -> IO () + +pangoFontDescriptionGetSize :: PangoFontDescription -> CInt +pangoFontDescriptionGetSize (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd c_pango_font_description_get_size + +foreign import ccall "pango_font_description_get_size" c_pango_font_description_get_size :: + Ptr PangoFontDescription -> IO CInt + +pangoFontDescriptionSetAbsoluteSize :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> CDouble -> m () +pangoFontDescriptionSetAbsoluteSize (PangoFontDescriptionPrim fpfd) sz = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> + c_pango_font_description_set_absolute_size pfd sz + +foreign import ccall "pango_font_description_set_absolute_size" c_pango_font_description_set_absolute_size :: + Ptr PangoFontDescription -> CDouble -> IO () + +pangoFontDescriptionGetSizeIsAbsolute :: PangoFontDescription -> Bool +pangoFontDescriptionGetSizeIsAbsolute (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + gbooleanToBool <$> c_pango_font_description_get_size_is_absolute pfd + +foreign import ccall "pango_font_description_get_size_is_absolute" + c_pango_font_description_get_size_is_absolute :: + Ptr PangoFontDescription -> IO #type gboolean + +instance PangoFontDescriptionSetting PangoGravity where + pangoFontDescriptionSet = pangoFontDescriptionSetGravity + pangoFontDescriptionGetUnsafe = pangoFontDescriptionGetGravity + pangoFontDescriptionMaskBit = PangoFontMaskGravity + +pangoFontDescriptionSetGravity :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> PangoGravity -> m () +pangoFontDescriptionSetGravity (PangoFontDescriptionPrim fpfd) (PangoGravity gr) = unsafeIOToPrim + $ withForeignPtr fpfd \pfd -> + c_pango_font_description_set_gravity pfd gr + +foreign import ccall "pango_font_description_set_gravity" + c_pango_font_description_set_gravity :: + Ptr PangoFontDescription -> #{type PangoGravity} -> IO () + +pangoFontDescriptionGetGravity :: PangoFontDescription -> PangoGravity +pangoFontDescriptionGetGravity (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + PangoGravity <$> c_pango_font_description_get_gravity pfd + +foreign import ccall "pango_font_description_get_gravity" + c_pango_font_description_get_gravity :: + Ptr PangoFontDescription -> IO #type PangoGravity + +pangoFontDescriptionMerge :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> + PangoFontDescriptionPrim (PrimState m) -> Bool -> m () +pangoFontDescriptionMerge (PangoFontDescriptionPrim fdsc) + (PangoFontDescriptionPrim fdsctm) re = unsafeIOToPrim + $ withForeignPtr fdsc \pdsc -> withForeignPtr fdsctm \pdsctm -> + c_pango_font_description_merge pdsc pdsctm $ boolToGboolean re + +foreign import ccall "pango_font_description_merge" + c_pango_font_description_merge :: + Ptr PangoFontDescription -> Ptr PangoFontDescription -> #{type gboolean} -> IO () + +pangoFontDescriptionBetterMatch :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> + Maybe (PangoFontDescriptionPrim (PrimState m)) -> + PangoFontDescriptionPrim (PrimState m) -> m Bool +pangoFontDescriptionBetterMatch + (PangoFontDescriptionPrim fdsc) mom (PangoFontDescriptionPrim fnm) = unsafeIOToPrim + $ gbooleanToBool <$> withForeignPtr fdsc \pdsc -> withMaybePangoFontDescriptionPrim mom \pom -> withForeignPtr fnm \pnm -> + c_pango_font_description_better_match pdsc pom pnm + +withMaybePangoFontDescriptionPrim :: + Maybe (PangoFontDescriptionPrim s) -> (Ptr PangoFontDescription -> IO a) -> IO a +withMaybePangoFontDescriptionPrim = \case + Nothing -> ($ nullPtr) + Just (PangoFontDescriptionPrim ffd) -> withForeignPtr ffd + +foreign import ccall "pango_font_description_better_match" + c_pango_font_description_better_match :: + Ptr PangoFontDescription -> Ptr PangoFontDescription -> + Ptr PangoFontDescription -> IO #{type gboolean} + +pangoFontDescriptionToString :: PangoFontDescription -> String +pangoFontDescriptionToString (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + peekCString =<< c_pango_font_description_to_string pfd + +foreign import ccall "pango_font_description_to_string" + c_pango_font_description_to_string :: + Ptr PangoFontDescription -> IO CString + +pangoFontDescriptionToFilename :: PangoFontDescription -> String +pangoFontDescriptionToFilename (PangoFontDescription_ fpfd) = unsafePerformIO + $ withForeignPtr fpfd \pfd -> + peekCString =<< c_pango_font_description_to_filename pfd + +foreign import ccall "pango_font_description_to_filename" + c_pango_font_description_to_filename :: + Ptr PangoFontDescription -> IO CString diff --git a/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Type.hs b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Type.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Type.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.Fonts.PangoFontDescription.Type ( + -- * PANGO FONT DESCRIPTION + PangoFontDescription(..), mkPangoFontDescription, + + -- * PANGO FONT DESCRIPTION NULLABLE + PangoFontDescriptionNullable(..), + mkPangoFontDescriptionNullable, + pangoFontDescriptionFromNullable, pangoFontDescriptionToNullable, + + -- * PANGO FONT DESCRIPTION FOR PRIMITIVE MONAD + PangoFontDescriptionPrim(..), + mkPangoFontDescriptionPrim, + PangoFontDescriptionST, PangoFontDescriptionIO, + pangoFontDescriptionFreeze, pangoFontDescriptionThaw, + pangoFontDescriptionCopy + ) where + +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer) +import Foreign.Concurrent +import Foreign.C.Struct + +data PangoFontDescription + = PangoFontDescription_ (ForeignPtr PangoFontDescription) + deriving Show + +mkPangoFontDescription :: Ptr PangoFontDescription -> IO PangoFontDescription +mkPangoFontDescription = \case + NullPtr -> error "bad" + p -> PangoFontDescription_ + <$> newForeignPtr p (c_pango_font_description_free p) + +data PangoFontDescriptionNullable + = PangoFontDescriptionNull + | PangoFontDescriptionNotNull (ForeignPtr PangoFontDescription) + deriving Show + +mkPangoFontDescriptionNullable :: Ptr PangoFontDescription -> IO PangoFontDescriptionNullable +mkPangoFontDescriptionNullable = \case + NullPtr -> pure PangoFontDescriptionNull + p -> PangoFontDescriptionNotNull + <$> newForeignPtr p (c_pango_font_description_free p) + +pangoFontDescriptionToNullable :: Maybe PangoFontDescription -> PangoFontDescriptionNullable +pangoFontDescriptionToNullable Nothing = PangoFontDescriptionNull +pangoFontDescriptionToNullable (Just (PangoFontDescription_ f)) = + PangoFontDescriptionNotNull f + +pangoFontDescriptionFromNullable :: PangoFontDescriptionNullable -> Maybe PangoFontDescription +pangoFontDescriptionFromNullable PangoFontDescriptionNull = Nothing +pangoFontDescriptionFromNullable (PangoFontDescriptionNotNull f) = + Just $ PangoFontDescription_ f + +foreign import ccall "pango_font_description_copy" + c_pango_font_description_copy :: + Ptr PangoFontDescription -> IO (Ptr PangoFontDescription) + +foreign import ccall "pango_font_description_free" + c_pango_font_description_free :: Ptr PangoFontDescription -> IO () + +structPrim "PangoFontDescription" + 'c_pango_font_description_copy 'c_pango_font_description_free [''Show] + +mkPangoFontDescriptionPrim :: + Ptr PangoFontDescription -> IO (PangoFontDescriptionPrim s) +mkPangoFontDescriptionPrim p = PangoFontDescriptionPrim + <$> newForeignPtr p (c_pango_font_description_free p) diff --git a/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Variations.hs b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Variations.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/Fonts/PangoFontDescription/Variations.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.Fonts.PangoFontDescription.Variations ( + -- * SET AND GET AXIS + pangoFontDescriptionSetAxis, pangoFontDescriptionGetAxis, + -- * SET AND GET VARIATIONS + Variations, + pangoFontDescriptionSetVariationsMap, + pangoFontDescriptionGetVariationsMap, + -- * DEFAULT AXES + Weight(..), Width(..), Slant(..), Italic(..), OpticalSize(..) + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.String +import Control.Monad.Primitive + +import Graphics.Pango.Basic.Fonts.PangoFontDescription.Type + +import qualified Data.ByteString as BS + +import System.IO.Unsafe + +import Data.Font.VariationAxis + +pangoFontDescriptionSetAxis :: forall a m . + (FontDescriptionAxis a, PrimMonad m) => + PangoFontDescriptionPrim (PrimState m) -> a -> m () +pangoFontDescriptionSetAxis fd a = do + as <- pangoFontDescriptionGetVariationsMap fd + pangoFontDescriptionSetVariationsMap fd $ variationsSetAxis a as + +pangoFontDescriptionGetAxis :: + forall a . FontDescriptionAxis a => PangoFontDescription -> Maybe a +pangoFontDescriptionGetAxis fd = unsafePerformIO do + pangoFontDescriptionThaw fd >>= \case + fd' -> do + as <- pangoFontDescriptionGetVariationsMap fd' + pure $ variationsGetAxis as + +pangoFontDescriptionSetVariationsMap :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> Variations -> m () +pangoFontDescriptionSetVariationsMap (PangoFontDescriptionPrim ffd) v = unsafeIOToPrim + $ withForeignPtr ffd \pfd -> BS.useAsCString (showVariations v) \cv -> + c_pango_font_description_set_variations pfd cv + +foreign import ccall "pango_font_description_set_variations" + c_pango_font_description_set_variations :: + Ptr PangoFontDescription -> CString -> IO () + +pangoFontDescriptionGetVariationsMap :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> m Variations +pangoFontDescriptionGetVariationsMap (PangoFontDescriptionPrim ffd) = unsafeIOToPrim + $ withForeignPtr ffd \pfd -> readVariations <$> + (myPackCString =<< c_pango_font_description_get_variations pfd) + +myPackCString :: CString -> IO BS.ByteString +myPackCString cs | cs == nullPtr = pure "" | otherwise = BS.packCString cs + +foreign import ccall "pango_font_description_get_variations" + c_pango_font_description_get_variations :: + Ptr PangoFontDescription -> IO CString diff --git a/src/Graphics/Pango/Basic/GlyphStorage.hsc b/src/Graphics/Pango/Basic/GlyphStorage.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/GlyphStorage.hsc @@ -0,0 +1,36 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.GlyphStorage ( + -- * PANGO FIXED + PangoFixed, PU, fromCInt, toCInt, + + -- * PANGO RECTANGLE AND EXTENTS + -- ** PangoRectangleFixed + PangoRectangleFixed, + pattern PangoRectangleFixed, + pangoRectangleFixedX, pangoRectangleFixedY, + pangoRectangleFixedWidth, pangoRectangleFixedHeight, + + PangoRectangleFixedPrim, PangoRectangleFixedST, PangoRectangleFixedIO, + pangoRectangleFixedFreeze, pangoRectangleFixedThaw, pangoRectangleFixedCopy, + + -- ** PangoRectanglePixel + PangoRectanglePixel, + pattern PangoRectanglePixel, + pangoRectanglePixelX, pangoRectanglePixelY, + pangoRectanglePixelWidth, pangoRectanglePixelHeight, + + PangoRectanglePixelPrim, + PangoRectanglePixelST, PangoRectanglePixelIO, + pangoRectanglePixelFreeze, pangoRectanglePixelThaw, + pangoRectanglePixelCopy, + + -- ** Extents and PixelExtents + Extents(..), PixelExtents(..), + + -- * PANGO GLYPH ITEM + PangoGlyphItem, PangoLayoutRun, + ) where + +import Graphics.Pango.Basic.GlyphStorage.Internal diff --git a/src/Graphics/Pango/Basic/GlyphStorage/Internal.hsc b/src/Graphics/Pango/Basic/GlyphStorage/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/GlyphStorage/Internal.hsc @@ -0,0 +1,172 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.GlyphStorage.Internal ( + -- * PANGO FIXED + PangoFixed, PU, fromCInt, toCInt, + + -- * PANGO RECTANGLE AND EXTENTS + -- ** PangoRectangleFixed + PangoRectangleFixed(..), + pattern PangoRectangleFixed, + pangoRectangleFixedX, pangoRectangleFixedY, + pangoRectangleFixedWidth, pangoRectangleFixedHeight, + + PangoRectangleFixedPrim(..), PangoRectangleFixedST, PangoRectangleFixedIO, + pangoRectangleFixedFreeze, pangoRectangleFixedThaw, pangoRectangleFixedCopy, + + -- ** PangoRectanglePixel + PangoRectanglePixel(..), + pattern PangoRectanglePixel, + pangoRectanglePixelX, pangoRectanglePixelY, + pangoRectanglePixelWidth, pangoRectanglePixelHeight, + + PangoRectanglePixelPrim(..), + PangoRectanglePixelST, PangoRectanglePixelIO, + pangoRectanglePixelFreeze, pangoRectanglePixelThaw, + pangoRectanglePixelCopy, + + -- ** Extents and PixelExtents + Extents(..), PixelExtents(..), + pangoExtentsToPixelsInclusive, pangoExtentsToPixelsNearest, + + -- * PANGO GLYPH ITEM + PangoGlyphItem(..), PangoLayoutRun, + mkPangoGlyphItemMaybe0 + ) where + +import GHC.Stack +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.Struct +import Control.Monad.Primitive +import Control.Exception +import Data.Fixed +import System.IO.Unsafe + +#include + +data PU + +instance HasResolution PU where resolution _ = #{const PANGO_SCALE} + +type PangoFixed = Fixed PU + +minCInt, maxCInt :: Integer +minCInt = fromIntegral (minBound @CInt) +maxCInt = fromIntegral (maxBound @CInt) + +fromCInt :: CInt -> PangoFixed +fromCInt = MkFixed . fromIntegral + +toCInt :: HasCallStack => PangoFixed -> CInt +toCInt (MkFixed i) + | minCInt <= i && i <= maxCInt = fromIntegral i + | otherwise = unsafePerformIO do + putStrLn $ prettyCallStack callStack + throw Overflow + +struct "PangoRectangleFixed" #{size PangoRectangle} #{alignment PangoRectangle} + [ ("x", ''PangoFixed, [| (fromCInt <$>) . #{peek PangoRectangle, x} |], + [| \p -> #{poke PangoRectangle, x} p . toCInt |]), + ("y", ''PangoFixed, [| (fromCInt <$>) . #{peek PangoRectangle, y} |], + [| \p -> #{poke PangoRectangle, y} p . toCInt |]), + ("width", ''PangoFixed, [| (fromCInt <$>) . #{peek PangoRectangle, width} |], + [| \p -> #{poke PangoRectangle, width} p . toCInt |]), + ("height", ''PangoFixed, [| (fromCInt <$>) . #{peek PangoRectangle, height} |], + [| \p -> #{poke PangoRectangle, height} p . toCInt |]) ] + [''Show] + +c_pango_rectangle_copy :: Ptr PangoRectangleFixed -> IO (Ptr PangoRectangleFixed) +c_pango_rectangle_copy s = mallocBytes #{size PangoRectangle} >>= \d -> + d <$ copyBytes d s #{size PangoRectangle} + +c_pango_rectangle_free :: Ptr PangoRectangleFixed -> IO () +c_pango_rectangle_free = free + +structPrim "PangoRectangleFixed" 'c_pango_rectangle_copy 'c_pango_rectangle_free + [''Show] + +{- +pattern PangoRectangleFixed :: + PangoFixed -> PangoFixed -> PangoFixed -> PangoFixed -> PangoRectangle +pattern PangoRectangleFixed { + pangoRectangleFixedX, pangoRectangleFixedY, + pangoRectangleFixedWidth, pangoRectangleFixedHeight } <- (pangoRectangleFixed -> ( + pangoRectangleFixedX, pangoRectangleFixedY, + pangoRectangleFixedWidth, pangoRectangleFixedHeight )) where + PangoRectangleFixed x y w h = + PangoRectangle (toCInt x) (toCInt y) (toCInt w) (toCInt h) + +pangoRectangleFixed :: + PangoRectangle -> (PangoFixed, PangoFixed, PangoFixed, PangoFixed) +pangoRectangleFixed (PangoRectangle + (fromCInt -> x) (fromCInt -> y) + (fromCInt -> w) (fromCInt -> h)) = (x, y, w, h) + -} + +struct "PangoRectanglePixel" #{size PangoRectangle} #{alignment PangoRectangle} + [ ("x", ''CInt, [| #{peek PangoRectangle, x} |], + [| #{poke PangoRectangle, x} |]), + ("y", ''CInt, [| #{peek PangoRectangle, y} |], + [| #{poke PangoRectangle, y} |]), + ("width", ''CInt, [| #{peek PangoRectangle, width} |], + [| #{poke PangoRectangle, width} |]), + ("height", ''CInt, [| #{peek PangoRectangle, height} |], + [| #{poke PangoRectangle, height} |]) ] + [''Show] + +c_pango_rectangle_pixel_copy :: Ptr PangoRectanglePixel -> IO (Ptr PangoRectanglePixel) +c_pango_rectangle_pixel_copy s = castPtr <$> c_pango_rectangle_copy (castPtr s) + +c_pango_rectangle_pixel_free :: Ptr PangoRectanglePixel -> IO () +c_pango_rectangle_pixel_free = c_pango_rectangle_free . castPtr + +structPrim "PangoRectanglePixel" 'c_pango_rectangle_pixel_copy + 'c_pango_rectangle_pixel_free [''Show] + +data Extents = Extents { + extentsInkRect :: PangoRectangleFixed, + extentsLogicalRect :: PangoRectangleFixed } deriving Show + +data PixelExtents = PixelExtents { + pixelExtentsInkRect :: PangoRectanglePixel, + pixelExtentsLogicalRect :: PangoRectanglePixel } deriving Show + +newtype PangoGlyphItem = PangoGlyphItem (ForeignPtr PangoGlyphItem) deriving Show + +mkPangoGlyphItemMaybe0 :: Ptr PangoGlyphItem -> IO (Maybe PangoGlyphItem) +mkPangoGlyphItemMaybe0 = \case + NullPtr -> pure Nothing + p -> Just . PangoGlyphItem <$> do + p' <- c_pango_glyph_item_copy p + newForeignPtr p' $ c_pango_glyph_item_free p' + +foreign import ccall "pango_glyph_item_free" c_pango_glyph_item_free :: + Ptr PangoGlyphItem -> IO () + +foreign import ccall "pango_glyph_item_copy" c_pango_glyph_item_copy :: + Ptr PangoGlyphItem -> IO (Ptr PangoGlyphItem) + +type PangoLayoutRun = PangoGlyphItem + +pangoExtentsToPixelsInclusive :: + PrimMonad m => PangoRectangleFixedPrim (PrimState m) -> m () +pangoExtentsToPixelsInclusive (PangoRectangleFixedPrim fr) = unsafeIOToPrim + $ withForeignPtr fr (`c_pango_extents_to_pixels` nullPtr) + +pangoExtentsToPixelsNearest :: + PrimMonad m => PangoRectangleFixedPrim (PrimState m) -> m () +pangoExtentsToPixelsNearest (PangoRectangleFixedPrim fr) = unsafeIOToPrim + . withForeignPtr fr $ c_pango_extents_to_pixels nullPtr + +foreign import ccall "pango_extents_to_pixels" c_pango_extents_to_pixels :: + Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () diff --git a/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix.hs b/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.GlyphStorage.PangoMatrix ( + + -- * TYPE + -- ** PangoMatrix + PangoMatrix, pattern PangoMatrix, + pangoMatrixXx, pangoMatrixXy, pangoMatrixYx, pangoMatrixYy, + pangoMatrixX0, pangoMatrixY0, + + -- ** PangoMatrixPrim + PangoMatrixPrim, PangoMatrixST, PangoMatrixIO, + pangoMatrixFreeze, pangoMatrixThaw, pangoMatrixCopy, + + -- ** PangoMatrixNullable + PangoMatrixNullable, pangoMatrixFromNullable, pangoMatrixToNullable, + + -- * FUNCTION + pangoMatrixTranslate, pangoMatrixScale, pangoMatrixRotate, + pangoMatrixConcat, + + pangoMatrixTransformPoint, pangoMatrixTransformDistance, + pangoMatrixTransformRectangle, pangoMatrixTransformPixelRectangle, + pangoMatrixGetFontScaleFactor, pangoMatrixGetFontScaleFactors + + ) where + +import Graphics.Pango.Basic.GlyphStorage.PangoMatrix.Internal diff --git a/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix/Internal.hsc b/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/GlyphStorage/PangoMatrix/Internal.hsc @@ -0,0 +1,188 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.GlyphStorage.PangoMatrix.Internal ( + + -- * TYPE + -- ** PangoMatrix + PangoMatrix(..), pattern PangoMatrix, + pangoMatrixXx, pangoMatrixXy, pangoMatrixYx, pangoMatrixYy, + pangoMatrixX0, pangoMatrixY0, + + -- ** PangoMatrixPrim + PangoMatrixPrim, PangoMatrixST, PangoMatrixIO, + pangoMatrixFreeze, pangoMatrixThaw, pangoMatrixCopy, + + -- ** PangoMatrixNullable + PangoMatrixNullable(..), pangoMatrixFromNullable, pangoMatrixToNullable, + mkPangoMatrixNullable0, + + -- * FUNCTION + pangoMatrixTranslate, pangoMatrixScale, pangoMatrixRotate, + pangoMatrixConcat, + + pangoMatrixTransformPoint, pangoMatrixTransformDistance, + pangoMatrixTransformRectangle, pangoMatrixTransformPixelRectangle, + pangoMatrixGetFontScaleFactor, pangoMatrixGetFontScaleFactors + + ) where + +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad.Primitive +import Data.Angle +import System.IO.Unsafe + +import Foreign.C.Struct + +import Graphics.Pango.Basic.GlyphStorage.Internal + +#include + +struct "PangoMatrix" #{size PangoMatrix} #{alignment PangoMatrix} + [ ("xx", ''CDouble, [| #{peek PangoMatrix, xx} |], + [| #{poke PangoMatrix, xx} |]), + ("xy", ''CDouble, [| #{peek PangoMatrix, xy} |], + [| #{poke PangoMatrix, xy} |]), + ("yx", ''CDouble, [| #{peek PangoMatrix, yx} |], + [| #{poke PangoMatrix, yx} |]), + ("yy", ''CDouble, [| #{peek PangoMatrix, yy} |], + [| #{poke PangoMatrix, yy} |]), + ("x0", ''CDouble, [| #{peek PangoMatrix, x0} |], + [| #{poke PangoMatrix, x0} |]), + ("y0", ''CDouble, [| #{peek PangoMatrix, y0} |], + [| #{poke PangoMatrix, y0} |]) ] + [''Show] + +foreign import ccall "pango_matrix_copy" c_pango_matrix_copy :: + Ptr PangoMatrix -> IO (Ptr PangoMatrix) + +foreign import ccall "pango_matrix_free" c_pango_matrix_free :: + Ptr PangoMatrix -> IO () + +structPrim "PangoMatrix" 'c_pango_matrix_copy 'c_pango_matrix_free [''Show] + +pangoMatrixTranslate :: PrimMonad m => + PangoMatrixPrim (PrimState m) -> CDouble -> CDouble -> m () +pangoMatrixTranslate (PangoMatrixPrim fm) tx ty = unsafeIOToPrim + $ withForeignPtr fm \pm -> c_pango_matrix_translate pm tx ty + +foreign import ccall "pango_matrix_translate" c_pango_matrix_translate :: + Ptr PangoMatrix -> CDouble -> CDouble -> IO () + +pangoMatrixScale :: PrimMonad m => + PangoMatrixPrim (PrimState m) -> CDouble -> CDouble -> m () +pangoMatrixScale (PangoMatrixPrim fm) sx sy = unsafeIOToPrim + $ withForeignPtr fm \pm -> c_pango_matrix_scale pm sx sy + +foreign import ccall "pango_matrix_scale" c_pango_matrix_scale :: + Ptr PangoMatrix -> CDouble -> CDouble -> IO () + +pangoMatrixRotate :: PrimMonad m => + PangoMatrixPrim (PrimState m) -> Angle CDouble -> m () +pangoMatrixRotate (PangoMatrixPrim fm) (Degree dgr) = unsafeIOToPrim + $ withForeignPtr fm \pm -> c_pango_matrix_rotate pm dgr + +foreign import ccall "pango_matrix_rotate" c_pango_matrix_rotate :: + Ptr PangoMatrix -> CDouble -> IO () + +pangoMatrixConcat :: PrimMonad m => + PangoMatrixPrim (PrimState m) -> PangoMatrix -> m () +pangoMatrixConcat (PangoMatrixPrim fm) (PangoMatrix_ fnm) = unsafeIOToPrim + $ withForeignPtr fm \pm -> withForeignPtr fnm \pnm -> + c_pango_matrix_concat pm pnm + +foreign import ccall "pango_matrix_concat" c_pango_matrix_concat :: + Ptr PangoMatrix -> Ptr PangoMatrix -> IO () + +pangoMatrixTransformPoint :: + PangoMatrix -> CDouble -> CDouble -> (CDouble, CDouble) +pangoMatrixTransformPoint (PangoMatrix_ fm) x y = unsafePerformIO + $ withForeignPtr fm \pm -> alloca \px -> alloca \py -> do + poke px x; poke py y + c_pango_matrix_transform_point pm px py + (,) <$> peek px <*> peek py + +foreign import ccall "pango_matrix_transform_point" + c_pango_matrix_transform_point :: + Ptr PangoMatrix -> Ptr CDouble -> Ptr CDouble -> IO () + +pangoMatrixTransformDistance :: + PangoMatrix -> CDouble -> CDouble -> (CDouble, CDouble) +pangoMatrixTransformDistance (PangoMatrix_ fm) dx dy = unsafePerformIO + $ withForeignPtr fm \pm -> alloca \pdx -> alloca \pdy -> do + poke pdx dx; poke pdy dy + c_pango_matrix_transform_distance pm pdx pdy + (,) <$> peek pdx <*> peek pdy + +foreign import ccall "pango_matrix_transform_distance" + c_pango_matrix_transform_distance :: + Ptr PangoMatrix -> Ptr CDouble -> Ptr CDouble -> IO () + +pangoMatrixTransformRectangle :: + PrimMonad m => PangoMatrix -> PangoRectangleFixedPrim (PrimState m) -> m () +pangoMatrixTransformRectangle (PangoMatrix_ fm) (PangoRectangleFixedPrim fr) = + unsafeIOToPrim $ withForeignPtr fm \pm -> withForeignPtr fr \pr -> + c_pango_matrix_transform_rectangle pm pr + +foreign import ccall "pango_matrix_transform_rectangle" + c_pango_matrix_transform_rectangle :: + Ptr PangoMatrix -> Ptr PangoRectangleFixed -> IO () + +pangoMatrixTransformPixelRectangle :: PrimMonad m => + PangoMatrix -> PangoRectanglePixelPrim (PrimState m) -> m () +pangoMatrixTransformPixelRectangle + (PangoMatrix_ fm) (PangoRectanglePixelPrim fr) = + unsafeIOToPrim $ withForeignPtr fm \pm -> withForeignPtr fr \pr -> + c_pango_matrix_transform_pixel_rectangle pm pr + +foreign import ccall "pango_matrix_transform_pixel_rectangle" + c_pango_matrix_transform_pixel_rectangle :: + Ptr PangoMatrix -> Ptr PangoRectanglePixel -> IO () + +pangoMatrixGetFontScaleFactor :: PangoMatrix -> CDouble +pangoMatrixGetFontScaleFactor (PangoMatrix_ fm) = unsafePerformIO + $ withForeignPtr fm c_pango_matrix_get_font_scale_factor + +foreign import ccall "pango_matrix_get_font_scale_factor" + c_pango_matrix_get_font_scale_factor :: + Ptr PangoMatrix -> IO CDouble + +pangoMatrixGetFontScaleFactors :: PangoMatrix -> (CDouble, CDouble) +pangoMatrixGetFontScaleFactors (PangoMatrix_ fm) = unsafePerformIO + $ withForeignPtr fm \pm -> alloca \xs -> alloca \ys -> do + c_pango_matrix_get_font_scale_factors pm xs ys + (,) <$> peek xs <*> peek ys + +foreign import ccall "pango_matrix_get_font_scale_factors" + c_pango_matrix_get_font_scale_factors :: + Ptr PangoMatrix -> Ptr CDouble -> Ptr CDouble -> IO () + +data PangoMatrixNullable + = PangoMatrixNull + | PangoMatrixNotNull (ForeignPtr PangoMatrix) + deriving Show + +pangoMatrixToNullable :: Maybe PangoMatrix -> PangoMatrixNullable +pangoMatrixToNullable = \case + Nothing -> PangoMatrixNull + Just (PangoMatrix_ f) -> PangoMatrixNotNull f + +pangoMatrixFromNullable :: PangoMatrixNullable -> Maybe PangoMatrix +pangoMatrixFromNullable = \case + PangoMatrixNull -> Nothing + PangoMatrixNotNull f -> Just $ PangoMatrix_ f + +mkPangoMatrixNullable0 :: Ptr PangoMatrix -> IO PangoMatrixNullable +mkPangoMatrixNullable0 = \case + NullPtr -> pure PangoMatrixNull + pm -> PangoMatrixNotNull <$> do + pm' <- c_pango_matrix_copy pm + newForeignPtr pm' $ c_pango_matrix_free pm' diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout.hs b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayout ( + -- * TYPE + PangoLayout, + PangoLayoutPrim, PangoLayoutST, PangoLayoutIO, + pangoLayoutFreeze, pangoLayoutThaw, pangoLayoutCopy, + + -- * CLASS + -- ** PangoLayoutSetting + PangoLayoutSetting, pangoLayoutSet, pangoLayoutGet, + + -- ** PangoLayoutInfo + PangoLayoutInfo, pangoLayoutInfo, + + -- * FUNCTION + pangoLayoutNew, pangoLayoutContextChanged, + pangoLayoutSetMarkup, pangoLayoutSetMarkupWithAccel, + + pangoLayoutIndexToPos, + pangoLayoutIndexToLineX, + pangoLayoutXyToIndex, + pangoLayoutGetCursorPos, + pangoLayoutMoveCursorVisually, Dir(..), + + -- * SETTING + + -- ** Width and Height + Width(..), Height(..), + + -- ** PangoWrapMode + PangoWrapMode(..), + pattern PangoWrapWord, pattern PangoWrapChar, pattern PangoWrapWordChar, + + -- ** PangoEllipsizeMode + PangoEllipsizeMode(..), + pattern PangoEllipsizeNone, pattern PangoEllipsizeStart, + pattern PangoEllipsizeMiddle, pattern PangoEllipsizeEnd, + + -- ** Indent, Spacing, LineSpacing, Justify and AutoDir + Indent(..), Spacing(..), LineSpacing(..), Justify(..), AutoDir(..), + + -- ** PangoAlignment + PangoAlignment(..), + pattern PangoAlignLeft, pattern PangoAlignCenter, + pattern PangoAlignRight, + + -- ** SingleParagraphMode + SingleParagraphMode(..), + + -- * INFO + + -- ** CharacterCount, IsWrapped, IsEllipsized and UnknownGlyphCount + CharacterCount(..), IsWrapped(..), IsEllipsized(..), UnknownGlyphsCount(..), + + -- ** PangoLogAttrs + PangoLogAttrs, pangoLogAttrsGetLogAttr, pangoLogAttrsGetSize, + PangoLogAttr, + pattern PangoLogAttr, + pangoLogAttrIsLineBreak, pangoLogAttrIsMandatoryBreak, + pangoLogAttrIsCharBreak, pangoLogAttrIsWhite, + pangoLogAttrIsCursorPosition, + pangoLogAttrIsWordStart, pangoLogAttrIsWordEnd, + pangoLogAttrIsSentenceBoundary, + pangoLogAttrIsSentenceStart, pangoLogAttrIsSentenceEnd, + pangoLogAttrBackspaceDeleteCharacter, pangoLogAttrIsExpandableSpace, + pangoLogAttrIsWordBoundary, + + -- ** LayoutSize, LayoutPixelSize, Baseline and LineCount + LayoutSize(..), LayoutPixelSize(..), Baseline(..), LineCount(..), + + ) where + +import Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout/Internal.hsc b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayout/Internal.hsc @@ -0,0 +1,883 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal ( + -- * TYPE + PangoLayout(..), + PangoLayoutPrim(..), PangoLayoutST, PangoLayoutIO, mkPangoLayoutPrim, + pangoLayoutFreeze, pangoLayoutThaw, pangoLayoutCopy, + + -- * CLASS + -- ** PangoLayoutSetting + PangoLayoutSetting, pangoLayoutSet, pangoLayoutGet, + + -- ** PangoLayoutInfo + PangoLayoutInfo, pangoLayoutInfo, + + -- * FUNCTION + pangoLayoutNew, pangoLayoutContextChanged, + pangoLayoutSetMarkup, pangoLayoutSetMarkupWithAccel, + + pangoLayoutIndexToPos, + pangoLayoutIndexToLineX, + pangoLayoutXyToIndex, + pangoLayoutGetCursorPos, + pangoLayoutMoveCursorVisually, Dir(..), + + -- * SETTING + + -- ** Width and Height + Width(..), Height(..), + + -- ** PangoWrapMode + PangoWrapMode(..), + pattern PangoWrapWord, pattern PangoWrapChar, pattern PangoWrapWordChar, + + -- ** PangoEllipsizeMode + PangoEllipsizeMode(..), + pattern PangoEllipsizeNone, pattern PangoEllipsizeStart, + pattern PangoEllipsizeMiddle, pattern PangoEllipsizeEnd, + + -- ** Indent, Spacing, LineSpacing, Justify and AutoDir + Indent(..), Spacing(..), LineSpacing(..), Justify(..), AutoDir(..), + + -- ** PangoAlignment + PangoAlignment(..), + pattern PangoAlignLeft, pattern PangoAlignCenter, + pattern PangoAlignRight, + + -- ** SingleParagraphMode + SingleParagraphMode(..), + + -- * INFO + + -- ** CharacterCount, IsWrapped, IsEllipsized and UnknownGlyphCount + CharacterCount(..), IsWrapped(..), IsEllipsized(..), UnknownGlyphsCount(..), + + -- ** PangoLogAttrs + PangoLogAttrs, pangoLogAttrsGetLogAttr, pangoLogAttrsGetSize, + PangoLogAttr, + pattern PangoLogAttr, + pangoLogAttrIsLineBreak, pangoLogAttrIsMandatoryBreak, + pangoLogAttrIsCharBreak, pangoLogAttrIsWhite, + pangoLogAttrIsCursorPosition, + pangoLogAttrIsWordStart, pangoLogAttrIsWordEnd, + pangoLogAttrIsSentenceBoundary, + pangoLogAttrIsSentenceStart, pangoLogAttrIsSentenceEnd, + pangoLogAttrBackspaceDeleteCharacter, pangoLogAttrIsExpandableSpace, + pangoLogAttrIsWordBoundary, + + -- ** LayoutSize, LayoutPixelSize, Baseline and LineCount + LayoutSize(..), LayoutPixelSize(..), Baseline(..), LineCount(..), + + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.String.Utf8 +import Foreign.C.String.ForeignCStringLen +import Foreign.C.String.Misc +import Foreign.C.Enum +import Foreign.C.Struct +import Control.Monad.Primitive +import Data.Maybe +import Data.List +import Data.Bool +import Data.Word +import Data.Int +import Data.Char +import Data.Text.CString +import System.IO.Unsafe +import System.GLib.Bool +import System.GLib.GObject + +import Graphics.Pango.Basic.GlyphStorage.Internal +import Graphics.Pango.Basic.Fonts.PangoFontDescription.Type +import Graphics.Pango.Basic.TextAttributes.Internal +import Graphics.Pango.LowLevel.Contexts.Internal +import Graphics.Pango.LowLevel.TabStops.Internal + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +#include +#include "pango_log_attr.h" + +newtype PangoLayout = PangoLayout_ (ForeignPtr PangoLayout) deriving Show + +foreign import ccall "pango_layout_copy" c_pango_layout_copy :: + Ptr PangoLayout -> IO (Ptr PangoLayout) + +foreign import ccall "g_object_unref" c_pango_layout_free :: + Ptr PangoLayout -> IO () + +structPrim "PangoLayout" 'c_pango_layout_copy 'c_pango_layout_free [''Show] + +mkPangoLayoutPrim :: Ptr PangoLayout -> IO (PangoLayoutPrim s) +mkPangoLayoutPrim p = PangoLayoutPrim <$> newForeignPtr p (c_g_object_unref p) + +pangoLayoutNew :: PrimMonad m => PangoContext -> m (PangoLayoutPrim (PrimState m)) +pangoLayoutNew (PangoContext fc) = unsafeIOToPrim + $ mkPangoLayoutPrim =<< withForeignPtr fc c_pango_layout_new + +foreign import ccall "pango_layout_new" c_pango_layout_new :: + Ptr PangoContext -> IO (Ptr PangoLayout) + +pangoLayoutContextChanged :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> m () +pangoLayoutContextChanged (PangoLayoutPrim fl) = unsafeIOToPrim + $ withForeignPtr fl c_pango_layout_context_changed + +foreign import ccall "pango_layout_context_changed" + c_pango_layout_context_changed :: + Ptr PangoLayout -> IO () + +class PangoLayoutSetting s where + pangoLayoutSet :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> s -> m () + pangoLayoutGet :: PangoLayout -> s + +instance PangoLayoutSetting T.Text where + pangoLayoutSet = (unsafeIOToPrim .) . pangoLayoutSetText + pangoLayoutGet = pangoLayoutGetText + +pangoLayoutSetText :: PangoLayoutPrim s -> T.Text -> IO () +pangoLayoutSetText (PangoLayoutPrim fpl) s = + withForeignPtr fpl \pl -> T.withCStringLen s \(cs, n) -> do + cs' <- copyCString cs n + addForeignPtrFinalizer fpl $ free cs' + c_pango_layout_set_text pl cs' $ fromIntegral n + +foreign import ccall "pango_layout_set_text" c_pango_layout_set_text :: + Ptr PangoLayout -> CString -> CInt -> IO () + +pangoLayoutGetText :: PangoLayout -> T.Text +pangoLayoutGetText (PangoLayout_ fpl) = unsafePerformIO + $ withForeignPtr fpl \pl -> peekCStringText =<< c_pango_layout_get_text pl + +foreign import ccall "pango_layout_get_text" c_pango_layout_get_text :: + Ptr PangoLayout -> IO CString + +pangoLayoutSetMarkup :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> T.Text -> m () +pangoLayoutSetMarkup (PangoLayoutPrim fpl) mu = unsafeIOToPrim + $ withForeignPtr fpl \ppl -> T.withCStringLen mu \(cs, cl) -> + c_pango_layout_set_markup ppl cs $ fromIntegral cl + +foreign import ccall "pango_layout_set_markup" + c_pango_layout_set_markup :: Ptr PangoLayout -> CString -> CInt -> IO () + +pangoLayoutSetMarkupWithAccel :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> T.Text -> Char -> m Char +pangoLayoutSetMarkupWithAccel (PangoLayoutPrim fpl) mu am = unsafeIOToPrim + $ withForeignPtr fpl \ppl -> + T.withCStringLen mu \(cs, cl) -> alloca \pa -> do + c_pango_layout_set_markup_with_accel ppl cs (fromIntegral cl) (fromIntegral $ ord am) pa + chr . fromIntegral <$> peek pa + +foreign import ccall "pango_layout_set_markup_with_accel" + c_pango_layout_set_markup_with_accel :: + Ptr PangoLayout -> CString -> CInt -> + #{type gunichar} -> Ptr #{type gunichar} -> IO () + +instance PangoLayoutSetting PangoTextAttrList where + pangoLayoutSet = pangoLayoutSetTextAttributes + pangoLayoutGet = pangoLayoutGetTextAttributes + +pangoLayoutSetTextAttributes :: PrimMonad m => + PangoLayoutPrim (PrimState m) -> PangoTextAttrList -> m () +pangoLayoutSetTextAttributes + l@(PangoLayoutPrim fl) (PangoTextAttrList (cs, ln) al) = unsafeIOToPrim do + withForeignPtr fl \pl -> withForeignPtr cs \cs' -> c_pango_layout_set_text pl cs' $ fromIntegral ln + pangoLayoutSetAttributes l al + +pangoLayoutGetTextAttributes :: PangoLayout -> PangoTextAttrList +pangoLayoutGetTextAttributes l@(PangoLayout_ fl) = unsafePerformIO $ PangoTextAttrList + <$> (copyToForeignCStringLen =<< toCStringLen =<< withForeignPtr fl c_pango_layout_get_text) + <*> pangoLayoutGetAttributes l + +pangoLayoutSetAttributes :: PangoLayoutPrim s -> PangoAttrList -> IO () +pangoLayoutSetAttributes (PangoLayoutPrim fl) al = + withForeignPtr fl \pl -> ($ c_pango_layout_set_attributes pl) case al of + PangoAttrListNull -> ($ nullPtr) + PangoAttrList fal -> withForeignPtr fal + +foreign import ccall "pango_layout_set_attributes" + c_pango_layout_set_attributes :: + Ptr PangoLayout -> Ptr PangoAttrList -> IO () + +pangoLayoutGetAttributes :: PangoLayout -> IO PangoAttrList +pangoLayoutGetAttributes (PangoLayout_ fpl) = + mkPangoAttrList =<< do + p <- withForeignPtr fpl c_pango_layout_get_attributes + p <$ c_pango_attr_list_ref p + +foreign import ccall "pango_layout_get_attributes" + c_pango_layout_get_attributes :: + Ptr PangoLayout -> IO (Ptr PangoAttrList) + +foreign import ccall "pango_attr_list_ref" c_pango_attr_list_ref :: + Ptr PangoAttrList -> IO (Ptr PangoAttrList) + +instance PangoLayoutSetting PangoFontDescriptionNullable where + pangoLayoutSet = pangoLayoutSetFontDescription + pangoLayoutGet = pangoLayoutGetFontDescription + +pangoLayoutSetFontDescription :: PrimMonad m => + PangoLayoutPrim (PrimState m) -> PangoFontDescriptionNullable -> m () +pangoLayoutSetFontDescription (PangoLayoutPrim fpl) fd = unsafeIOToPrim + $ withForeignPtr fpl \pl -> case fd of + PangoFontDescriptionNull -> c_pango_layout_set_font_description pl nullPtr + PangoFontDescriptionNotNull ffd -> do + addForeignPtrFinalizer fpl $ touchForeignPtr ffd + withForeignPtr ffd $ c_pango_layout_set_font_description pl + +foreign import ccall "pango_layout_set_font_description" c_pango_layout_set_font_description :: + Ptr PangoLayout -> Ptr PangoFontDescription -> IO () + +pangoLayoutGetFontDescription :: PangoLayout -> PangoFontDescriptionNullable +pangoLayoutGetFontDescription (PangoLayout_ fpl) = unsafePerformIO + $ mkPangoFontDescriptionNullable =<< withForeignPtr fpl \ppl -> + c_pango_font_description_copy + =<< c_pango_layout_get_font_description ppl + +foreign import ccall "pango_layout_get_font_description" c_pango_layout_get_font_description :: + Ptr PangoLayout -> IO (Ptr PangoFontDescription) + +foreign import ccall "pango_font_description_copy" c_pango_font_description_copy :: + Ptr PangoFontDescription -> IO (Ptr PangoFontDescription) + +data Width = WidthDefault | Width PangoFixed deriving Show + +getWidth :: Width -> CInt +getWidth = \case WidthDefault -> - 1; Width w -> toCInt w + +width :: CInt -> Width +width = \case - 1 -> WidthDefault; w -> Width $ fromCInt w + +instance PangoLayoutSetting Width where + pangoLayoutSet l = pangoLayoutSetWidth l . getWidth + pangoLayoutGet l = width $ pangoLayoutGetWidth l + +data Height = HeightDefault | Height PangoFixed | LinesPerParagraph CInt + deriving Show + +toHeight :: CInt -> Height +toHeight n + | n < 0 = LinesPerParagraph $ - n + | otherwise = Height $ fromCInt n + +fromHeight :: Height -> CInt +fromHeight = \case + HeightDefault -> - 1 + Height d -> toCInt d + LinesPerParagraph n -> - n + +instance PangoLayoutSetting Height where + pangoLayoutSet l = pangoLayoutSetHeight l . fromHeight + pangoLayoutGet l = toHeight $ pangoLayoutGetHeight l + +pangoLayoutSetWidth, pangoLayoutSetHeight :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> CInt -> m () +pangoLayoutSetWidth (PangoLayoutPrim fl) w = unsafeIOToPrim + $ withForeignPtr fl \pl -> c_pango_layout_set_width pl w + +pangoLayoutSetHeight (PangoLayoutPrim fl) h = unsafeIOToPrim + $ withForeignPtr fl \pl -> c_pango_layout_set_height pl h + +pangoLayoutGetWidth, pangoLayoutGetHeight :: PangoLayout -> CInt +pangoLayoutGetWidth (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl c_pango_layout_get_width + +pangoLayoutGetHeight (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl c_pango_layout_get_height + +foreign import ccall "pango_layout_set_width" c_pango_layout_set_width :: + Ptr PangoLayout -> CInt -> IO () + +foreign import ccall "pango_layout_get_width" c_pango_layout_get_width :: + Ptr PangoLayout -> IO CInt + +foreign import ccall "pango_layout_set_height" c_pango_layout_set_height :: + Ptr PangoLayout -> CInt -> IO () + +foreign import ccall "pango_layout_get_height" c_pango_layout_get_height :: + Ptr PangoLayout -> IO CInt + +enum "PangoWrapMode" ''#{type PangoWrapMode} [''Show] [ + ("PangoWrapWord", #{const PANGO_WRAP_WORD}), + ("PangoWrapChar", #{const PANGO_WRAP_CHAR}), + ("PangoWrapWordChar", #{const PANGO_WRAP_WORD_CHAR}) ] + +instance PangoLayoutSetting PangoWrapMode where + pangoLayoutSet = pangoLayoutSetWrap + pangoLayoutGet = pangoLayoutGetWrap + +pangoLayoutSetWrap :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> PangoWrapMode -> m () +pangoLayoutSetWrap (PangoLayoutPrim fl) (PangoWrapMode wm) = unsafeIOToPrim + $ withForeignPtr fl \pl -> c_pango_layout_set_wrap pl wm + +pangoLayoutGetWrap :: PangoLayout -> PangoWrapMode +pangoLayoutGetWrap (PangoLayout_ fl) = unsafePerformIO $ PangoWrapMode + <$> withForeignPtr fl c_pango_layout_get_wrap + +foreign import ccall "pango_layout_set_wrap" c_pango_layout_set_wrap :: + Ptr PangoLayout -> #{type PangoWrapMode} -> IO () + +foreign import ccall "pango_layout_get_wrap" c_pango_layout_get_wrap :: + Ptr PangoLayout -> IO #{type PangoWrapMode} + +enum "PangoEllipsizeMode" ''#{type PangoEllipsizeMode} [''Show] [ + ("PangoEllipsizeNone", #{const PANGO_ELLIPSIZE_NONE}), + ("PangoEllipsizeStart", #{const PANGO_ELLIPSIZE_START}), + ("PangoEllipsizeMiddle", #{const PANGO_ELLIPSIZE_MIDDLE}), + ("PangoEllipsizeEnd", #{const PANGO_ELLIPSIZE_END}) ] + +instance PangoLayoutSetting PangoEllipsizeMode where + pangoLayoutSet = pangoLayoutSetEllipsize + pangoLayoutGet = pangoLayoutGetEllipsize + +pangoLayoutSetEllipsize :: PrimMonad m => + PangoLayoutPrim (PrimState m) -> PangoEllipsizeMode -> m () +pangoLayoutSetEllipsize (PangoLayoutPrim fpl) (PangoEllipsizeMode pem) = unsafeIOToPrim + $ withForeignPtr fpl \pl -> c_pango_layout_set_ellipsize pl pem + +pangoLayoutGetEllipsize :: PangoLayout -> PangoEllipsizeMode +pangoLayoutGetEllipsize (PangoLayout_ fl) = unsafePerformIO $ PangoEllipsizeMode + <$> withForeignPtr fl c_pango_layout_get_ellipsize + +foreign import ccall "pango_layout_set_ellipsize" c_pango_layout_set_ellipsize :: + Ptr PangoLayout -> #{type PangoEllipsizeMode} -> IO () + +foreign import ccall "pango_layout_get_ellipsize" c_pango_layout_get_ellipsize :: + Ptr PangoLayout -> IO #{type PangoEllipsizeMode} + +newtype Indent = Indent { getIndent :: PangoFixed } deriving Show + +instance PangoLayoutSetting Indent where + pangoLayoutSet l = pangoLayoutSetIndent l . toCInt . getIndent + pangoLayoutGet l = Indent . fromCInt $ pangoLayoutGetIndent l + +pangoLayoutSetIndent :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> CInt -> m () +pangoLayoutSetIndent (PangoLayoutPrim fl) idt = unsafeIOToPrim + $ withForeignPtr fl \pl -> c_pango_layout_set_indent pl idt + +pangoLayoutGetIndent :: PangoLayout -> CInt +pangoLayoutGetIndent (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl c_pango_layout_get_indent + +foreign import ccall "pango_layout_set_indent" c_pango_layout_set_indent :: + Ptr PangoLayout -> CInt -> IO () + +foreign import ccall "pango_layout_get_indent" c_pango_layout_get_indent :: + Ptr PangoLayout -> IO CInt + +newtype Spacing = Spacing { getSpacing :: PangoFixed } deriving Show + +instance PangoLayoutSetting Spacing where + pangoLayoutSet l = pangoLayoutSetSpacing l . toCInt . getSpacing + pangoLayoutGet l = Spacing . fromCInt $ pangoLayoutGetSpacing l + +pangoLayoutSetSpacing :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> CInt -> m () +pangoLayoutSetSpacing (PangoLayoutPrim fl) sp = unsafeIOToPrim + $ withForeignPtr fl \pl -> c_pango_layout_set_spacing pl sp + +pangoLayoutGetSpacing :: PangoLayout -> CInt +pangoLayoutGetSpacing (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl c_pango_layout_get_spacing + +foreign import ccall "pango_layout_set_spacing" c_pango_layout_set_spacing :: + Ptr PangoLayout -> CInt -> IO () + +foreign import ccall "pango_layout_get_spacing" c_pango_layout_get_spacing :: + Ptr PangoLayout -> IO CInt + +newtype LineSpacing = LineSpacing { getLineSpacing :: CFloat } deriving Show + +instance PangoLayoutSetting LineSpacing where + pangoLayoutSet l = pangoLayoutSetLineSpacing l . getLineSpacing + pangoLayoutGet l = LineSpacing $ pangoLayoutGetLineSpacing l + +pangoLayoutSetLineSpacing :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> CFloat -> m () +pangoLayoutSetLineSpacing (PangoLayoutPrim fpl) fct = unsafeIOToPrim + $ withForeignPtr fpl \pl -> c_pango_layout_set_line_spacing pl fct + +pangoLayoutGetLineSpacing :: PangoLayout -> CFloat +pangoLayoutGetLineSpacing (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl c_pango_layout_get_line_spacing + +foreign import ccall "pango_layout_set_line_spacing" c_pango_layout_set_line_spacing :: + Ptr PangoLayout -> CFloat -> IO () + +foreign import ccall "pango_layout_get_line_spacing" c_pango_layout_get_line_spacing :: + Ptr PangoLayout -> IO CFloat + +newtype Justify = Justify { getJustify :: Bool } deriving Show + +instance PangoLayoutSetting Justify where + pangoLayoutSet l = pangoLayoutSetJustify l . getJustify + pangoLayoutGet l = Justify $ pangoLayoutGetJustify l + +pangoLayoutSetJustify :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> Bool -> m () +pangoLayoutSetJustify (PangoLayoutPrim fl) b = unsafeIOToPrim $ withForeignPtr fl \pl -> + c_pango_layout_set_justify pl $ bool #{const FALSE} #{const TRUE} b + +pangoLayoutGetJustify :: PangoLayout -> Bool +pangoLayoutGetJustify (PangoLayout_ fl) = unsafePerformIO + $ (<$> withForeignPtr fl c_pango_layout_get_justify) \case + #{const FALSE} -> False + #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_layout_set_justify" c_pango_layout_set_justify :: + Ptr PangoLayout -> #{type gboolean} -> IO () + +foreign import ccall "pango_layout_get_justify" c_pango_layout_get_justify :: + Ptr PangoLayout -> IO #{type gboolean} + +newtype AutoDir = AutoDir { getAutoDir :: Bool } deriving Show + +instance PangoLayoutSetting AutoDir where + pangoLayoutSet l = pangoLayoutSetAutoDir l . getAutoDir + pangoLayoutGet l = AutoDir $ pangoLayoutGetAutoDir l + +pangoLayoutSetAutoDir :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> Bool -> m () +pangoLayoutSetAutoDir (PangoLayoutPrim fl) b = unsafeIOToPrim $ withForeignPtr fl \pl -> + c_pango_layout_set_auto_dir pl $ bool #{const FALSE} #{const TRUE} b + +pangoLayoutGetAutoDir :: PangoLayout -> Bool +pangoLayoutGetAutoDir (PangoLayout_ fl) = unsafePerformIO + $ (<$> withForeignPtr fl c_pango_layout_get_auto_dir) \case + #{const FALSE} -> False + #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_layout_set_auto_dir" c_pango_layout_set_auto_dir :: + Ptr PangoLayout -> #{type gboolean} -> IO () + +foreign import ccall "pango_layout_get_auto_dir" c_pango_layout_get_auto_dir :: + Ptr PangoLayout -> IO #{type gboolean} + +enum "PangoAlignment" ''#{type PangoAlignment} [''Show] [ + ("PangoAlignLeft", #{const PANGO_ALIGN_LEFT}), + ("PangoAlignCenter", #{const PANGO_ALIGN_CENTER}), + ("PangoAlignRight", #{const PANGO_ALIGN_RIGHT}) ] + +instance PangoLayoutSetting PangoAlignment where + pangoLayoutSet = pangoLayoutSetAlignment + pangoLayoutGet = pangoLayoutGetAlignment + +pangoLayoutSetAlignment :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> PangoAlignment -> m () +pangoLayoutSetAlignment (PangoLayoutPrim fpl) (PangoAlignment pa) = unsafeIOToPrim + $ withForeignPtr fpl \pl -> c_pango_layout_set_alignment pl pa + +pangoLayoutGetAlignment :: PangoLayout -> PangoAlignment +pangoLayoutGetAlignment (PangoLayout_ fl) = unsafePerformIO + $ PangoAlignment <$> withForeignPtr fl c_pango_layout_get_alignment + +foreign import ccall "pango_layout_set_alignment" c_pango_layout_set_alignment :: + Ptr PangoLayout -> #{type PangoAlignment} -> IO () + +foreign import ccall "pango_layout_get_alignment" c_pango_layout_get_alignment :: + Ptr PangoLayout -> IO #{type PangoAlignment} + +instance PangoLayoutSetting PangoTabArrayNullable where + pangoLayoutSet = pangoLayoutSetTabs + pangoLayoutGet = pangoLayoutGetTabs + +pangoLayoutSetTabs :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> PangoTabArrayNullable -> m () +pangoLayoutSetTabs (PangoLayoutPrim fl) ta = unsafeIOToPrim + $ withForeignPtr fl \pl -> case ta of + PangoTabArrayNull -> c_pango_layout_set_tabs pl nullPtr + PangoTabArrayNotNull fta -> do + addForeignPtrFinalizer fl $ touchForeignPtr fta + withForeignPtr fta $ c_pango_layout_set_tabs pl + +pangoLayoutGetTabs :: PangoLayout -> PangoTabArrayNullable +pangoLayoutGetTabs (PangoLayout_ fl) = unsafePerformIO + $ makePangoTabArrayNullable =<< withForeignPtr fl c_pango_layout_get_tabs + +foreign import ccall "pango_layout_set_tabs" c_pango_layout_set_tabs :: + Ptr PangoLayout -> Ptr PangoTabArray -> IO () + +foreign import ccall "pango_layout_get_tabs" c_pango_layout_get_tabs :: + Ptr PangoLayout -> IO (Ptr PangoTabArray) + +newtype SingleParagraphMode = + SingleParagraphMode { getSingleParagraphMode :: Bool } deriving Show + +instance PangoLayoutSetting SingleParagraphMode where + pangoLayoutSet l = + pangoLayoutSetSingleParagraphMode l . getSingleParagraphMode + pangoLayoutGet l = + SingleParagraphMode $ pangoLayoutGetSingleParagraphMode l + +pangoLayoutSetSingleParagraphMode :: + PrimMonad m => PangoLayoutPrim (PrimState m) -> Bool -> m () +pangoLayoutSetSingleParagraphMode (PangoLayoutPrim fl) spm = unsafeIOToPrim + $ withForeignPtr fl \pl -> + c_pango_layout_set_single_paragraph_mode pl (boolToGboolean spm) + +pangoLayoutGetSingleParagraphMode :: PangoLayout -> Bool +pangoLayoutGetSingleParagraphMode (PangoLayout_ fl) = unsafePerformIO + $ (<$> withForeignPtr fl c_pango_layout_get_single_paragraph_mode) \case + #{const FALSE} -> False; #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_layout_set_single_paragraph_mode" + c_pango_layout_set_single_paragraph_mode :: + Ptr PangoLayout -> #{type gboolean} -> IO () + +foreign import ccall "pango_layout_get_single_paragraph_mode" + c_pango_layout_get_single_paragraph_mode :: + Ptr PangoLayout -> IO #{type gboolean} + +class PangoLayoutInfo i where pangoLayoutInfo :: PangoLayout -> i + +newtype CharacterCount = CharacterCount CInt deriving Show + +instance PangoLayoutInfo CharacterCount where + pangoLayoutInfo = unsafePerformIO . (CharacterCount <$>) . pangoLayoutGetCharacterCount + +pangoLayoutGetCharacterCount :: PangoLayout -> IO CInt +pangoLayoutGetCharacterCount (PangoLayout_ fpl) = + withForeignPtr fpl c_pango_layout_get_character_count + +foreign import ccall "pango_layout_get_character_count" + c_pango_layout_get_character_count :: Ptr PangoLayout -> IO CInt + +newtype IsEllipsized = IsEllipsized Bool deriving Show + +instance PangoLayoutInfo IsEllipsized where + pangoLayoutInfo = unsafePerformIO . (IsEllipsized <$>) . pangoLayoutIsEllipsized + +pangoLayoutIsEllipsized :: PangoLayout -> IO Bool +pangoLayoutIsEllipsized (PangoLayout_ fl) = + (<$> withForeignPtr fl c_pango_layout_is_ellipsized) \case + #{const FALSE} -> False + #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_layout_is_ellipsized" + c_pango_layout_is_ellipsized :: Ptr PangoLayout -> IO #{type gboolean} + +newtype IsWrapped = IsWrapped Bool deriving Show + +instance PangoLayoutInfo IsWrapped where + pangoLayoutInfo = unsafePerformIO . (IsWrapped <$>) . pangoLayoutIsWrapped + +pangoLayoutIsWrapped :: PangoLayout -> IO Bool +pangoLayoutIsWrapped (PangoLayout_ fl) = + (<$> withForeignPtr fl c_pango_layout_is_wrapped) \case + #{const FALSE} -> False + #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_layout_is_wrapped" c_pango_layout_is_wrapped :: + Ptr PangoLayout -> IO #{type gboolean} + +newtype UnknownGlyphsCount = UnknownGlyphsCount CInt deriving Show + +instance PangoLayoutInfo UnknownGlyphsCount where + pangoLayoutInfo = unsafePerformIO . (UnknownGlyphsCount <$>) . pangoLayoutGetUnknownGlyphsCount + +pangoLayoutGetUnknownGlyphsCount :: PangoLayout -> IO CInt +pangoLayoutGetUnknownGlyphsCount (PangoLayout_ fpl) = + withForeignPtr fpl c_pango_layout_get_unknown_glyphs_count + +foreign import ccall "pango_layout_get_unknown_glyphs_count" + c_pango_layout_get_unknown_glyphs_count :: Ptr PangoLayout -> IO CInt + +data PangoLogAttr = PangoLogAttr_ (ForeignPtr PangoLogAttr) Int deriving Show +data PangoLogAttrStruct + +pattern PangoLogAttr :: + Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> + Bool -> Bool -> Bool -> Bool -> PangoLogAttr +pattern PangoLogAttr { + pangoLogAttrIsLineBreak, + pangoLogAttrIsMandatoryBreak, + pangoLogAttrIsCharBreak, + pangoLogAttrIsWhite, + pangoLogAttrIsCursorPosition, + pangoLogAttrIsWordStart, + pangoLogAttrIsWordEnd, + pangoLogAttrIsSentenceBoundary, + pangoLogAttrIsSentenceStart, + pangoLogAttrIsSentenceEnd, + pangoLogAttrBackspaceDeleteCharacter, + pangoLogAttrIsExpandableSpace, + pangoLogAttrIsWordBoundary } <- (pangoLogAttrExpand -> PangoLogAttrExpand + pangoLogAttrIsLineBreak + pangoLogAttrIsMandatoryBreak + pangoLogAttrIsCharBreak + pangoLogAttrIsWhite + pangoLogAttrIsCursorPosition + pangoLogAttrIsWordStart + pangoLogAttrIsWordEnd + pangoLogAttrIsSentenceBoundary + pangoLogAttrIsSentenceStart + pangoLogAttrIsSentenceEnd + pangoLogAttrBackspaceDeleteCharacter + pangoLogAttrIsExpandableSpace + pangoLogAttrIsWordBoundary) + +data PangoLogAttrExpand = PangoLogAttrExpand { + pangoLogAttrExpandIsLineBreak :: Bool, + pangoLogAttrExpandIsMandatoryBreak :: Bool, + pangoLogAttrExpandIsCharBreak :: Bool, + pangoLogAttrExpandIsWhite :: Bool, + pangoLogAttrExpandIsCursorPosition :: Bool, + pangoLogAttrExpandIsWordStart :: Bool, + pangoLogAttrExpandIsWordEnd :: Bool, + pangoLogAttrExpandIsSentenceBoundary :: Bool, + pangoLogAttrExpandIsSentenceStart :: Bool, + pangoLogAttrExpandIsSentenceEnd :: Bool, + pangoLogAttrExpandBackspaceDeletesCharacter :: Bool, + pangoLogAttrExpandIsExpandableSpace :: Bool, + pangoLogAttrExpandIsWordBoundary :: Bool + } deriving Show + +pangoLogAttrExpand :: PangoLogAttr -> PangoLogAttrExpand +pangoLogAttrExpand (PangoLogAttr_ fb i) = unsafePerformIO + $ withForeignPtr fb \pb_ -> let pb = pb_ `plusPtr` (i * #{size PangoLogAttr}) in + allocaBytes #{size PangoLogAttrStr} \ps -> do + c_pango_log_attr_to_struct pb ps + PangoLogAttrExpand + <$> #{peek PangoLogAttrStr, is_line_break} ps + <*> #{peek PangoLogAttrStr, is_mandatory_break} ps + <*> #{peek PangoLogAttrStr, is_char_break} ps + <*> #{peek PangoLogAttrStr, is_white} ps + <*> #{peek PangoLogAttrStr, is_cursor_position} ps + <*> #{peek PangoLogAttrStr, is_word_start} ps + <*> #{peek PangoLogAttrStr, is_word_end} ps + <*> #{peek PangoLogAttrStr, is_sentence_boundary} ps + <*> #{peek PangoLogAttrStr, is_sentence_start} ps + <*> #{peek PangoLogAttrStr, is_sentence_end} ps + <*> #{peek PangoLogAttrStr, backspace_deletes_character} ps + <*> #{peek PangoLogAttrStr, is_expandable_space} ps + <*> #{peek PangoLogAttrStr, is_word_boundary} ps + +foreign import ccall "pango_log_attr_to_struct" c_pango_log_attr_to_struct :: + Ptr PangoLogAttr -> Ptr PangoLogAttrStruct -> IO () + +instance PangoLayoutInfo PangoLogAttrs where + pangoLayoutInfo = pangoLayoutGetLogAttrs + +data PangoLogAttrs = PangoLogAttrs (ForeignPtr PangoLogAttr) CInt deriving Show + +mkPangoLogAttrs :: Ptr PangoLogAttr -> CInt -> IO PangoLogAttrs +mkPangoLogAttrs p n = + (`PangoLogAttrs` n) <$> newForeignPtr p (c_g_free_pango_log_attr p) + +foreign import ccall "g_free" c_g_free_pango_log_attr :: + Ptr PangoLogAttr -> IO () + +pangoLayoutGetLogAttrs :: PangoLayout -> PangoLogAttrs +pangoLayoutGetLogAttrs (PangoLayout_ fl) = unsafePerformIO + $ withForeignPtr fl \pl -> alloca \plas -> alloca \pn -> do + c_pango_layout_get_log_attrs pl plas pn + uncurry mkPangoLogAttrs =<< (,) <$> peek plas <*> peek pn + +foreign import ccall "pango_layout_get_log_attrs" c_pango_layout_get_log_attrs :: + Ptr PangoLayout -> Ptr (Ptr PangoLogAttr) -> Ptr CInt -> IO () + +pangoLogAttrsGetSize :: PangoLogAttrs -> Int +pangoLogAttrsGetSize (PangoLogAttrs _ sz) = fromIntegral sz + +pangoLogAttrsGetLogAttr :: PangoLogAttrs -> Int -> Maybe PangoLogAttr +pangoLogAttrsGetLogAttr (PangoLogAttrs fla sz) i + | 0 <= i && i < fromIntegral sz = Just $ PangoLogAttr_ fla i + | otherwise = Nothing + +instance PangoLayoutInfo Extents where + pangoLayoutInfo = unsafePerformIO . (uncurry Extents <$>) . pangoLayoutGetExtents + +pangoLayoutGetExtents :: PangoLayout -> IO (PangoRectangleFixed, PangoRectangleFixed) +pangoLayoutGetExtents (PangoLayout_ fpl) = withForeignPtr fpl \pl -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_get_extents pl irct lrct + (,) <$> (PangoRectangleFixed_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectangleFixed_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_get_extents" c_pango_layout_get_extents :: + Ptr PangoLayout -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () + +instance PangoLayoutInfo PixelExtents where + pangoLayoutInfo = unsafePerformIO . (uncurry PixelExtents <$>) . pangoLayoutGetPixelExtents + +pangoLayoutGetPixelExtents :: PangoLayout -> IO (PangoRectanglePixel, PangoRectanglePixel) +pangoLayoutGetPixelExtents (PangoLayout_ fpl) = + withForeignPtr fpl \pl -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_get_pixel_extents pl irct lrct + (,) <$> (PangoRectanglePixel_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectanglePixel_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_get_pixel_extents" c_pango_layout_get_pixel_extents :: + Ptr PangoLayout -> Ptr PangoRectanglePixel -> Ptr PangoRectanglePixel -> IO () + +data LayoutSize = LayoutSize { + layoutSizeWidth :: PangoFixed, layoutSizeHeight :: PangoFixed } + deriving Show + +instance PangoLayoutInfo LayoutSize where + pangoLayoutInfo = unsafePerformIO . (uncurry LayoutSize <$>) . pangoLayoutGetSize + +pangoLayoutGetSize :: PangoLayout -> IO (PangoFixed, PangoFixed) +pangoLayoutGetSize (PangoLayout_ fpl) = + withForeignPtr fpl \pl -> alloca \pw -> alloca \ph -> do + c_pango_layout_get_size pl pw ph + (\w h -> (fromCInt w, fromCInt h)) <$> peek pw <*> peek ph + +foreign import ccall "pango_layout_get_size" c_pango_layout_get_size :: + Ptr PangoLayout -> Ptr CInt -> Ptr CInt -> IO () + +data LayoutPixelSize = LayoutPixelSize { + layoutPixelSizeWidth :: CInt, layoutPixelSizeHeight :: CInt } + deriving Show + +instance PangoLayoutInfo LayoutPixelSize where + pangoLayoutInfo = unsafePerformIO . (uncurry LayoutPixelSize <$>) . pangoLayoutGetPixelSize + +pangoLayoutGetPixelSize :: PangoLayout -> IO (CInt, CInt) +pangoLayoutGetPixelSize (PangoLayout_ fpl) = + withForeignPtr fpl \pl -> alloca \w -> alloca \h -> do + c_pango_layout_get_pixel_size pl w h + (,) <$> peek w <*> peek h + +foreign import ccall "pango_layout_get_pixel_size" c_pango_layout_get_pixel_size :: + Ptr PangoLayout -> Ptr CInt -> Ptr CInt -> IO () + +newtype Baseline = Baseline PangoFixed deriving Show + +instance PangoLayoutInfo Baseline where + pangoLayoutInfo = unsafePerformIO . (Baseline . fromCInt <$>) . pangoLayoutGetBaseline + +pangoLayoutGetBaseline :: PangoLayout -> IO CInt +pangoLayoutGetBaseline (PangoLayout_ fpl) = + withForeignPtr fpl c_pango_layout_get_baseline + +foreign import ccall "pango_layout_get_baseline" c_pango_layout_get_baseline :: + Ptr PangoLayout -> IO CInt + +newtype LineCount = LineCount CInt deriving Show + +instance PangoLayoutInfo LineCount where + pangoLayoutInfo = unsafePerformIO . (LineCount <$>) . pangoLayoutGetLineCount + +pangoLayoutGetLineCount :: PangoLayout -> IO CInt +pangoLayoutGetLineCount (PangoLayout_ fpl) = + withForeignPtr fpl c_pango_layout_get_line_count + +foreign import ccall "pango_layout_get_line_count" c_pango_layout_get_line_count :: + Ptr PangoLayout -> IO CInt + +pangoLayoutIndexToPos :: PangoLayout -> Int -> IO (Maybe PangoRectangleFixed) +pangoLayoutIndexToPos (PangoLayout_ fl) idx = withForeignPtr fl \pl -> do + pos <- mallocBytes #{size PangoRectangle} + t <- c_pango_layout_get_text pl + is <- byteIndices =<< toCStringLen t + case is `maybeIndex` idx of + Nothing -> pure Nothing + Just i -> do + c_pango_layout_index_to_pos pl (fromIntegral i) pos + Just . PangoRectangleFixed_ <$> newForeignPtr pos (free pos) + +maybeIndex :: [a] -> Int -> Maybe a +maybeIndex _ i | i < 0 = Nothing +maybeIndex [] _ = Nothing +maybeIndex (x : _) 0 = Just x +maybeIndex (_ : xs) i = maybeIndex xs (i - 1) + +foreign import ccall "pango_layout_index_to_pos" c_pango_layout_index_to_pos :: + Ptr PangoLayout -> CInt -> Ptr PangoRectangleFixed -> IO () + +pangoLayoutIndexToLineX :: PangoLayout -> Int -> Bool -> IO (Maybe (CInt, PangoFixed)) +pangoLayoutIndexToLineX (PangoLayout_ fpl) idx tr = + withForeignPtr fpl \pl -> alloca \ln -> alloca \xpos -> do + t <- c_pango_layout_get_text pl + is <- byteIndices =<< toCStringLen t + case is `maybeIndex` idx of + Nothing -> pure Nothing + Just i -> do + c_pango_layout_index_to_line_x pl (fromIntegral i) (boolToGboolean tr) ln xpos + Just <$> ((,) <$> peek ln <*> (fromCInt <$> peek xpos)) + +foreign import ccall "pango_layout_index_to_line_x" + c_pango_layout_index_to_line_x :: + Ptr PangoLayout -> CInt -> #{type gboolean} -> Ptr CInt -> Ptr CInt -> IO () + +pangoLayoutXyToIndex :: PangoLayout -> PangoFixed -> PangoFixed -> IO (Int, CInt, Bool) +pangoLayoutXyToIndex (PangoLayout_ fpl) x_ y_ = + withForeignPtr fpl \pl -> alloca \idx -> alloca \tr -> do + t <- c_pango_layout_get_text pl + is <- byteIndices =<< toCStringLen t + isd <- c_pango_layout_xy_to_index pl x y idx tr + (,,) <$> (fromJust . (`elemIndex` is) . fromIntegral <$> peek idx) <*> peek tr <*> pure (gbooleanToBool isd) + where + [x, y] = toCInt <$> [x_, y_] + +foreign import ccall "pango_layout_xy_to_index" c_pango_layout_xy_to_index :: + Ptr PangoLayout -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO #type gboolean + +pangoLayoutGetCursorPos :: PangoLayout -> Int -> IO (Maybe (PangoRectangleFixed, PangoRectangleFixed)) +pangoLayoutGetCursorPos (PangoLayout_ fpl) idx = withForeignPtr fpl \pl -> do + spos <- mallocBytes #{size PangoRectangle} + wpos <- mallocBytes #{size PangoRectangle} + t <- c_pango_layout_get_text pl + is <- byteIndices =<< toCStringLen t + case is `maybeIndex` idx of + Nothing -> pure Nothing + Just i -> do + c_pango_layout_get_cursor_pos pl (fromIntegral i) spos wpos + (Just <$>) $ (,) + <$> (PangoRectangleFixed_ <$> newForeignPtr spos (free spos)) + <*> (PangoRectangleFixed_ <$> newForeignPtr wpos (free wpos)) + +foreign import ccall "pango_layout_get_cursor_pos" c_pango_layout_get_cursor_pos :: + Ptr PangoLayout -> CInt -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () + +data MinMax a = Min | Jst a | Max deriving Show +data Dir = L | R deriving Show + +pangoLayoutMoveCursorVisually :: + PangoLayout -> Bool -> Int -> Bool -> Dir -> IO (Maybe (MinMax Int, CInt)) +pangoLayoutMoveCursorVisually (PangoLayout_ fpl) str oidx otr dir = + withForeignPtr fpl \pl -> alloca \nidx -> alloca \ntr -> do + t <- c_pango_layout_get_text pl + is <- byteIndices =<< toCStringLen t + case is `maybeIndex` oidx of + Nothing -> pure Nothing + Just i -> do + c_pango_layout_move_cursor_visually pl + (boolToGboolean str) (fromIntegral i) (bool 0 1 otr) + (case dir of L -> - 1; R -> 1) nidx ntr + nidx' <- peek nidx + let mnidx = case nidx of + _ | nidx' < 0 -> Min + | nidx' < maxBound -> Jst . fromJust . (`elemIndex` is) $ fromIntegral nidx' + | otherwise -> Max + ntr' <- peek ntr + pure . Just $ (mnidx, ntr') + +foreign import ccall "pango_layout_move_cursor_visually" c_pango_layout_move_cursor_visually :: + Ptr PangoLayout -> #{type gboolean} -> CInt -> CInt -> CInt -> + Ptr CInt -> Ptr CInt -> IO () diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter.hs b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayoutIter ( + -- * TYPE + PangoLayoutIter, + + -- * GET ITERATOR + pangoLayoutGetIter, + + -- * NEXT + pangoLayoutIterNextRun, pangoLayoutIterNextChar, + pangoLayoutIterNextCluster, pangoLayoutIterNextLine, + pangoLayoutIterAtLastLine, + + -- * GET FROM ITERATOR + -- ** Get Index and Baseline + pangoLayoutIterGetIndex, pangoLayoutIterGetBaseline, + + -- ** Get Run and Line + pangoLayoutIterGetRun, pangoLayoutIterGetLine, + + -- ** Get Extents + pangoLayoutIterGetCharExtents, pangoLayoutIterGetClusterExtents, + pangoLayoutIterGetRunExtents, + pangoLayoutIterGetLineYrange, pangoLayoutIterGetLineExtents ) where + +import Graphics.Pango.Basic.LayoutObjects.PangoLayoutIter.Internal diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter/Internal.hsc b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutIter/Internal.hsc @@ -0,0 +1,196 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayoutIter.Internal ( + -- * TYPE + PangoLayoutIter(..), + + -- * GET ITERATOR + pangoLayoutGetIter, + + -- * NEXT + pangoLayoutIterNextRun, pangoLayoutIterNextChar, + pangoLayoutIterNextCluster, pangoLayoutIterNextLine, + pangoLayoutIterAtLastLine, + + -- * GET FROM ITERATOR + -- ** Get Index and Baseline + pangoLayoutIterGetIndex, pangoLayoutIterGetBaseline, + + -- ** Get Run and Line + pangoLayoutIterGetRun, pangoLayoutIterGetLine, + + -- ** Get Extents + pangoLayoutIterGetCharExtents, pangoLayoutIterGetClusterExtents, + pangoLayoutIterGetRunExtents, + pangoLayoutIterGetLineYrange, pangoLayoutIterGetLineExtents ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Data.Int + +import System.GLib.Bool +import Graphics.Pango.Basic.GlyphStorage.Internal +import Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal +import Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine.Internal + +#include + +newtype PangoLayoutIter = PangoLayoutIter (ForeignPtr PangoLayoutIter) + deriving Show + +makePangoLayoutIter :: ForeignPtr PangoLayout -> Ptr PangoLayoutIter -> IO PangoLayoutIter +makePangoLayoutIter fl p = + PangoLayoutIter <$> newForeignPtr p (c_pango_layout_iter_free p >> touchForeignPtr fl) + +foreign import ccall "pango_layout_iter_free" c_pango_layout_iter_free :: + Ptr PangoLayoutIter -> IO () + +pangoLayoutGetIter :: PangoLayout -> IO PangoLayoutIter +pangoLayoutGetIter (PangoLayout_ fl) = + makePangoLayoutIter fl =<< withForeignPtr fl c_pango_layout_get_iter + +foreign import ccall "pango_layout_get_iter" c_pango_layout_get_iter :: + Ptr PangoLayout -> IO (Ptr PangoLayoutIter) + +pangoLayoutIterNextRun :: PangoLayoutIter -> IO Bool +pangoLayoutIterNextRun (PangoLayoutIter fli) = + gbooleanToBool <$> withForeignPtr fli c_pango_layout_iter_next_run + +foreign import ccall "pango_layout_iter_next_run" + c_pango_layout_iter_next_run :: + Ptr PangoLayoutIter -> IO #type gboolean + +pangoLayoutIterNextChar :: PangoLayoutIter -> IO Bool +pangoLayoutIterNextChar (PangoLayoutIter fli) = + gbooleanToBool <$> withForeignPtr fli c_pango_layout_iter_next_char + +foreign import ccall "pango_layout_iter_next_char" + c_pango_layout_iter_next_char :: + Ptr PangoLayoutIter -> IO #type gboolean + +pangoLayoutIterNextCluster :: PangoLayoutIter -> IO Bool +pangoLayoutIterNextCluster (PangoLayoutIter fli) = + gbooleanToBool <$> withForeignPtr fli c_pango_layout_iter_next_cluster + +foreign import ccall "pango_layout_iter_next_cluster" + c_pango_layout_iter_next_cluster :: + Ptr PangoLayoutIter -> IO #type gboolean + +pangoLayoutIterNextLine :: PangoLayoutIter -> IO Bool +pangoLayoutIterNextLine (PangoLayoutIter fli) = + gbooleanToBool <$> withForeignPtr fli c_pango_layout_iter_next_line + +foreign import ccall "pango_layout_iter_next_line" + c_pango_layout_iter_next_line :: + Ptr PangoLayoutIter -> IO #type gboolean + +pangoLayoutIterAtLastLine :: PangoLayoutIter -> IO Bool +pangoLayoutIterAtLastLine (PangoLayoutIter fli) = + gbooleanToBool <$> withForeignPtr fli c_pango_layout_iter_at_last_line + +foreign import ccall "pango_layout_iter_at_last_line" + c_pango_layout_iter_at_last_line :: + Ptr PangoLayoutIter -> IO #type gboolean + +pangoLayoutIterGetIndex :: PangoLayoutIter -> IO CInt +pangoLayoutIterGetIndex (PangoLayoutIter fli) = + withForeignPtr fli c_pango_layout_iter_get_index + +foreign import ccall "pango_layout_iter_get_index" + c_pango_layout_iter_get_index :: + Ptr PangoLayoutIter -> IO CInt + +pangoLayoutIterGetBaseline :: PangoLayoutIter -> IO CInt +pangoLayoutIterGetBaseline (PangoLayoutIter fli) = + withForeignPtr fli c_pango_layout_iter_get_baseline + +foreign import ccall "pango_layout_iter_get_baseline" + c_pango_layout_iter_get_baseline :: + Ptr PangoLayoutIter -> IO CInt + +pangoLayoutIterGetRun :: PangoLayoutIter -> IO (Maybe PangoLayoutRun) +pangoLayoutIterGetRun (PangoLayoutIter fli) = mkPangoGlyphItemMaybe0 + =<< withForeignPtr fli c_pango_layout_iter_get_run + +foreign import ccall "pango_layout_iter_get_run" c_pango_layout_iter_get_run :: + Ptr PangoLayoutIter -> IO (Ptr PangoLayoutRun) + +pangoLayoutIterGetLine :: PangoLayoutIter -> IO PangoLayoutLine +pangoLayoutIterGetLine (PangoLayoutIter fli) = + makePangoLayoutLine' fli =<< withForeignPtr fli c_pango_layout_iter_get_line + +makePangoLayoutLine' :: ForeignPtr PangoLayoutIter -> Ptr PangoLayoutLine -> IO PangoLayoutLine +makePangoLayoutLine' fli p = PangoLayoutLine <$> newForeignPtr p (touchForeignPtr fli) + +foreign import ccall "pango_layout_iter_get_line" + c_pango_layout_iter_get_line :: + Ptr PangoLayoutIter -> IO (Ptr PangoLayoutLine) + +pangoLayoutIterGetCharExtents :: PangoLayoutIter -> IO PangoRectangleFixed +pangoLayoutIterGetCharExtents (PangoLayoutIter fli) = + withForeignPtr fli \pli -> do + rct <- mallocBytes #{size PangoRectangle} + c_pango_layout_iter_get_char_extents pli rct + PangoRectangleFixed_ <$> newForeignPtr rct (free rct) + +foreign import ccall "pango_layout_iter_get_char_extents" + c_pango_layout_iter_get_char_extents :: + Ptr PangoLayoutIter -> Ptr PangoRectangleFixed -> IO () + +pangoLayoutIterGetClusterExtents :: + PangoLayoutIter -> IO (PangoRectangleFixed, PangoRectangleFixed) +pangoLayoutIterGetClusterExtents (PangoLayoutIter fli) = + withForeignPtr fli \pli -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_iter_get_cluster_extents pli irct lrct + (,) <$> (PangoRectangleFixed_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectangleFixed_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_iter_get_cluster_extents" + c_pango_layout_iter_get_cluster_extents :: + Ptr PangoLayoutIter -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () + +pangoLayoutIterGetRunExtents :: + PangoLayoutIter -> IO (PangoRectangleFixed, PangoRectangleFixed) +pangoLayoutIterGetRunExtents (PangoLayoutIter fli) = + withForeignPtr fli \pli -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_iter_get_run_extents pli irct lrct + (,) <$> (PangoRectangleFixed_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectangleFixed_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_iter_get_run_extents" + c_pango_layout_iter_get_run_extents :: + Ptr PangoLayoutIter -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () + +pangoLayoutIterGetLineYrange :: PangoLayoutIter -> IO (CInt, CInt) +pangoLayoutIterGetLineYrange (PangoLayoutIter fli) = + withForeignPtr fli \pli -> alloca \y0 -> alloca \y1 -> do + c_pango_layout_iter_get_line_yrange pli y0 y1 + (,) <$> peek y0 <*> peek y1 + +foreign import ccall "pango_layout_iter_get_line_yrange" + c_pango_layout_iter_get_line_yrange :: + Ptr PangoLayoutIter -> Ptr CInt -> Ptr CInt -> IO () + +pangoLayoutIterGetLineExtents :: + PangoLayoutIter -> IO (PangoRectangleFixed, PangoRectangleFixed) +pangoLayoutIterGetLineExtents (PangoLayoutIter fli) = + withForeignPtr fli \pli -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_iter_get_line_extents pli irct lrct + (,) <$> (PangoRectangleFixed_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectangleFixed_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_iter_get_line_extents" + c_pango_layout_iter_get_line_extents :: + Ptr PangoLayoutIter -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine.hsc b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine.hsc @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine ( + + -- * TYPE + PangoLayoutLine, + + -- * GET LINE + pangoLayoutGetLine, pangoLayoutGetLines, + + -- * GET FROM LINE + pangoLayoutLineGetExtents, pangoLayoutLineGetPixelExtents, + pangoLayoutLineIndexToX, pangoLayoutLineXToIndex, + pangoLayoutLineGetXRanges ) where + +import Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine.Internal diff --git a/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine/Internal.hsc b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/LayoutObjects/PangoLayoutLine/Internal.hsc @@ -0,0 +1,117 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine.Internal ( + + -- * TYPE + PangoLayoutLine(..), + + -- * GET LINE + pangoLayoutGetLine, pangoLayoutGetLines, + + -- * GET FROM LINE + pangoLayoutLineGetExtents, pangoLayoutLineGetPixelExtents, + pangoLayoutLineIndexToX, pangoLayoutLineXToIndex, + pangoLayoutLineGetXRanges ) where + +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Data.Int + +import System.GLib.Bool +import Graphics.Pango.Basic.GlyphStorage.Internal +import Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal +import System.GLib.SinglyLinkedLists + +#include + +pangoLayoutGetLine :: PangoLayout -> CInt -> IO (Maybe PangoLayoutLine) +pangoLayoutGetLine (PangoLayout_ fl) ln = makePangoLayoutLineMaybe fl + =<< withForeignPtr fl \pl -> c_pango_layout_get_line pl ln + +foreign import ccall "pango_layout_get_line" c_pango_layout_get_line :: + Ptr PangoLayout -> CInt -> IO (Ptr PangoLayoutLine) + +newtype PangoLayoutLine = PangoLayoutLine (ForeignPtr PangoLayoutLine) deriving Show + +makePangoLayoutLine :: ForeignPtr PangoLayout -> Ptr PangoLayoutLine -> IO PangoLayoutLine +makePangoLayoutLine fl p = PangoLayoutLine <$> newForeignPtr p (touchForeignPtr fl) + +makePangoLayoutLineMaybe :: ForeignPtr PangoLayout -> Ptr PangoLayoutLine -> IO (Maybe PangoLayoutLine) +makePangoLayoutLineMaybe fl = \case + NullPtr -> pure Nothing + p -> Just . PangoLayoutLine + <$> newForeignPtr p (touchForeignPtr fl) + +pangoLayoutGetLines :: PangoLayout -> IO [PangoLayoutLine] +pangoLayoutGetLines (PangoLayout_ fl) = withForeignPtr fl \pl -> + (makePangoLayoutLine fl `mapM`) =<< g_slist_to_list =<< c_pango_layout_get_lines pl + +foreign import ccall "pango_layout_get_lines" c_pango_layout_get_lines :: + Ptr PangoLayout -> IO (Ptr (GSList PangoLayoutLine)) + +pangoLayoutLineGetExtents :: PangoLayoutLine -> IO Extents +pangoLayoutLineGetExtents (PangoLayoutLine fll) = + withForeignPtr fll \pll -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_line_get_extents pll irct lrct + Extents <$> (PangoRectangleFixed_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectangleFixed_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_line_get_extents" + c_pango_layout_line_get_extents :: + Ptr PangoLayoutLine -> Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO () + +pangoLayoutLineGetPixelExtents :: PangoLayoutLine -> IO PixelExtents +pangoLayoutLineGetPixelExtents (PangoLayoutLine fpll) = + withForeignPtr fpll \pll -> do + irct <- mallocBytes #{size PangoRectangle} + lrct <- mallocBytes #{size PangoRectangle} + c_pango_layout_line_get_pixel_extents pll irct lrct + PixelExtents + <$> (PangoRectanglePixel_ <$> newForeignPtr irct (free irct)) + <*> (PangoRectanglePixel_ <$> newForeignPtr lrct (free lrct)) + +foreign import ccall "pango_layout_line_get_pixel_extents" + c_pango_layout_line_get_pixel_extents :: + Ptr PangoLayoutLine -> + Ptr PangoRectanglePixel -> Ptr PangoRectanglePixel -> IO () + +pangoLayoutLineIndexToX :: PangoLayoutLine -> CInt -> Bool -> IO CInt +pangoLayoutLineIndexToX (PangoLayoutLine fpll) idx trl = + withForeignPtr fpll \pll -> alloca \xpos -> do + c_pango_layout_line_index_to_x pll idx (boolToGboolean trl) xpos + peek xpos + +foreign import ccall "pango_layout_line_index_to_x" + c_pango_layout_line_index_to_x :: + Ptr PangoLayoutLine -> CInt -> #{type gboolean} -> Ptr CInt -> IO () + +pangoLayoutLineXToIndex :: PangoLayoutLine -> CInt -> IO (CInt, CInt, Bool) +pangoLayoutLineXToIndex (PangoLayoutLine fpll) xpos = + withForeignPtr fpll \pll -> alloca \idx -> alloca \trl -> do + isd <- c_pango_layout_line_x_to_index pll xpos idx trl + (,,) <$> peek idx <*> peek trl <*> pure (gbooleanToBool isd) + +foreign import ccall "pango_layout_line_x_to_index" + c_pango_layout_line_x_to_index :: + Ptr PangoLayoutLine -> CInt -> Ptr CInt -> Ptr CInt -> IO #type gboolean + +pangoLayoutLineGetXRanges :: PangoLayoutLine -> CInt -> CInt -> IO [CInt] +pangoLayoutLineGetXRanges (PangoLayoutLine fpll) st ed = + withForeignPtr fpll \pll -> alloca \prngs -> alloca \pn -> do + c_pango_layout_line_get_x_ranges pll st ed prngs pn + rngs <- peek prngs + n <- peek pn + peekArray (fromIntegral $ 2 * n) rngs <* c_g_free rngs + +foreign import ccall "pango_layout_line_get_x_ranges" c_pango_layout_line_get_x_ranges :: + Ptr PangoLayoutLine -> CInt -> CInt -> Ptr (Ptr CInt) -> Ptr CInt -> IO () + +foreign import ccall "g_free" c_g_free :: Ptr a -> IO () diff --git a/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage.hs b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage ( + -- * TYPE + PangoLanguage, pattern PangoLanguage, getPangoLanguage, + + -- * FUNCTION + pangoLanguageMatches, pangoLanguageIncludesScript, + pangoLanguageGetScripts, pangoLanguageGetDefault, + pangoLanguageGetSampleString ) where + +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage.Internal diff --git a/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage/Internal.hsc b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoLanguage/Internal.hsc @@ -0,0 +1,103 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage.Internal ( + -- * TYPE + PangoLanguage(..), pattern PangoLanguage, getPangoLanguage, + + -- * FUNCTION + pangoLanguageMatches, pangoLanguageIncludesScript, + pangoLanguageGetScripts, pangoLanguageGetDefault, + pangoLanguageGetSampleString ) where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Data.Int +import Data.Text.CString +import Text.Read +import System.IO.Unsafe + +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum + +import qualified Data.Text as T + +#include + +pangoLanguageGetDefault :: IO PangoLanguage +pangoLanguageGetDefault = PangoLanguage_ <$> c_pango_language_get_default + +foreign import ccall "pango_language_get_default" + c_pango_language_get_default :: IO (Ptr PangoLanguage) + +pangoLanguageGetSampleString :: PangoLanguage -> T.Text +pangoLanguageGetSampleString (PangoLanguage_ pl) = unsafePerformIO + $ peekCStringText =<< c_pango_language_get_sample_string pl + +foreign import ccall "pango_language_get_sample_string" + c_pango_language_get_sample_string :: Ptr PangoLanguage -> IO CString + +pangoLanguageMatches :: PangoLanguage -> String -> Bool +pangoLanguageMatches (PangoLanguage_ l) rl = unsafePerformIO + $ withCString rl \crl -> (<$> c_pango_language_matches l crl) \case + #{const FALSE} -> False; #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_language_matches" c_pango_language_matches :: + Ptr PangoLanguage -> CString -> IO #{type gboolean} + +pangoLanguageIncludesScript :: PangoLanguage -> PangoScript -> Bool +pangoLanguageIncludesScript (PangoLanguage_ l) (PangoScript s) = unsafePerformIO + $ (<$> c_pango_language_includes_script l s) \case + #{const FALSE} -> False; #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_language_includes_script" c_pango_language_includes_script :: + Ptr PangoLanguage -> #{type PangoScript} -> IO #{type gboolean} + +pangoLanguageGetScripts :: PangoLanguage -> [PangoScript] +pangoLanguageGetScripts (PangoLanguage_ l) = unsafePerformIO + $ (PangoScript <$>) <$> alloca \pn -> do + ss <- c_pango_language_get_scripts l pn + n <- peek pn + peekArray (fromIntegral n) ss + +foreign import ccall "pango_language_get_scripts" c_pango_language_get_scripts :: + Ptr PangoLanguage -> Ptr CInt -> IO (Ptr #{type PangoScript}) + +newtype PangoLanguage = PangoLanguage_ (Ptr PangoLanguage) + +instance Show PangoLanguage where + showsPrec d l = showParen (d > 10) + $ ("PangoLanguage " ++) . (show (pangoLanguageToString l) ++) + +instance Read PangoLanguage where + readPrec = parens $ prec appPrec do + Ident "PangoLanguage" <- lexP + s <- step readPrec + pure $ PangoLanguage s + where appPrec = 10 + +{-# COMPLETE PangoLanguage #-} + +pattern PangoLanguage :: String -> PangoLanguage +pattern PangoLanguage { getPangoLanguage } + <- (pangoLanguageToString -> getPangoLanguage) where + PangoLanguage s = pangoLanguageFromString s + +pangoLanguageToString :: PangoLanguage -> String +pangoLanguageToString (PangoLanguage_ pl) = + unsafePerformIO $ peekCString =<< c_pango_language_to_string pl + +foreign import ccall "pango_language_to_string" + c_pango_language_to_string :: Ptr PangoLanguage -> IO CString + +pangoLanguageFromString :: String -> PangoLanguage +pangoLanguageFromString l = unsafePerformIO $ withCString l \cl -> + PangoLanguage_ <$> c_pango_language_from_string cl + +foreign import ccall "pango_language_from_string" + c_pango_language_from_string :: CString -> IO (Ptr PangoLanguage) diff --git a/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript.hsc b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript.hsc @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript ( + module Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Internal + ) where + +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Internal hiding ( + pattern PangoScript ) diff --git a/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Enum.hsc b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Enum.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Enum.hsc @@ -0,0 +1,141 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum where + +import Foreign.C.Enum +import Data.Int + +#include + +enum "PangoScript" ''#{type PangoScript} [''Show, ''Read] [ + ("PangoScriptInvaludCode", #{const PANGO_SCRIPT_INVALID_CODE}), + ("PangoScriptCommon", #{const PANGO_SCRIPT_COMMON}), + ("PangoScriptInherited", #{const PANGO_SCRIPT_INHERITED}), + + ("PangoScriptArabic", #{const PANGO_SCRIPT_ARABIC}), + ("PangoScriptArmenian", #{const PANGO_SCRIPT_ARMENIAN}), + ("PangoScriptBengali", #{const PANGO_SCRIPT_BENGALI}), + ("PangoScriptBopomofo", #{const PANGO_SCRIPT_BOPOMOFO}), + ("PangoScriptCherokee", #{const PANGO_SCRIPT_CHEROKEE}), + ("PangoScriptCoptic", #{const PANGO_SCRIPT_COPTIC}), + ("PangoScriptCyrillic", #{const PANGO_SCRIPT_CYRILLIC}), + ("PangoScriptDeseret", #{const PANGO_SCRIPT_DESERET}), + ("PangoScriptDevanagari", #{const PANGO_SCRIPT_DEVANAGARI}), + ("PangoScriptEthiopic", #{const PANGO_SCRIPT_ETHIOPIC}), + ("PangoScriptGeorgian", #{const PANGO_SCRIPT_GEORGIAN}), + ("PangoScriptGothic", #{const PANGO_SCRIPT_GOTHIC}), + ("PangoScriptGreek", #{const PANGO_SCRIPT_GREEK}), + ("PangoScriptGujarati", #{const PANGO_SCRIPT_GUJARATI}), + ("PangoScriptGurmukhi", #{const PANGO_SCRIPT_GURMUKHI}), + ("PangoScriptHan", #{const PANGO_SCRIPT_HAN}), + ("PangoScriptHangul", #{const PANGO_SCRIPT_HANGUL}), + ("PangoScriptHebrew", #{const PANGO_SCRIPT_HEBREW}), + ("PangoScriptHiragana", #{const PANGO_SCRIPT_HIRAGANA}), + ("PangoScriptKannada", #{const PANGO_SCRIPT_KANNADA}), + ("PangoScriptKatakana", #{const PANGO_SCRIPT_KATAKANA}), + ("PangoScriptKhmer", #{const PANGO_SCRIPT_KHMER}), + ("PangoScriptLao", #{const PANGO_SCRIPT_LAO}), + ("PangoScriptLatin", #{const PANGO_SCRIPT_LATIN}), + ("PangoScriptMalaylam", #{const PANGO_SCRIPT_MALAYALAM}), + ("PangoScriptMongolian", #{const PANGO_SCRIPT_MONGOLIAN}), + ("PangoScriptMyanmar", #{const PANGO_SCRIPT_MYANMAR}), + ("PangoScriptOgham", #{const PANGO_SCRIPT_OGHAM}), + ("PangoScriptOldItalic", #{const PANGO_SCRIPT_OLD_ITALIC}), + ("PangoScriptOriya", #{const PANGO_SCRIPT_ORIYA}), + ("PangoScriptRunic", #{const PANGO_SCRIPT_RUNIC}), + ("PangoScriptSinhala", #{const PANGO_SCRIPT_SINHALA}), + ("PangoScriptSyriac", #{const PANGO_SCRIPT_SYRIAC}), + ("PangoScriptTamil", #{const PANGO_SCRIPT_TAMIL}), + ("PangoScriptTelugu", #{const PANGO_SCRIPT_TELUGU}), + ("PangoScriptThaana", #{const PANGO_SCRIPT_THAANA}), + ("PangoScriptThai", #{const PANGO_SCRIPT_THAI}), + ("PangoScriptTibetan", #{const PANGO_SCRIPT_TIBETAN}), + ("PangoScriptCanadianAboriginal", + #{const PANGO_SCRIPT_CANADIAN_ABORIGINAL}), + ("PangoScriptYi", #{const PANGO_SCRIPT_YI}), + ("PangoScriptTagalog", #{const PANGO_SCRIPT_TAGALOG}), + ("PangoScriptHanunoo", #{const PANGO_SCRIPT_HANUNOO}), + ("PangoScriptBuhid", #{const PANGO_SCRIPT_BUHID}), + ("PangoScriptTagbanwa", #{const PANGO_SCRIPT_TAGBANWA}), + ("PangoScriptBraille", #{const PANGO_SCRIPT_BRAILLE}), + ("PangoScriptCypriot", #{const PANGO_SCRIPT_CYPRIOT}), + ("PangoScriptLimbu", #{const PANGO_SCRIPT_LIMBU}), + ("PangoScriptOsmanya", #{const PANGO_SCRIPT_OSMANYA}), + ("PangoscriptShavian", #{const PANGO_SCRIPT_SHAVIAN}), + ("PangoScriptLinearB", #{const PANGO_SCRIPT_LINEAR_B}), + ("PangoScriptTaiLe", #{const PANGO_SCRIPT_TAI_LE}), + ("PangoScriptUgaritic", #{const PANGO_SCRIPT_UGARITIC}), + + ("PangoScriptNewTaiLue", #{const PANGO_SCRIPT_NEW_TAI_LUE}), + ("PangoScriptBuginese", #{const PANGO_SCRIPT_BUGINESE}), + ("PangoScriptGlagolitic", #{const PANGO_SCRIPT_GLAGOLITIC}), + ("PangoScriptTifinagh", #{const PANGO_SCRIPT_TIFINAGH}), + ("PangoScriptSylotiNagri", #{const PANGO_SCRIPT_SYLOTI_NAGRI}), + ("PangoScriptOldPersian", #{const PANGO_SCRIPT_OLD_PERSIAN}), + ("PangoScriptKharoshthi", #{const PANGO_SCRIPT_KHAROSHTHI}), + + ("PangoScriptUnknown", #{const PANGO_SCRIPT_UNKNOWN}), + ("PangoScriptBalinese", #{const PANGO_SCRIPT_BALINESE}), + ("PangoScriptCuneiform", #{const PANGO_SCRIPT_CUNEIFORM}), + ("PangoScriptPhoenician", #{const PANGO_SCRIPT_PHOENICIAN}), + ("PangoScriptPhagsPa", #{const PANGO_SCRIPT_PHAGS_PA}), + ("PangoScriptNko", #{const PANGO_SCRIPT_NKO}), + + ("PangoScriptKyahLi", #{const PANGO_SCRIPT_KAYAH_LI}), + ("PangoScriptLepcha", #{const PANGO_SCRIPT_LEPCHA}), + ("PangoScriptRejang", #{const PANGO_SCRIPT_REJANG}), + ("PangoScriptSundanese", #{const PANGO_SCRIPT_SUNDANESE}), + ("PangoScriptSaurashtra", #{const PANGO_SCRIPT_SAURASHTRA}), + ("PangoScriptCham", #{const PANGO_SCRIPT_CHAM}), + ("PangoScriptOlChiki", #{const PANGO_SCRIPT_OL_CHIKI}), + ("PangoScriptVai", #{const PANGO_SCRIPT_VAI}), + ("PangoScriptCarian", #{const PANGO_SCRIPT_CARIAN}), + ("PangoScriptLycian", #{const PANGO_SCRIPT_LYCIAN}), + ("PangoScriptLydian", #{const PANGO_SCRIPT_LYDIAN}), + + ("PangoScriptBatak", #{const PANGO_SCRIPT_BATAK}), + ("PangoScriptBraham", #{const PANGO_SCRIPT_BRAHMI}), + ("PangoScriptMandaic", #{const PANGO_SCRIPT_MANDAIC}), + ("PangoScriptChakma", #{const PANGO_SCRIPT_CHAKMA}), + ("PangoScriptMeroiticCursive", #{const PANGO_SCRIPT_MEROITIC_CURSIVE}), + ("PangoScriptMeroiticHieroglyphs", + #{const PANGO_SCRIPT_MEROITIC_HIEROGLYPHS}), + ("PangoScriptMiao", #{const PANGO_SCRIPT_MIAO}), + ("PangoScriptSharada", #{const PANGO_SCRIPT_SHARADA}), + ("PangoScriptSoraSompeng", #{const PANGO_SCRIPT_SORA_SOMPENG}), + ("PangoScriptTakri", #{const PANGO_SCRIPT_TAKRI}), + + ("PangoScriptBassaVah", #{const PANGO_SCRIPT_BASSA_VAH}), + ("PangoScriptCaucasianAlbanian", + #{const PANGO_SCRIPT_CAUCASIAN_ALBANIAN}), + ("PangoScriptDuployan", #{const PANGO_SCRIPT_DUPLOYAN}), + ("PangoScriptElbasan", #{const PANGO_SCRIPT_ELBASAN}), + ("PangoScriptGrantha", #{const PANGO_SCRIPT_GRANTHA}), + ("PangoScriptKhojki", #{const PANGO_SCRIPT_KHOJKI}), + ("PangoScriptKhudawadi", #{const PANGO_SCRIPT_KHUDAWADI}), + ("PangoScriptLinearA", #{const PANGO_SCRIPT_LINEAR_A}), + ("PangoScriptMahajani", #{const PANGO_SCRIPT_MAHAJANI}), + ("PangoScriptManichaean", #{const PANGO_SCRIPT_MANICHAEAN}), + ("PangoScriptMendeKikakui", #{const PANGO_SCRIPT_MENDE_KIKAKUI}), + ("PangoScriptModi", #{const PANGO_SCRIPT_MODI}), + ("PangoScriptMro", #{const PANGO_SCRIPT_MRO}), + ("PangoScriptNabataean", #{const PANGO_SCRIPT_NABATAEAN}), + ("PangoScriptOldNorthArabian", #{const PANGO_SCRIPT_OLD_NORTH_ARABIAN}), + ("PangoScriptOldPermic", #{const PANGO_SCRIPT_OLD_PERMIC}), + ("PangoScriptPahawhHmong", #{const PANGO_SCRIPT_PAHAWH_HMONG}), + ("PangoScriptPalmyrene", #{const PANGO_SCRIPT_PALMYRENE}), + ("PangoScriptPauCinHau", #{const PANGO_SCRIPT_PAU_CIN_HAU}), + ("PangoScriptPsalterPahlavi", #{const PANGO_SCRIPT_PSALTER_PAHLAVI}), + ("PangoScriptSiddham", #{const PANGO_SCRIPT_SIDDHAM}), + ("PangoScriptTirhuta", #{const PANGO_SCRIPT_TIRHUTA}), + ("PangoScriptWarangCiti", #{const PANGO_SCRIPT_WARANG_CITI}), + ("PangoScriptAhom", #{const PANGO_SCRIPT_AHOM}), + ("PangoScriptAnatolianHieroglyphs", + #{const PANGO_SCRIPT_ANATOLIAN_HIEROGLYPHS}), + ("PangoScriptHatran", #{const PANGO_SCRIPT_HATRAN}), + ("PangoScriptMultani", #{const PANGO_SCRIPT_MULTANI}), + ("PangoScriptOldHungarian", #{const PANGO_SCRIPT_OLD_HUNGARIAN}), + ("PangoScriptSignwriting", #{const PANGO_SCRIPT_SIGNWRITING}) ] diff --git a/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Internal.hsc b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/ScriptsAndLanguages/PangoScript/Internal.hsc @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Internal ( + -- * FUNCTION + pangoScriptForUnichar, pangoScriptGetSampleLanguage, pangoScriptForText, + -- * ENUM + module Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum, + ) where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Control.Exception +import Data.Traversable +import Data.Bool +import Data.Word +import Data.Int +import Data.Char +import System.IO.Unsafe + +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage.Internal +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T +import qualified Data.Text.Foreign.StringPartial as T + +#include + +pangoScriptForUnichar :: Char -> PangoScript +pangoScriptForUnichar c = unsafePerformIO + $ PangoScript <$> c_pango_script_for_unichar (fromIntegral $ ord c) + +foreign import ccall "pango_script_for_unichar" c_pango_script_for_unichar :: + #{type gunichar} -> IO #{type PangoScript} + +pangoScriptGetSampleLanguage :: PangoScript -> IO (Maybe PangoLanguage) +pangoScriptGetSampleLanguage (PangoScript s) = + nullable Nothing (Just . PangoLanguage_) + <$> c_pango_script_get_sample_language s + +foreign import ccall "pango_script_get_sample_language" + c_pango_script_get_sample_language :: + #{type PangoScript} -> IO (Ptr PangoLanguage) + +pattern NullPtr :: Ptr a +pattern NullPtr <- ((== nullPtr) -> True) where NullPtr = nullPtr + +nullable :: b -> (Ptr a -> b) -> Ptr a -> b +nullable d f = \case NullPtr -> d; p -> f p + +pangoScriptForText :: T.Text -> [(T.Text, PangoScript)] +pangoScriptForText t = unsafePerformIO $ withPangoScriptIter t \i -> do + rss <- pangoScriptIterGetRanges i + for rss \(r, s) -> (, s) <$> T.peekCStringPart r + +data PangoScriptIter + +withPangoScriptIter :: T.Text -> (Ptr PangoScriptIter -> IO a) -> IO a +withPangoScriptIter t f = T.withCStringLen t \(cs, l) -> bracket + (c_pango_script_iter_new cs $ fromIntegral l) c_pango_script_iter_free f + +foreign import ccall "pango_script_iter_new" c_pango_script_iter_new :: + CString -> CInt -> IO (Ptr PangoScriptIter) + +foreign import ccall "pango_script_iter_free" c_pango_script_iter_free :: + Ptr PangoScriptIter -> IO () + +pangoScriptIterGetRanges :: Ptr PangoScriptIter -> IO [(T.CStringPart, PangoScript)] +pangoScriptIterGetRanges i = unsafeInterleaveIO do + rs@(r, _) <- pangoScriptIterGetRange i + (\r' e f -> T.emptyOrCStringPart e f r') r (pure []) + $ pangoScriptIterNext i + >>= bool (pure [rs]) ((rs :) <$> pangoScriptIterGetRanges i) + +pangoScriptIterGetRange :: Ptr PangoScriptIter -> IO (T.CStringPart, PangoScript) +pangoScriptIterGetRange i = alloca \st -> alloca \ed -> alloca \s -> do + c_pango_script_iter_get_range i st ed s + (,) <$> ((,) <$> peek st <*> peek ed) <*> (PangoScript <$> peek s) + +foreign import ccall "pango_script_iter_get_range" c_pango_script_iter_get_range :: + Ptr PangoScriptIter -> Ptr CString -> Ptr CString -> Ptr #{type PangoScript} -> IO () + +pangoScriptIterNext :: Ptr PangoScriptIter -> IO Bool +pangoScriptIterNext i = (<$> c_pango_script_iter_next i) \case + #{const FALSE} -> False; #{const TRUE} -> True + _ -> error "never occur" + +foreign import ccall "pango_script_iter_next" c_pango_script_iter_next :: + Ptr PangoScriptIter -> IO #{type gboolean} diff --git a/src/Graphics/Pango/Basic/TextAttributes.hs b/src/Graphics/Pango/Basic/TextAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/TextAttributes.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIOnS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.TextAttributes ( + -- * TYPE + PangoTextAttrList, PangoTextAttrListPrim, + pangoTextAttrListNew, + pangoTextAttrListFreeze, pangoTextAttrListThaw, + pangoTextAttrListCopy, + + -- * PARSE MARKUP + pangoParseMarkup, pangoMarkupParserNew, pangoMarkupParserFinish, + + -- * INSERT AN ATTRIBUTE TO PANGO TEXT ATTRIBUTE LIST FOR PRIMITIVE MONAD + pangoTextAttrListInsert, pangoTextAttrListInsertBefore, + pangoTextAttrListChange, + + -- * PANGO ATTRIBUTE VALUE + -- ** Class + PangoAttributeValue, PangoAttribute, pangoAttrNew, + + -- ** Instance + -- *** FontDescription + PangoFontDescriptionPrim, + pangoAttrFontDescNew, + + -- *** Strikethrough and StrikethroughColor + Strikethrough(..), + StrikethroughColor(..), + + -- *** PangoUnderline and UnderlineColor + PangoUnderline, pattern PangoUnderlineNone, + pattern PangoUnderlineSingle, pattern PangoUnderlineDouble, + pattern PangoUnderlineLow, pattern PangoUnderlineError, + + UnderlineColor(..), + + -- *** Shape + Shape(..), + + -- *** Scale + Scale(..), + + -- *** Rise + Rise, pattern Rise, + + -- *** LetterSpacing + LetterSpacing, pattern LetterSpacing, + + -- *** Color and Alpha of Foreground and Background + ForegroundColor(..), BackgroundColor(..), + ForegroundAlpha(..), BackgroundAlpha(..), + + -- * PANGO COLOR + PangoColor(..), pangoColorParse, pangoColorToString, + ) where + +import Graphics.Pango.Basic.TextAttributes.Internal +import Graphics.Pango.Basic.Fonts.PangoFontDescription diff --git a/src/Graphics/Pango/Basic/TextAttributes/Internal.hsc b/src/Graphics/Pango/Basic/TextAttributes/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/TextAttributes/Internal.hsc @@ -0,0 +1,650 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.TextAttributes.Internal ( + -- * TYPE + PangoTextAttrList(..), + PangoTextAttrListPrim, + pangoTextAttrListNew, + pangoTextAttrListFreeze, pangoTextAttrListThaw, + pangoTextAttrListCopy, + + -- * PARSE MARKUP + pangoParseMarkup, pangoMarkupParserNew, pangoMarkupParserFinish, + + -- * INSERT AN ATTRIBUTE TO PANGO TEXT ATTRIBUTE LIST FOR PRIMITIVE MONAD + pangoTextAttrListInsert, pangoTextAttrListInsertBefore, + pangoTextAttrListChange, + + -- * PANGO ATTRIBUTE VALUE + -- ** Class + PangoAttribute, PangoAttributeValue, pangoAttrNew, + + -- ** Instance + -- *** FontDescription + pangoAttrFontDescNew, + + -- *** Strikethrough and StrikethroughColor + Strikethrough(..), StrikethroughColor(..), + + -- *** PangoUnderline and UnderlineColor + PangoUnderline, pattern PangoUnderlineNone, + pattern PangoUnderlineSingle, pattern PangoUnderlineDouble, + pattern PangoUnderlineLow, pattern PangoUnderlineError, + UnderlineColor(..), + + -- *** Shape + Shape(..), + + -- *** Scale + Scale(..), + + -- *** Rise + Rise, pattern Rise, + + -- *** LetterSpacing + LetterSpacing, pattern LetterSpacing, + + -- *** Color and Alpha of Foreground and Background + ForegroundColor(..), BackgroundColor(..), + ForegroundAlpha(..), BackgroundAlpha(..), + + -- * PANGO COLOR + PangoColor(..), pangoColorParse, pangoColorToString, + + -- * INTERNAL + PangoAttrList(..), mkPangoAttrList ) where + +import GHC.Stack +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.String.Utf8 +import Foreign.C.String.Misc +import Foreign.C.String.ForeignCStringLen +import Foreign.C.Enum +import Control.Monad.Primitive +import Data.Array +import Data.Bool +import Data.Word +import Data.Int +import Data.Char +import Data.Color +import System.IO.Unsafe + +import System.GLib.ErrorReporting +import System.GLib.SimpleXmlSubsetParser + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +import Graphics.Pango.Basic.GlyphStorage.Internal +import Graphics.Pango.Basic.Fonts.PangoFontDescription +import Graphics.Pango.Basic.Fonts.PangoFontDescription.Type +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoLanguage.Internal +import Graphics.Pango.Basic.VerticalText + +#include + +data PangoTextAttrList = PangoTextAttrList { + pangoTextAttrListText :: ForeignCStringLen, + pangoTextAttrListAttrList :: PangoAttrList + } deriving Show + +data PangoAttrList + = PangoAttrListNull + | PangoAttrList (ForeignPtr PangoAttrList) + deriving Show + +mkPangoAttrList :: Ptr PangoAttrList -> IO PangoAttrList +mkPangoAttrList p + | p == nullPtr = pure PangoAttrListNull + | otherwise = PangoAttrList <$> newForeignPtr p (c_pango_attr_list_unref p) + +foreign import ccall "pango_attr_list_unref" c_pango_attr_list_unref :: + Ptr PangoAttrList -> IO () + +pangoParseMarkup :: T.Text -> Maybe Char -> Either GError (PangoTextAttrList, Maybe Char) +pangoParseMarkup mt am = unsafePerformIO + $ T.withCStringLen mt \(cmt, cmtl) -> alloca \ppal -> alloca \pt -> alloca \pac -> alloca \pge -> do + r <- c_pango_parse_markup cmt (fromIntegral cmtl) (toGunichar am) ppal pt pac pge + pt' <- toCStringLen =<< peek pt + pt'' <- copyToForeignCStringLen pt' + case r of + #{const FALSE} -> Left <$> (mkGError =<< peek pge) + #{const TRUE} -> (Right <$>) $ (,) + <$> (PangoTextAttrList pt'' <$> (mkPangoAttrList =<< peek ppal)) + <*> (fromGunichar <$> peek pac) + _ -> error "never occur" + +toGunichar :: Maybe Char -> #{type gunichar} +toGunichar = \case Nothing -> 0; Just c -> fromIntegral $ ord c + +fromGunichar :: #{type gunichar} -> Maybe Char +fromGunichar = \case 0 -> Nothing; uc -> Just . chr $ fromIntegral uc + +foreign import ccall "pango_parse_markup" c_pango_parse_markup :: + CString -> CInt -> #{type gunichar} -> + Ptr (Ptr PangoAttrList) -> Ptr CString -> Ptr #{type gunichar} -> + Ptr (Ptr GError) -> IO #{type gboolean} + +pangoMarkupParserNew :: PrimMonad m => Maybe Char -> m (GMarkupParseContext (PrimState m)) +pangoMarkupParserNew am = unsafeIOToPrim + $ mkGMarkupParseContext =<< c_pango_markup_parser_new (toGunichar am) + +foreign import ccall "pango_markup_parser_new" c_pango_markup_parser_new :: + #{type gunichar} -> IO (Ptr (GMarkupParseContext s)) + +pangoMarkupParserFinish :: PrimMonad m => GMarkupParseContext (PrimState m) -> + m (Either GError (PangoTextAttrList, Maybe Char)) +pangoMarkupParserFinish (GMarkupParseContext fpc) = unsafeIOToPrim + $ withForeignPtr fpc \ppc -> alloca \ppal -> alloca \pt -> alloca \pac -> alloca \pge -> do + r <- c_pango_markup_parser_finish ppc ppal pt pac pge + pt' <- toCStringLen =<< peek pt + pt'' <- copyToForeignCStringLen pt' + case r of + #{const FALSE} -> Left <$> (mkGError =<< peek pge) + #{const TRUE} -> (Right <$>) $ (,) + <$> (PangoTextAttrList pt'' <$> (mkPangoAttrList =<< peek ppal)) + <*> (fromGunichar <$> peek pac) + _ -> error "never occur" + +foreign import ccall "pango_markup_parser_finish" + c_pango_markup_parser_finish :: + Ptr (GMarkupParseContext s) -> Ptr (Ptr PangoAttrList) -> Ptr CString -> + Ptr #{type gunichar} -> Ptr (Ptr GError) -> IO #{type gboolean} + +newtype PangoAttribute s = PangoAttribute (ForeignPtr (PangoAttribute s)) + deriving Show + +mkPangoAttribute :: Ptr (PangoAttribute s) -> IO (PangoAttribute s) +mkPangoAttribute p = + PangoAttribute <$> newForeignPtr p (c_pango_attribute_destroy p) + +foreign import ccall "pango_attribute_destroy" c_pango_attribute_destroy :: + Ptr (PangoAttribute s) -> IO () + +pangoAttributeSetStartIndex, pangoAttributeSetEndIndex :: PrimMonad m => + PangoAttribute (PrimState m) -> CUInt -> m () +pangoAttributeSetStartIndex (PangoAttribute fa) si = unsafeIOToPrim + $ withForeignPtr fa \pa -> #{poke PangoAttribute, start_index} pa si + +pangoAttributeSetEndIndex (PangoAttribute fa) ei = unsafeIOToPrim + $ withForeignPtr fa \pa -> #{poke PangoAttribute, end_index} pa ei + +class PangoAttributeValue v where + pangoAttrNew :: PrimMonad m => v -> m (PangoAttribute (PrimState m)) + +instance PangoAttributeValue PangoLanguage where + pangoAttrNew = pangoAttrLanguageNew + +pangoAttrLanguageNew :: PrimMonad m => + PangoLanguage -> m (PangoAttribute (PrimState m)) +pangoAttrLanguageNew (PangoLanguage_ l) = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_language_new l + +foreign import ccall "pango_attr_language_new" c_pango_attr_language_new :: + Ptr PangoLanguage -> IO (Ptr (PangoAttribute s)) + +-- data Family = Family String deriving Show + +instance PangoAttributeValue Family where + pangoAttrNew (Family f) = pangoAttrFamilyNew f + +pangoAttrFamilyNew :: PrimMonad m => String -> m (PangoAttribute (PrimState m)) +pangoAttrFamilyNew f = + unsafeIOToPrim $ mkPangoAttribute =<< withCString f c_pango_attr_family_new + +foreign import ccall "pango_attr_family_new" c_pango_attr_family_new :: + CString -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoStyle where pangoAttrNew = pangoAttrStyleNew + +pangoAttrStyleNew :: PrimMonad m => PangoStyle -> m (PangoAttribute (PrimState m)) +pangoAttrStyleNew (PangoStyle s) = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_style_new s + +foreign import ccall "pango_attr_style_new" c_pango_attr_style_new :: + #{type PangoStyle} -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoVariant where + pangoAttrNew = pangoAttrVariantNew + +pangoAttrVariantNew :: PrimMonad m => PangoVariant -> m (PangoAttribute (PrimState m)) +pangoAttrVariantNew (PangoVariant v) = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_variant_new v + +foreign import ccall "pango_attr_variant_new" c_pango_attr_variant_new :: + #{type PangoVariant} -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoStretch where + pangoAttrNew = pangoAttrStretchNew + +pangoAttrStretchNew :: PrimMonad m => PangoStretch -> m (PangoAttribute (PrimState m)) +pangoAttrStretchNew (PangoStretch s) = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_stretch_new s + +foreign import ccall "pango_attr_stretch_new" c_pango_attr_stretch_new :: + #{type PangoStretch} -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoWeight where + pangoAttrNew = pangoAttrWeightNew + +pangoAttrWeightNew :: PrimMonad m => PangoWeight -> m (PangoAttribute (PrimState m)) +pangoAttrWeightNew (PangoWeight w) = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_weight_new w + +foreign import ccall "pango_attr_weight_new" c_pango_attr_weight_new :: + #{type PangoWeight} -> IO (Ptr (PangoAttribute s)) + +-- data Size = Size Double | AbsoluteSize Double deriving Show + +instance PangoAttributeValue Size where + pangoAttrNew = pangoAttrSizeNew + +pangoAttrSizeNew :: PrimMonad m => Size -> m (PangoAttribute (PrimState m)) +pangoAttrSizeNew = unsafeIOToPrim . (mkPangoAttribute =<<) . \case + Size s -> c_pango_attr_size_new . round $ s * #{const PANGO_SCALE} + AbsoluteSize a -> c_pango_attr_size_new_absolute . round $ a * #{const PANGO_SCALE} + +foreign import ccall "pango_attr_size_new" c_pango_attr_size_new :: + CInt -> IO (Ptr (PangoAttribute s)) + +foreign import ccall "pango_attr_size_new_absolute" c_pango_attr_size_new_absolute :: + CInt -> IO (Ptr (PangoAttribute s)) + +pangoAttrFontDescNew :: PrimMonad m => + PangoFontDescriptionPrim (PrimState m) -> m (PangoAttribute (PrimState m)) +pangoAttrFontDescNew (PangoFontDescriptionPrim ffd) = unsafeIOToPrim + $ mkPangoAttribute =<< withForeignPtr ffd c_pango_attr_font_desc_new + +foreign import ccall "pango_attr_font_desc_new" c_pango_attr_font_desc_new :: + Ptr PangoFontDescription -> IO (Ptr (PangoAttribute s)) + +data ForegroundColor d = ForegroundColor (Rgb d) deriving Show + +instance RealFrac d => PangoAttributeValue (ForegroundColor d) where + pangoAttrNew = pangoAttrForegroundNew + +pangoAttrForegroundNew :: (PrimMonad m, RealFrac d) => + ForegroundColor d -> m (PangoAttribute (PrimState m)) +pangoAttrForegroundNew (ForegroundColor (RgbWord16 r g b)) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_foreground_new r g b + +foreign import ccall "pango_attr_foreground_new" c_pango_attr_foreground_new :: + Word16 -> Word16 -> Word16 -> IO (Ptr (PangoAttribute s)) + +data BackgroundColor d = BackgroundColor (Rgb d) deriving Show + +instance RealFrac d => PangoAttributeValue (BackgroundColor d) where + pangoAttrNew = pangoAttrBackgroundNew + +pangoAttrBackgroundNew :: (PrimMonad m, RealFrac d) => + BackgroundColor d -> m (PangoAttribute (PrimState m)) +pangoAttrBackgroundNew (BackgroundColor (RgbWord16 r g b)) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_background_new r g b + +foreign import ccall "pango_attr_background_new" c_pango_attr_background_new :: + Word16 -> Word16 -> Word16 -> IO (Ptr (PangoAttribute s)) + +newtype Strikethrough = Strikethrough Bool deriving Show + +instance PangoAttributeValue Strikethrough where + pangoAttrNew (Strikethrough b) = pangoAttrStrikethroughNew b + +pangoAttrStrikethroughNew :: PrimMonad m => + Bool -> m (PangoAttribute (PrimState m)) +pangoAttrStrikethroughNew b = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_strikethrough_new case b of + False -> #{const FALSE}; True -> #{const TRUE} + +foreign import ccall "pango_attr_strikethrough_new" c_pango_attr_strikethrough_new :: + #{type gboolean} -> IO (Ptr (PangoAttribute s)) + +data StrikethroughColor d = StrikethroughColor (Rgb d) deriving Show + +instance RealFrac d => PangoAttributeValue (StrikethroughColor d) where + pangoAttrNew = pangoAttrStrikethroughColorNew + +pangoAttrStrikethroughColorNew :: (PrimMonad m, RealFrac d) => + StrikethroughColor d -> m (PangoAttribute (PrimState m)) +pangoAttrStrikethroughColorNew (StrikethroughColor (RgbWord16 r g b)) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_strikethrough_color_new r g b + +foreign import ccall "pango_attr_strikethrough_color_new" c_pango_attr_strikethrough_color_new :: + Word16 -> Word16 -> Word16 -> IO (Ptr (PangoAttribute s)) + +enum "PangoUnderline" ''#{type PangoUnderline} [''Show] [ + ("PangoUnderlineNone", #{const PANGO_UNDERLINE_NONE}), + ("PangoUnderlineSingle", #{const PANGO_UNDERLINE_SINGLE}), + ("PangoUnderlineDouble", #{const PANGO_UNDERLINE_DOUBLE}), + ("PangoUnderlineLow", #{const PANGO_UNDERLINE_LOW}), + ("PangoUnderlineError", #{const PANGO_UNDERLINE_ERROR}) ] + +instance PangoAttributeValue PangoUnderline where + pangoAttrNew = pangoAttrUnderlineNew + +pangoAttrUnderlineNew :: PrimMonad m => + PangoUnderline -> m (PangoAttribute (PrimState m)) +pangoAttrUnderlineNew (PangoUnderline ul) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_underline_new ul + +foreign import ccall "pango_attr_underline_new" c_pango_attr_underline_new :: + #{type PangoUnderline} -> IO (Ptr (PangoAttribute s)) + +data UnderlineColor d = UnderlineColor (Rgb d) deriving Show + +instance RealFrac d => PangoAttributeValue (UnderlineColor d) where + pangoAttrNew = pangoAttrUnderlineColorNew + +pangoAttrUnderlineColorNew :: (PrimMonad m, RealFrac d) => + UnderlineColor d -> m (PangoAttribute (PrimState m)) +pangoAttrUnderlineColorNew (UnderlineColor (RgbWord16 r g b)) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_underline_color_new r g b + +foreign import ccall "pango_attr_underline_color_new" c_pango_attr_underline_color_new :: + Word16 -> Word16 -> Word16 -> IO (Ptr (PangoAttribute s)) + +data Shape = Shape PangoRectangleFixed PangoRectangleFixed deriving Show + +instance PangoAttributeValue Shape where + pangoAttrNew (Shape ir lr) = pangoAttrShapeNew ir lr + +pangoAttrShapeNew :: PrimMonad m => + PangoRectangleFixed -> PangoRectangleFixed -> m (PangoAttribute (PrimState m)) +pangoAttrShapeNew (PangoRectangleFixed_ fir) (PangoRectangleFixed_ flr) = unsafeIOToPrim + $ withForeignPtr fir \pir -> withForeignPtr flr \plr -> + mkPangoAttribute =<< c_pango_attr_shape_new pir plr + +foreign import ccall "pango_attr_shape_new" c_pango_attr_shape_new :: + Ptr PangoRectangleFixed -> Ptr PangoRectangleFixed -> IO (Ptr (PangoAttribute s)) + +newtype Scale = Scale CDouble deriving Show + +instance PangoAttributeValue Scale where + pangoAttrNew (Scale s) = pangoAttrScaleNew s + +pangoAttrScaleNew :: PrimMonad m => CDouble -> m (PangoAttribute (PrimState m)) +pangoAttrScaleNew s = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_scale_new s + +foreign import ccall "pango_attr_scale_new" c_pango_attr_scale_new :: + CDouble -> IO (Ptr (PangoAttribute s)) + +newtype Rise = RiseInPangoUnit { getRiseInPangoUnit :: CInt } deriving Show + +pattern Rise :: PangoFixed -> Rise +pattern Rise r <- (fromCInt . getRiseInPangoUnit -> r) where + Rise = RiseInPangoUnit . toCInt + +instance PangoAttributeValue Rise where + pangoAttrNew = pangoAttrRiseNew . getRiseInPangoUnit + +pangoAttrRiseNew :: PrimMonad m => CInt -> m (PangoAttribute (PrimState m)) +pangoAttrRiseNew r = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_rise_new r + +foreign import ccall "pango_attr_rise_new" c_pango_attr_rise_new :: + CInt -> IO (Ptr (PangoAttribute s)) + +newtype LetterSpacing = + LetterSpacingInPangoUnit { getLetterSpacingInPangoUnit :: CInt } + deriving Show + +instance PangoAttributeValue LetterSpacing where + pangoAttrNew = pangoAttrLetterSpacingNew . getLetterSpacingInPangoUnit + +pattern LetterSpacing :: PangoFixed -> LetterSpacing +pattern LetterSpacing s <- + (fromCInt . getLetterSpacingInPangoUnit -> s) where + LetterSpacing = LetterSpacingInPangoUnit . toCInt + +pangoAttrLetterSpacingNew :: + PrimMonad m => CInt -> m (PangoAttribute (PrimState m)) +pangoAttrLetterSpacingNew s = + unsafeIOToPrim $ mkPangoAttribute =<< c_pango_attr_letter_spacing_new s + +foreign import ccall "pango_attr_letter_spacing_new" + c_pango_attr_letter_spacing_new :: + CInt -> IO (Ptr (PangoAttribute s)) + +newtype Fallback = Fallback Bool deriving Show + +instance PangoAttributeValue Fallback where + pangoAttrNew (Fallback b) = pangoAttrFallbackNew b + +pangoAttrFallbackNew :: PrimMonad m => Bool -> m (PangoAttribute (PrimState m)) +pangoAttrFallbackNew b = unsafeIOToPrim $ mkPangoAttribute + =<< c_pango_attr_fallback_new (bool #{const FALSE} #{const TRUE} b) + +foreign import ccall "pango_attr_fallback_new" c_pango_attr_fallback_new :: + #{type gboolean} -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoGravity where + pangoAttrNew = pangoAttrGravityNew + +pangoAttrGravityNew :: + PrimMonad m => PangoGravity -> m (PangoAttribute (PrimState m)) +pangoAttrGravityNew (PangoGravity g) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_gravity_new g + +foreign import ccall "pango_attr_gravity_new" c_pango_attr_gravity_new :: + #{type PangoGravity} -> IO (Ptr (PangoAttribute s)) + +instance PangoAttributeValue PangoGravityHint where + pangoAttrNew = pangoAttrGravityHintNew + +pangoAttrGravityHintNew :: + PrimMonad m => PangoGravityHint -> m (PangoAttribute (PrimState m)) +pangoAttrGravityHintNew (PangoGravityHint gh) = unsafeIOToPrim + $ mkPangoAttribute =<< c_pango_attr_gravity_hint_new gh + +foreign import ccall "pango_attr_gravity_hint_new" + c_pango_attr_gravity_hint_new :: + #{type PangoGravityHint} -> IO (Ptr (PangoAttribute s)) + +newtype FontFeatures = FontFeatures { getFontFeatures :: String } deriving Show + +instance PangoAttributeValue FontFeatures where + pangoAttrNew = pangoAttrFontFeaturesNew . getFontFeatures + +pangoAttrFontFeaturesNew :: + PrimMonad m => String -> m (PangoAttribute (PrimState m)) +pangoAttrFontFeaturesNew f = unsafeIOToPrim + $ mkPangoAttribute =<< withCString f c_pango_attr_font_features_new + +foreign import ccall "pango_attr_font_features_new" + c_pango_attr_font_features_new :: + CString -> IO (Ptr (PangoAttribute s)) + +newtype ForegroundAlpha d = ForegroundAlpha { getForegroundAlpha :: Alpha d } + deriving Show + +instance RealFrac d => PangoAttributeValue (ForegroundAlpha d) where + pangoAttrNew = pangoAttrForegroundAlphaNew . getForegroundAlpha + +newtype BackgroundAlpha d = BackgroundAlpha { getBackgroundAlpha :: Alpha d } + deriving Show + +instance RealFrac d => PangoAttributeValue (BackgroundAlpha d) where + pangoAttrNew = pangoAttrBackgroundAlphaNew . getBackgroundAlpha + +pangoAttrForegroundAlphaNew, pangoAttrBackgroundAlphaNew :: + (PrimMonad m, RealFrac d) => Alpha d -> m (PangoAttribute (PrimState m)) +pangoAttrForegroundAlphaNew (AlphaWord16 a) = unsafeIOToPrim . (mkPangoAttribute =<<) + $ c_pango_attr_foreground_alpha_new case a of 0 -> 1; _ -> a + +pangoAttrBackgroundAlphaNew (AlphaWord16 a) = unsafeIOToPrim . (mkPangoAttribute =<<) + $ c_pango_attr_background_alpha_new case a of 0 -> 1; _ -> a + +foreign import ccall "pango_attr_foreground_alpha_new" + c_pango_attr_foreground_alpha_new :: + Word16 -> IO (Ptr (PangoAttribute s)) + +foreign import ccall "pango_attr_background_alpha_new" + c_pango_attr_background_alpha_new :: + Word16 -> IO (Ptr (PangoAttribute s)) + +data PangoColor = PangoColor { + pangoColorRed :: Word16, + pangoColorGreen :: Word16, + pangoColorBlue :: Word16 } deriving Show + +instance Storable PangoColor where + sizeOf _ = #{size PangoColor} + alignment _ = #{alignment PangoColor} + peek p = PangoColor + <$> #{peek PangoColor, red} p + <*> #{peek PangoColor, green} p + <*> #{peek PangoColor, blue} p + poke p (PangoColor r g b) = do + #{poke PangoColor, red} p r + #{poke PangoColor, green} p g + #{poke PangoColor, blue} p b + +pangoColorParse :: String -> Maybe PangoColor +pangoColorParse s = unsafePerformIO $ withCString s \cs -> alloca \pc -> + c_pango_color_parse pc cs >>= \case + #{const FALSE} -> pure Nothing + #{const TRUE} -> Just <$> peek pc + _ -> error "never occur" + +foreign import ccall "pango_color_parse" c_pango_color_parse :: + Ptr PangoColor -> CString -> IO #{type gboolean} + +pangoColorToString :: PangoColor -> String +pangoColorToString c = unsafePerformIO $ peekCString =<< alloca \cc -> + poke cc c >> c_pango_color_to_string cc + +foreign import ccall "pango_color_to_string" c_pango_color_to_string :: + Ptr PangoColor -> IO CString + +pangoTextAttrListFreeze :: PrimMonad m => + PangoTextAttrListPrim (PrimState m) -> m PangoTextAttrList +pangoTextAttrListFreeze (PangoTextAttrListPrim csl _ al) = + PangoTextAttrList csl <$> pangoAttrListFreeze al + +pangoTextAttrListThaw :: PrimMonad m => + PangoTextAttrList -> m (Maybe (PangoTextAttrListPrim (PrimState m))) +pangoTextAttrListThaw (PangoTextAttrList csl al) = unsafeIOToPrim do + ids <- ((\is -> listArray (0, length is - 1) is) . (fromIntegral <$>) <$> withForeignCStringLen csl byteIndices) + mal <- pangoAttrListThawIo al + pure $ PangoTextAttrListPrim csl ids <$> mal + +data PangoTextAttrListPrim s = PangoTextAttrListPrim { + pangoTextAttrListPrimText :: ForeignCStringLen, + pangoTextAttrListPrimUtf8Indices :: Array Int CUInt, + pangoTextAttrListPrimAttrList :: PangoAttrListPrim s + } deriving Show + +pangoTextAttrListNew :: + PrimMonad m => T.Text -> m (PangoTextAttrListPrim (PrimState m)) +pangoTextAttrListNew t = unsafeIOToPrim $ T.withCStringLen t \csl -> do + csl' <- copyToForeignCStringLen csl + PangoTextAttrListPrim csl' + <$> ((\is -> listArray (0, length is - 1) is) . (fromIntegral <$>) + <$> byteIndices csl) + <*> (mkPangoAttrListPrim =<< c_pango_attr_list_new) + +pangoTextAttrListCopy :: PrimMonad m => + PangoTextAttrListPrim (PrimState m) -> m (PangoTextAttrListPrim (PrimState m)) +pangoTextAttrListCopy (PangoTextAttrListPrim t is al) = + PangoTextAttrListPrim t is <$> pangoAttrListCopy al + +toUtf8Index :: HasCallStack => Array Int CUInt -> Int -> CUInt +toUtf8Index t i | i < mn = 0 | i > mx = maxBound | otherwise = t ! i + where (mn, mx) = bounds t + +pangoTextAttrListInsert, pangoTextAttrListInsertBefore, + pangoTextAttrListChange :: PrimMonad m => + PangoTextAttrListPrim (PrimState m) -> + PangoAttribute (PrimState m) -> Int -> Int -> m () +pangoTextAttrListInsert = pangoTextAttrListInsertGen pangoAttrListInsert + +pangoTextAttrListInsertBefore = + pangoTextAttrListInsertGen pangoAttrListInsertBefore + +pangoTextAttrListChange = pangoTextAttrListInsertGen pangoAttrListChange + +pangoTextAttrListInsertGen :: PrimMonad m => + (PangoAttrListPrim (PrimState m) -> + PangoAttribute (PrimState m) -> m ()) -> + PangoTextAttrListPrim (PrimState m) -> PangoAttribute (PrimState m) -> + Int -> Int -> m () +pangoTextAttrListInsertGen pali (PangoTextAttrListPrim _ t al) a s e = do + pangoAttributeSetStartIndex a (toUtf8Index t s) + pangoAttributeSetEndIndex a (toUtf8Index t e) + pali al a + + +newtype PangoAttrListPrim s = PangoAttrListPrim (ForeignPtr (PangoAttrListPrim s)) deriving Show + +mkPangoAttrListPrim :: Ptr (PangoAttrListPrim s) -> IO (PangoAttrListPrim s) +mkPangoAttrListPrim p = PangoAttrListPrim <$> newForeignPtr p (c_pango_attr_list_prim_unref p) + +foreign import ccall "pango_attr_list_unref" c_pango_attr_list_prim_unref :: + Ptr (PangoAttrListPrim s) -> IO () + +foreign import ccall "pango_attr_list_new" c_pango_attr_list_new :: + IO (Ptr (PangoAttrListPrim s)) + +pangoAttrListCopy :: PrimMonad m => + PangoAttrListPrim (PrimState m) -> m (PangoAttrListPrim (PrimState m)) +pangoAttrListCopy (PangoAttrListPrim fal) = unsafeIOToPrim + $ mkPangoAttrListPrim =<< withForeignPtr fal c_pango_attr_list_copy + +foreign import ccall "pango_attr_list_copy" c_pango_attr_list_copy :: + Ptr (PangoAttrListPrim s) -> IO (Ptr (PangoAttrListPrim s)) + +pangoAttrListFreeze :: + PrimMonad m => PangoAttrListPrim (PrimState m) -> m PangoAttrList +pangoAttrListFreeze (PangoAttrListPrim fal) = unsafeIOToPrim + $ mkPangoAttrList =<< withForeignPtr fal c_pango_attr_list_freeze + +foreign import ccall "pango_attr_list_copy" c_pango_attr_list_freeze :: + Ptr (PangoAttrListPrim s) -> IO (Ptr PangoAttrList) + +pangoAttrListThawIo :: PangoAttrList -> IO (Maybe (PangoAttrListPrim s)) +pangoAttrListThawIo = \case + PangoAttrListNull -> pure Nothing + PangoAttrList fal -> (Just <$>) . mkPangoAttrListPrim + =<< withForeignPtr fal c_pango_attr_list_thaw + +foreign import ccall "pango_attr_list_copy" c_pango_attr_list_thaw :: + Ptr PangoAttrList -> IO (Ptr (PangoAttrListPrim s)) + +pangoAttrListInsert, pangoAttrListInsertBefore, pangoAttrListChange :: + PrimMonad m => + PangoAttrListPrim (PrimState m) -> PangoAttribute (PrimState m) -> m () +pangoAttrListInsert (PangoAttrListPrim fal) (PangoAttribute fa) = unsafeIOToPrim + $ withForeignPtr fal \pal -> withForeignPtr fa \pa -> do + pa' <- c_pango_attribute_copy pa + c_pango_attr_list_insert pal pa' + +pangoAttrListInsertBefore (PangoAttrListPrim fal) (PangoAttribute fa) = unsafeIOToPrim + $ withForeignPtr fal \pal -> withForeignPtr fa \pa -> do + pa' <- c_pango_attribute_copy pa + c_pango_attr_list_insert_before pal pa' + +pangoAttrListChange (PangoAttrListPrim fal) (PangoAttribute fa) = unsafeIOToPrim + $ withForeignPtr fal \pal -> withForeignPtr fa \pa -> do + pa' <- c_pango_attribute_copy pa + c_pango_attr_list_change pal pa' + +foreign import ccall "pango_attr_list_insert" c_pango_attr_list_insert :: + Ptr (PangoAttrListPrim s) -> Ptr (PangoAttribute s) -> IO () + +foreign import ccall "pango_attr_list_insert_before" c_pango_attr_list_insert_before :: + Ptr (PangoAttrListPrim s) -> Ptr (PangoAttribute s) -> IO () + +foreign import ccall "pango_attr_list_change" c_pango_attr_list_change :: + Ptr (PangoAttrListPrim s) -> Ptr (PangoAttribute s) -> IO () + +foreign import ccall "pango_attribute_copy" c_pango_attribute_copy :: + Ptr (PangoAttribute s) -> IO (Ptr (PangoAttribute s)) diff --git a/src/Graphics/Pango/Basic/VerticalText.hsc b/src/Graphics/Pango/Basic/VerticalText.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Basic/VerticalText.hsc @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Basic.VerticalText ( + -- * ENUM + -- ** PangoGravity + PangoGravity(..), + pattern PangoGravitySouth, + pattern PangoGravityEast, + pattern PangoGravityNorth, + pattern PangoGravityWest, + pattern PangoGravityAuto, + + -- ** PangoGravityHint + PangoGravityHint(..), + pattern PangoGravityHintNatural, + pattern PangoGravityHintStrong, + pattern PangoGravityHintLine, + + -- * FUNCTION + pangoGravityGetForMatrix, + pangoGravityGetForScript, + pangoGravityGetForScriptAndWidth, + pangoGravityToRotation + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.Types +import Foreign.C.Enum +import Data.Bool +import Data.Word +import Data.Int +import Data.Angle +import System.IO.Unsafe +import Graphics.Pango.Basic.GlyphStorage.PangoMatrix.Internal +import Graphics.Pango.Basic.ScriptsAndLanguages.PangoScript.Enum + +#include + +enum "PangoGravity" ''#{type PangoGravity} [''Show] [ + ("PangoGravitySouth", #{const PANGO_GRAVITY_SOUTH}), + ("PangoGravityEast", #{const PANGO_GRAVITY_EAST}), + ("PangoGravityNorth", #{const PANGO_GRAVITY_NORTH}), + ("PangoGravityWest", #{const PANGO_GRAVITY_WEST}), + ("PangoGravityAuto", #{const PANGO_GRAVITY_AUTO}) ] + +enum "PangoGravityHint" ''#{type PangoGravityHint} [''Show] [ + ("PangoGravityHintNatural", #{const PANGO_GRAVITY_HINT_NATURAL}), + ("PangoGravityHintStrong", #{const PANGO_GRAVITY_HINT_STRONG}), + ("PangoGravityHintLine", #{const PANGO_GRAVITY_HINT_LINE}) ] + +pangoGravityGetForMatrix :: PangoMatrix -> PangoGravity +pangoGravityGetForMatrix (PangoMatrix_ fm) = unsafePerformIO + $ PangoGravity <$> withForeignPtr fm c_pango_gravity_get_for_matrix + +foreign import ccall "pango_gravity_get_for_matrix" + c_pango_gravity_get_for_matrix :: + Ptr PangoMatrix -> IO #{type PangoGravity} + +pangoGravityGetForScript :: + PangoScript -> PangoGravity -> PangoGravityHint -> PangoGravity +pangoGravityGetForScript (PangoScript s) (PangoGravity b) (PangoGravityHint h) = + unsafePerformIO $ PangoGravity <$> c_pango_gravity_get_for_script s b h + +foreign import ccall "pango_gravity_get_for_script" + c_pango_gravity_get_for_script :: + #{type PangoScript} -> #{type PangoGravity} -> + #{type PangoGravityHint} -> IO #{type PangoGravity} + +pangoGravityGetForScriptAndWidth :: + PangoScript -> Bool -> PangoGravity -> PangoGravityHint -> PangoGravity +pangoGravityGetForScriptAndWidth + (PangoScript s) w (PangoGravity b) (PangoGravityHint h) = + unsafePerformIO $ PangoGravity <$> + c_pango_gravity_get_for_script_and_width + s (bool #{const FALSE} #{const TRUE} w) b h + +foreign import ccall "pango_gravity_get_for_script_and_width" + c_pango_gravity_get_for_script_and_width :: + #{type PangoScript} -> #{type gboolean} -> #{type PangoGravity} -> + #{type PangoGravityHint} -> IO #{type PangoGravity} + +pangoGravityToRotation :: PangoGravity -> Angle CDouble +pangoGravityToRotation (PangoGravity g) = + unsafePerformIO $ Radian <$> c_pango_gravity_to_rotation g + +foreign import ccall "pango_gravity_to_rotation" c_pango_gravity_to_rotation :: + #{type PangoGravity} -> IO CDouble diff --git a/src/Graphics/Pango/LowLevel/Contexts.hs b/src/Graphics/Pango/LowLevel/Contexts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/LowLevel/Contexts.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.LowLevel.Contexts ( + PangoContext, PangoContextSetting, pangoContextSet, pangoContextGet, + BaseGravity(..) ) where + +import Graphics.Pango.LowLevel.Contexts.Internal diff --git a/src/Graphics/Pango/LowLevel/Contexts/Internal.hsc b/src/Graphics/Pango/LowLevel/Contexts/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/LowLevel/Contexts/Internal.hsc @@ -0,0 +1,91 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.LowLevel.Contexts.Internal ( + PangoContext(..), mkPangoContext, + PangoContextSetting(..), BaseGravity(..) ) where + +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Data.Word +import System.GLib.GObject + +import Graphics.Pango.Basic.Fonts.PangoFontDescription.Type + +import Graphics.Pango.Basic.GlyphStorage.PangoMatrix.Internal +import Graphics.Pango.Basic.VerticalText + +#include + +newtype PangoContext = PangoContext (ForeignPtr PangoContext) deriving Show + +mkPangoContext :: Ptr PangoContext -> IO PangoContext +mkPangoContext p = PangoContext <$> newForeignPtr p (c_g_object_unref p) + +class PangoContextSetting s where + pangoContextSet :: PangoContext -> s -> IO () + pangoContextGet :: PangoContext -> IO s + +newtype BaseGravity = BaseGravity { getBaseGravity :: PangoGravity } deriving Show + +instance PangoContextSetting BaseGravity where + pangoContextSet c = pangoContextSetBaseGravity c . getBaseGravity + pangoContextGet c = BaseGravity <$> pangoContextGetBaseGravity c + +pangoContextSetBaseGravity :: PangoContext -> PangoGravity -> IO () +pangoContextSetBaseGravity (PangoContext fc) (PangoGravity g) = + withForeignPtr fc \pc -> c_pango_context_set_base_gravity pc g + +pangoContextGetBaseGravity :: PangoContext -> IO PangoGravity +pangoContextGetBaseGravity (PangoContext fc) = + PangoGravity <$> withForeignPtr fc c_pango_context_get_base_gravity + +foreign import ccall "pango_context_set_base_gravity" + c_pango_context_set_base_gravity :: + Ptr PangoContext -> #{type PangoGravity} -> IO () + +foreign import ccall "pango_context_get_base_gravity" + c_pango_context_get_base_gravity :: + Ptr PangoContext -> IO #{type PangoGravity} + +instance PangoContextSetting PangoFontDescription where + pangoContextSet = pangoContextSetFontDescription + pangoContextGet = pangoContextGetFontDescription + +pangoContextSetFontDescription :: PangoContext -> PangoFontDescription -> IO () +pangoContextSetFontDescription (PangoContext fc) (PangoFontDescription_ ffd) = + withForeignPtr fc \pc -> withForeignPtr ffd \pfd -> + c_pango_context_set_font_description pc pfd + +pangoContextGetFontDescription :: PangoContext -> IO PangoFontDescription +pangoContextGetFontDescription (PangoContext fc) = mkPangoFontDescription + =<< withForeignPtr fc c_pango_context_get_font_description + +foreign import ccall "pango_context_set_font_description" + c_pango_context_set_font_description :: + Ptr PangoContext -> Ptr PangoFontDescription -> IO () + +foreign import ccall "pango_context_get_font_description" + c_pango_context_get_font_description :: + Ptr PangoContext -> IO (Ptr PangoFontDescription) + +instance PangoContextSetting PangoMatrixNullable where + pangoContextSet = pangoContextSetMatrix + pangoContextGet = pangoContextGetMatrix + +pangoContextGetMatrix :: PangoContext -> IO PangoMatrixNullable +pangoContextGetMatrix (PangoContext fc) = mkPangoMatrixNullable0 =<< + withForeignPtr fc c_pango_context_get_matrix + +foreign import ccall "pango_context_get_matrix" c_pango_context_get_matrix :: + Ptr PangoContext -> IO (Ptr PangoMatrix) + +pangoContextSetMatrix :: PangoContext -> PangoMatrixNullable -> IO () +pangoContextSetMatrix (PangoContext fc) m = withForeignPtr fc \pc -> case m of + PangoMatrixNull -> c_pango_context_set_matrix pc NullPtr + PangoMatrixNotNull fm -> withForeignPtr fm $ c_pango_context_set_matrix pc + +foreign import ccall "pango_context_set_matrix" c_pango_context_set_matrix :: + Ptr PangoContext -> Ptr PangoMatrix -> IO () diff --git a/src/Graphics/Pango/LowLevel/TabStops.hs b/src/Graphics/Pango/LowLevel/TabStops.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/LowLevel/TabStops.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.LowLevel.TabStops ( + -- * PANGO TAB ARRAY + PangoTabArray, pangoTabArrayThaw, + pangoTabArrayGetTab, pangoTabArrayGetTabs, + + -- * PANGO TAB ARRAY NULLABLE + PangoTabArrayNullable, + pangoTabArrayFromNullable, pangoTabArrayToNullable, + + -- * PANGO TAB ARRAY FIXED + PangoTabArrayFixed, pangoTabArrayFixedFreeze, + pangoTabArrayFixedNew, pangoTabArrayFixedSetTab, + + -- * PANGO TAB ARRAY INT + PangoTabArrayInt, pangoTabArrayIntFreeze, + pangoTabArrayIntNew, pangoTabArrayIntSetTab, + ) where + +import Graphics.Pango.LowLevel.TabStops.Internal diff --git a/src/Graphics/Pango/LowLevel/TabStops/Internal.hsc b/src/Graphics/Pango/LowLevel/TabStops/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/LowLevel/TabStops/Internal.hsc @@ -0,0 +1,241 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.LowLevel.TabStops.Internal ( + -- * PANGO TAB ARRAY + PangoTabArray(..), makePangoTabArray, pangoTabArrayThaw, + pangoTabArrayGetTab, pangoTabArrayGetTabs, + + -- * PANGO TAB ARRAY NULLABLE + PangoTabArrayNullable(..), makePangoTabArrayNullable, + pangoTabArrayFromNullable, pangoTabArrayToNullable, + + -- * PANGO TAB ARRAY FIXED + PangoTabArrayFixed, pangoTabArrayFixedFreeze, + pangoTabArrayFixedNew, pangoTabArrayFixedSetTab, + + -- * PANGO TAB ARRAY INT + PangoTabArrayInt, pangoTabArrayIntFreeze, + pangoTabArrayIntNew, pangoTabArrayIntSetTab, + ) where + +import Foreign.Ptr +import Foreign.Ptr.Misc +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.Enum +import Control.Arrow +import Control.Monad.Primitive +import Data.Foldable +import Data.Word +import Data.Int +import System.IO.Unsafe + +import Graphics.Pango.Basic.GlyphStorage + +#include + +newtype PangoTabArray = PangoTabArray (ForeignPtr PangoTabArray) deriving Show + +makePangoTabArray :: Ptr PangoTabArray -> IO PangoTabArray +makePangoTabArray = \case + NullPtr -> error "bad" + p -> PangoTabArray <$> newForeignPtr p (c_pango_tab_array_free p) + +data PangoTabArrayNullable + = PangoTabArrayNull + | PangoTabArrayNotNull (ForeignPtr PangoTabArray) + deriving Show + +makePangoTabArrayNullable :: Ptr PangoTabArray -> IO PangoTabArrayNullable +makePangoTabArrayNullable = \case + NullPtr -> pure PangoTabArrayNull + p -> PangoTabArrayNotNull <$> newForeignPtr p (c_pango_tab_array_free p) + +pangoTabArrayFromNullable :: PangoTabArrayNullable -> Maybe PangoTabArray +pangoTabArrayFromNullable = \case + PangoTabArrayNull -> Nothing + PangoTabArrayNotNull fta -> Just $ PangoTabArray fta + +pangoTabArrayToNullable :: Maybe PangoTabArray -> PangoTabArrayNullable +pangoTabArrayToNullable = \case + Nothing -> PangoTabArrayNull + Just (PangoTabArray fta) -> PangoTabArrayNotNull fta + +newtype PangoTabArrayFixed s = + PangoTabArrayFixed (ForeignPtr PangoTabArray) deriving Show + +mkPangoTabArrayFixed :: + Ptr PangoTabArray -> IO (PangoTabArrayFixed s) +mkPangoTabArrayFixed p = + PangoTabArrayFixed <$> newForeignPtr p (c_pango_tab_array_free p) + +newtype PangoTabArrayInt s = + PangoTabArrayInt (ForeignPtr PangoTabArray) deriving Show + +mkPangoTabArrayInt :: + Ptr PangoTabArray -> IO (PangoTabArrayInt s) +mkPangoTabArrayInt p = + PangoTabArrayInt <$> newForeignPtr p (c_pango_tab_array_free p) + +foreign import ccall "pango_tab_array_free" c_pango_tab_array_free :: + Ptr PangoTabArray -> IO () + +pangoTabArrayFixedNew :: + PrimMonad m => m (PangoTabArrayFixed (PrimState m)) +pangoTabArrayFixedNew = unsafeIOToPrim + $ mkPangoTabArrayFixed =<< c_pango_tab_array_new 1 #{const FALSE} + +pangoTabArrayIntNew :: + PrimMonad m => m (PangoTabArrayInt (PrimState m)) +pangoTabArrayIntNew = unsafeIOToPrim + $ mkPangoTabArrayInt =<< c_pango_tab_array_new 1 #{const TRUE} + +foreign import ccall "pango_tab_array_new" c_pango_tab_array_new :: + CInt -> #{type gboolean} -> IO (Ptr PangoTabArray) + +pangoTabArrayFixedSetTab :: PrimMonad m => + PangoTabArrayFixed (PrimState m) -> CInt -> PangoFixed -> m () +pangoTabArrayFixedSetTab (PangoTabArrayFixed fta) idx x = unsafeIOToPrim + $ withForeignPtr fta \pta -> do + sz <- c_pango_tab_array_get_size_prim pta + if idx < sz + then c_pango_tab_array_set_tab pta idx #{const PANGO_TAB_LEFT} $ toCInt x + else do lst <- tempPangoTabArrayGetTab pta (sz - 1) + let Just (sz', tss) = calculateFixed sz idx (fromCInt lst) x + c_pango_tab_array_resize pta sz' + for_ (zip [sz .. sz' - 1] tss) \(i, xx) -> + c_pango_tab_array_set_tab pta i #{const PANGO_TAB_LEFT} + . round $ xx * #{const PANGO_SCALE} + +foreign import ccall "pango_tab_array_set_tab" c_pango_tab_array_set_tab :: + Ptr PangoTabArray -> CInt -> #{type PangoTabAlign} -> CInt -> IO () + +tempPangoTabArrayGetTab :: Ptr PangoTabArray -> CInt -> IO CInt +tempPangoTabArrayGetTab pta idx = alloca \px -> do + c_pango_tab_array_get_tab_prim pta idx nullPtr px + peek px + +foreign import ccall "pango_tab_array_get_tab" c_pango_tab_array_get_tab_prim :: + Ptr PangoTabArray -> CInt -> Ptr #{type PangoTabAlign} -> Ptr CInt -> IO () + +calculateFixed :: CInt -> CInt -> PangoFixed -> PangoFixed -> Maybe (CInt, [PangoFixed]) +calculateFixed sz idx lst x + | idx < sz = Nothing + | otherwise = Just (sz', take (fromIntegral $ sz' - sz) [lst + dx, lst + 2 * dx ..]) + where + sz' = nextPow2 $ idx + 1 + dx = (x - lst) / fromIntegral (idx - sz + 1) + +calculateDouble :: CInt -> CInt -> Double -> Double -> Maybe (CInt, [Double]) +calculateDouble sz idx lst x + | idx < sz = Nothing + | otherwise = Just (sz', take (fromIntegral $ sz' - sz) [lst + dx, lst + 2 * dx ..]) + where + sz' = nextPow2 $ idx + 1 + dx = (x - lst) / fromIntegral (idx - sz + 1) + +nextPow2 :: (Ord n, Num n) => n -> n +nextPow2 k = head . dropWhile (< k) $ (2 ^) <$> [0 :: Int ..] + +pangoTabArrayIntSetTab :: PrimMonad m => + PangoTabArrayInt (PrimState m) -> CInt -> CInt -> m () +pangoTabArrayIntSetTab (PangoTabArrayInt fta) idx x = unsafeIOToPrim + $ withForeignPtr fta \pta -> do + sz <- c_pango_tab_array_get_size_prim pta + if idx < sz + then c_pango_tab_array_set_tab pta idx #{const PANGO_TAB_LEFT} x + else do lst <- tempPangoTabArrayGetTab pta (sz - 1) + let Just (sz', tss) = calculateCInt sz idx lst x + c_pango_tab_array_resize pta sz' + for_ (zip [sz .. sz' - 1] tss) \(i, xx) -> + c_pango_tab_array_set_tab pta i #{const PANGO_TAB_LEFT} xx + +calculateCInt :: CInt -> CInt -> CInt -> CInt -> Maybe (CInt, [CInt]) +calculateCInt sz idx lst x = + second (round <$>) <$> calculateDouble sz idx (fromIntegral lst) (fromIntegral x) + +foreign import ccall "pango_tab_array_get_size" c_pango_tab_array_get_size_prim :: + Ptr PangoTabArray -> IO CInt + +foreign import ccall "pango_tab_array_get_size" c_pango_tab_array_get_size :: + Ptr PangoTabArray -> IO CInt + +foreign import ccall "pango_tab_array_resize" c_pango_tab_array_resize :: + Ptr PangoTabArray -> CInt -> IO () + +enum "PangoTabAlign" ''#{type PangoTabAlign} [''Show] [ + ("PangoTabLeft", #{const PANGO_TAB_LEFT}) ] + +pangoTabArrayGetTab :: PangoTabArray -> CInt -> Maybe (Either Double CInt) +pangoTabArrayGetTab (PangoTabArray fta) idx = unsafePerformIO + $ withForeignPtr fta \pta -> alloca \loc -> do + px <- c_pango_tab_array_get_positions_in_pixels pta + sz <- c_pango_tab_array_get_size pta + if 0 <= idx && idx < sz then Just <$> do + c_pango_tab_array_get_tab pta idx nullPtr loc + (<$> peek loc) case px of + #{const FALSE} -> + Left . (/ #{const PANGO_SCALE}) . fromIntegral + #{const TRUE} -> Right + _ -> error "never occur" + else pure Nothing + +foreign import ccall "pango_tab_array_get_tab" c_pango_tab_array_get_tab :: + Ptr PangoTabArray -> CInt -> Ptr #{type PangoTabAlign} -> Ptr CInt -> IO () + +pangoTabArrayGetTabs :: PangoTabArray -> Either [Double] [CInt] +pangoTabArrayGetTabs (PangoTabArray fta) = unsafePerformIO + $ withForeignPtr fta \pta -> alloca \locs -> do + n <- c_pango_tab_array_get_size pta + px <- c_pango_tab_array_get_positions_in_pixels pta + c_pango_tab_array_get_tabs pta nullPtr locs + (<$> (peekArrayAndFree n =<< peek locs)) case px of + #{const FALSE} -> Left + . ((/ #{const PANGO_SCALE}) . fromIntegral <$>) + #{const TRUE} -> Right + _ -> error "never occur" + +foreign import ccall "pango_tab_array_get_tabs" c_pango_tab_array_get_tabs :: + Ptr PangoTabArray -> Ptr (Ptr #type PangoTabAlign) -> Ptr (Ptr CInt) -> IO () + +peekArrayAndFree :: Storable a => CInt -> Ptr a -> IO [a] +peekArrayAndFree n p = peekArray (fromIntegral n) p <* free p + +foreign import ccall "pango_tab_array_get_positions_in_pixels" + c_pango_tab_array_get_positions_in_pixels :: + Ptr PangoTabArray -> IO #type gboolean + +pangoTabArrayIntFreeze :: PrimMonad m => + PangoTabArrayInt (PrimState m) -> m PangoTabArray +pangoTabArrayIntFreeze (PangoTabArrayInt fta) = + unsafeIOToPrim $ withForeignPtr fta \pta -> + makePangoTabArray =<< c_pango_tab_array_freeze pta + +pangoTabArrayFixedFreeze :: PrimMonad m => + PangoTabArrayFixed (PrimState m) -> m PangoTabArray +pangoTabArrayFixedFreeze (PangoTabArrayFixed fta) = + unsafeIOToPrim $ withForeignPtr fta \pta -> + makePangoTabArray =<< c_pango_tab_array_freeze pta + +pangoTabArrayThaw :: PrimMonad m => PangoTabArray -> m (Either + (PangoTabArrayFixed (PrimState m)) + (PangoTabArrayInt (PrimState m))) +pangoTabArrayThaw (PangoTabArray fta) = + unsafeIOToPrim $ withForeignPtr fta \pta -> do + px <- c_pango_tab_array_get_positions_in_pixels pta + c_pango_tab_array_thaw pta >>= case px of + #{const FALSE} -> (Left <$>) . mkPangoTabArrayFixed + #{const TRUE} -> (Right <$>) . mkPangoTabArrayInt + _ -> error "never occur" + +foreign import ccall "pango_tab_array_copy" c_pango_tab_array_freeze :: + Ptr PangoTabArray -> IO (Ptr PangoTabArray) + +foreign import ccall "pango_tab_array_copy" c_pango_tab_array_thaw :: + Ptr PangoTabArray -> IO (Ptr PangoTabArray) diff --git a/src/Graphics/Pango/Rendering/Cairo.hsc b/src/Graphics/Pango/Rendering/Cairo.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Pango/Rendering/Cairo.hsc @@ -0,0 +1,159 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Pango.Rendering.Cairo ( + -- * CREATE + pangoCairoCreateContext, + pangoCairoUpdateContext, + pangoCairoCreateLayout, + pangoCairoUpdateLayout, + + -- * SHOW + pangoCairoShowLayout, + pangoCairoShowErrorUnderline, + pangoCairoShowGlyphItem, + pangoCairoShowLayoutLine, + + -- * PATH + pangoCairoLayoutLinePath, + pangoCairoLayoutPath, + pangoCairoErrorUnderlinePath, + + -- * RESOLUTION + pangoCairoContextGetResolution, + pangoCairoContextSetResolution + + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (addForeignPtrFinalizer) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.C +import Foreign.C.String.Misc +import Control.Monad.Primitive +import Data.Maybe +import Data.CairoContext + +import Graphics.Pango.Basic.GlyphStorage.Internal +import Graphics.Pango.Basic.LayoutObjects.PangoLayout.Internal +import Graphics.Pango.Basic.LayoutObjects.PangoLayoutLine.Internal +import Graphics.Pango.LowLevel.Contexts.Internal + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +pangoCairoCreateContext :: PrimMonad m => CairoT r (PrimState m) -> m PangoContext +pangoCairoCreateContext (CairoT fcr) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> + mkPangoContext =<< c_pango_cairo_create_context pcr + +foreign import ccall "pango_cairo_create_context" + c_pango_cairo_create_context :: Ptr (CairoT r s) -> IO (Ptr PangoContext) + +pangoCairoUpdateContext :: + PrimMonad m => CairoT r (PrimState m) -> PangoContext -> m () +pangoCairoUpdateContext (CairoT fcr) (PangoContext fc) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> withForeignPtr fc \pc -> + c_pango_cairo_update_context pcr pc + +foreign import ccall "pango_cairo_update_context" + c_pango_cairo_update_context :: + Ptr (CairoT r s) -> Ptr PangoContext -> IO () + +pangoCairoCreateLayout :: + PrimMonad m => CairoT r (PrimState m) -> m (PangoLayoutPrim (PrimState m)) +pangoCairoCreateLayout (CairoT fcr) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> + mkPangoLayoutPrim =<< c_pango_cairo_create_layout pcr + +foreign import ccall "pango_cairo_create_layout" c_pango_cairo_create_layout :: + Ptr (CairoT r s) -> IO (Ptr PangoLayout) + +pangoCairoUpdateLayout :: PrimMonad m => + CairoT r (PrimState m) -> PangoLayoutPrim (PrimState m) -> m () +pangoCairoUpdateLayout (CairoT fcr) (PangoLayoutPrim fl) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> withForeignPtr fl \pl -> + c_pango_cairo_update_layout pcr pl + +foreign import ccall "pango_cairo_update_layout" c_pango_cairo_update_layout :: + Ptr (CairoT r s) -> Ptr PangoLayout -> IO () + +pangoCairoShowGlyphItem :: CairoTIO r -> T.Text -> PangoGlyphItem -> IO () +pangoCairoShowGlyphItem (CairoT fcr) t (PangoGlyphItem fgi) = + withForeignPtr fcr \cr -> T.withCStringLen t \(ct, n) -> do + cs' <- copyCString ct n + addForeignPtrFinalizer fcr $ free cs' + withForeignPtr fgi $ c_pango_cairo_show_glyph_item cr cs' + +foreign import ccall "pango_cairo_show_glyph_item" + c_pango_cairo_show_glyph_item :: + Ptr (CairoT r s) -> CString -> Ptr PangoGlyphItem -> IO () + +pangoCairoShowLayoutLine :: CairoTIO r -> PangoLayoutLine -> IO () +pangoCairoShowLayoutLine (CairoT fcr) (PangoLayoutLine fll) = + withForeignPtr fcr \cr -> + withForeignPtr fll $ c_pango_cairo_show_layout_line cr + +foreign import ccall "pango_cairo_show_layout_line" + c_pango_cairo_show_layout_line :: + Ptr (CairoT r s) -> Ptr PangoLayoutLine -> IO () + +pangoCairoShowLayout :: CairoTIO r -> PangoLayout -> IO () +pangoCairoShowLayout (CairoT fcr) (PangoLayout_ fl) = withForeignPtr fcr \cr -> + withForeignPtr fl $ c_pango_cairo_show_layout cr + +foreign import ccall "pango_cairo_show_layout" c_pango_cairo_show_layout :: + Ptr (CairoT r s) -> Ptr PangoLayout -> IO () + +pangoCairoShowErrorUnderline :: + CairoTIO r -> CDouble -> CDouble -> CDouble -> CDouble -> IO () +pangoCairoShowErrorUnderline (CairoT fcr) x y w h = + withForeignPtr fcr \cr -> c_pango_cairo_show_error_underline cr x y w h + +foreign import ccall "pango_cairo_show_error_underline" + c_pango_cairo_show_error_underline :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +pangoCairoLayoutLinePath :: CairoTIO r -> PangoLayoutLine -> IO () +pangoCairoLayoutLinePath (CairoT fcr) (PangoLayoutLine fll) = + withForeignPtr fcr \cr -> + withForeignPtr fll $ c_pango_cairo_layout_line_path cr + +foreign import ccall "pango_cairo_layout_line_path" + c_pango_cairo_layout_line_path :: + Ptr (CairoT r s) -> Ptr PangoLayoutLine -> IO () + +pangoCairoLayoutPath :: CairoTIO r -> PangoLayout -> IO () +pangoCairoLayoutPath (CairoT fcr) (PangoLayout_ fl) = withForeignPtr fcr \cr -> + withForeignPtr fl $ c_pango_cairo_layout_path cr + +foreign import ccall "pango_cairo_layout_path" c_pango_cairo_layout_path :: + Ptr (CairoT r s) -> Ptr PangoLayout -> IO () + +pangoCairoErrorUnderlinePath :: + CairoTIO r -> CDouble -> CDouble -> CDouble -> CDouble -> IO () +pangoCairoErrorUnderlinePath (CairoT fcr) x y w h = withForeignPtr fcr \cr -> + c_pango_cairo_error_underline_path cr x y w h + +foreign import ccall "pango_cairo_error_underline_path" + c_pango_cairo_error_underline_path :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +pangoCairoContextGetResolution :: PangoContext -> IO (Maybe CDouble) +pangoCairoContextGetResolution (PangoContext fctx) = do + r <- withForeignPtr fctx c_pango_cairo_context_get_resolution + pure if r < 0 then Nothing else Just r + +foreign import ccall "pango_cairo_context_get_resolution" + c_pango_cairo_context_get_resolution :: + Ptr PangoContext -> IO CDouble + +pangoCairoContextSetResolution :: PangoContext -> Maybe CDouble -> IO () +pangoCairoContextSetResolution (PangoContext fctx) mr = + withForeignPtr fctx \pctx -> c_pango_cairo_context_set_resolution pctx + $ fromMaybe (- 1) mr + +foreign import ccall "pango_cairo_context_set_resolution" + c_pango_cairo_context_set_resolution :: + Ptr PangoContext -> CDouble -> IO () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"