Merge pull request #16 from haskell-game/update-to-text-2.0

Mikolaj · web-flow · commit 4a92a6a9d267 · 2022-08-14T12:22:29.000+02:00
Update to work with text &gt;= 2.0.1
diff --git a/README.md b/README.md
@@ -8,7 +8,7 @@
 Haskell bindings for the True Type Font library for SDL.
 
 - libsdl <https://www.libsdl.org>
-- sdl2-ttf <https://www.libsdl.org/projects/SDL_ttf/>
+- sdl2-ttf <https://github.com/libsdl-org/SDL_ttf>
 
 Both the raw and the higher level bindings should allow you to use any aspect
 of the original SDL2_ttf library. Please report an issue if you encounter a bug
diff --git a/sdl2-ttf.cabal b/sdl2-ttf.cabal
@@ -1,7 +1,7 @@
 name:          sdl2-ttf
 version:       2.1.3
 synopsis:      Bindings to SDL2_ttf.
-description:   Haskell bindings to SDL2_ttf C++ library <http://www.libsdl.org/projects/SDL_ttf/>.
+description:   Haskell bindings to SDL2_ttf C++ library <https://github.com/libsdl-org/SDL_ttf>.
 bug-reports:   https://github.com/haskell-game/sdl2-ttf/issues
 license:       BSD3
 license-file:  LICENSE
@@ -14,7 +14,7 @@ copyright:     Copyright © 2013-2022 Ömer Sinan Ağacan, Siniša Biđin, Rongc
 category:      Font, Foreign binding, Graphics
 build-type:    Simple
 cabal-version: >=1.10
-tested-with:   GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3
+tested-with:   GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 || ==9.4
 
 source-repository head
   type:     git
@@ -45,7 +45,7 @@ library
     bytestring       >= 0.10.4.0,
     sdl2             >= 2.2,
     template-haskell,
-    text             >= 1.1.0.0,
+    text             >= 1.1.0.0 && < 2 || >= 2.0.1,
     th-abstraction   >= 0.4.0.0,
     transformers     >= 0.4
 
diff --git a/src/SDL/Font.hs b/src/SDL/Font.hs
@@ -16,9 +16,7 @@ throwing an 'SDLException' in case it encounters an error.
 
 -}
 
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE CPP, DeriveGeneric, LambdaCase, OverloadedStrings #-}
 
 module SDL.Font
   (
@@ -86,31 +84,52 @@ module SDL.Font
   , blendedWrapped
   ) where
 
-import Control.Exception      (throwIO)
-import Control.Monad          (unless)
+import Control.Exception (throwIO)
+import Control.Monad (unless)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.Bits              ((.&.), (.|.))
-import Data.ByteString        (ByteString)
-import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackCString)
-import Data.Text              (Text)
-import Data.Text.Encoding     (decodeUtf8)
-import Data.Text.Foreign      (lengthWord16, unsafeCopyToPtr)
-import Data.Word              (Word8, Word16)
-import Foreign.C.String       (CString, withCString)
-import Foreign.C.Types        (CUShort, CInt)
-import Foreign.Marshal.Alloc  (allocaBytes, alloca)
-import Foreign.Marshal.Utils  (with, fromBool, toBool)
-import Foreign.Ptr            (Ptr, castPtr, nullPtr)
-import Foreign.Storable       (peek, pokeByteOff)
-import GHC.Generics           (Generic)
-import SDL                    (Surface(..), SDLException(SDLCallFailed))
+import Data.Bits ((.&.), (.|.))
+import Data.ByteString (ByteString)
+import Data.ByteString.Unsafe (unsafePackCString, unsafeUseAsCStringLen)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Word (Word8)
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (fromBool, toBool, with)
+import Foreign.Ptr (Ptr, castPtr, nullPtr)
+import Foreign.Storable (peek)
+import GHC.Generics (Generic)
+import SDL (SDLException (SDLCallFailed), Surface (..))
 import SDL.Internal.Exception
-import SDL.Raw.Filesystem     (rwFromConstMem)
-import SDL.Vect               (V4(..))
+import SDL.Raw.Filesystem (rwFromConstMem)
+import SDL.Vect (V4 (..))
 
+import qualified Foreign.C.String
 import qualified SDL.Raw
 import qualified SDL.Raw.Font
 
+-- stolen from https://github.com/haskell-game/dear-imgui.hs/blob/main/src/DearImGui/Internal/Text.hs
+#if MIN_VERSION_text(2,0,1)
+
+import qualified Data.Text.Foreign
+
+withCString :: Text -> (CString -> IO a) -> IO a
+withCString = Data.Text.Foreign.withCString
+
+#else
+
+import qualified Data.Text
+import qualified GHC.Foreign
+import qualified System.IO
+
+withCString :: Text -> (CString -> IO a) -> IO a
+withCString t action = do
+  GHC.Foreign.withCString System.IO.utf8 (Data.Text.unpack t) $ \textPtr ->
+    action textPtr
+
+#endif
+
 -- | Gets the major, minor, patch versions of the linked @SDL2_ttf@ library.
 --
 -- You may call this without initializing the library with 'initialize'.
@@ -151,7 +170,7 @@ load :: MonadIO m => FilePath -> PointSize -> m Font
 load path pts =
   fmap Font .
     throwIfNull "SDL.Font.load" "TTF_OpenFont" .
-      liftIO . withCString path $
+      liftIO . Foreign.C.String.withCString path $
         flip SDL.Raw.Font.openFont $ fromIntegral pts
 
 -- | Same as 'load', but accepts a 'ByteString' containing a font instead.
@@ -175,7 +194,7 @@ loadIndex :: MonadIO m => FilePath -> PointSize -> Index -> m Font
 loadIndex path pts i =
   fmap Font .
     throwIfNull "SDL.Font.loadIndex" "TTF_OpenFontIndex" .
-      liftIO . withCString path $ \cpath ->
+      liftIO . Foreign.C.String.withCString path $ \cpath ->
         SDL.Raw.Font.openFontIndex cpath (fromIntegral pts) (fromIntegral i)
 
 -- | Same as 'loadIndex', but accepts a 'ByteString' containing a font instead.
@@ -205,10 +224,10 @@ unmanaged p = Surface p Nothing
 solid :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
 solid (Font font) (V4 r g b a) text =
   fmap unmanaged .
-    throwIfNull "SDL.Font.solid" "TTF_RenderUNICODE_Solid" .
-      liftIO . withText text $ \ptr ->
+    throwIfNull "SDL.Font.solid" "TTF_RenderUTF8_Solid" .
+      liftIO . withCString text $ \ptr ->
         with (SDL.Raw.Color r g b a) $ \fg ->
-          SDL.Raw.Font.renderUNICODE_Solid font (castPtr ptr) fg
+          SDL.Raw.Font.renderUTF8_Solid font (castPtr ptr) fg
 
 -- | Uses the /slow and nice, but with a solid box/ method.
 --
@@ -220,11 +239,11 @@ solid (Font font) (V4 r g b a) text =
 shaded :: MonadIO m => Font -> Color -> Color -> Text -> m SDL.Surface
 shaded (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) text =
   fmap unmanaged .
-    throwIfNull "SDL.Font.shaded" "TTF_RenderUNICODE_Shaded" .
-      liftIO . withText text $ \ptr ->
+    throwIfNull "SDL.Font.shaded" "TTF_RenderUTF8_Shaded" .
+      liftIO . withCString text $ \ptr ->
         with (SDL.Raw.Color r g b a) $ \fg ->
           with (SDL.Raw.Color r2 g2 b2 a2) $ \bg ->
-            SDL.Raw.Font.renderUNICODE_Shaded font (castPtr ptr) fg bg
+            SDL.Raw.Font.renderUTF8_Shaded font (castPtr ptr) fg bg
 
 -- | The /slow slow slow, but ultra nice over another image/ method, 'blended'
 -- renders text at high quality.
@@ -237,21 +256,10 @@ shaded (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) text =
 blended :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
 blended (Font font) (V4 r g b a) text =
   fmap unmanaged .
-    throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended" .
-      liftIO . withText text $ \ptr ->
+    throwIfNull "SDL.Font.blended" "TTF_RenderUTF8_Blended" .
+      liftIO . withCString text $ \ptr ->
         with (SDL.Raw.Color r g b a) $ \fg ->
-          SDL.Raw.Font.renderUNICODE_Blended font (castPtr ptr) fg
-
--- Analogous to Data.Text.Foreign.useAsPtr, just appends a null-byte.
--- FIXME: Is this even necessary?
-withText :: Text -> (Ptr Word16 -> IO a) -> IO a
-withText text act =
-  allocaBytes len $ \ptr -> do
-    unsafeCopyToPtr text ptr
-    pokeByteOff ptr (len - 2) (0 :: CUShort)
-    act ptr
-  where
-    len = 2*(lengthWord16 text + 1)
+          SDL.Raw.Font.renderUTF8_Blended font (castPtr ptr) fg
 
 -- Helper function for converting a bitmask into a list of values.
 fromMaskWith :: (Enum a, Bounded a) => (a -> CInt) -> CInt -> [a]
@@ -464,18 +472,18 @@ glyphMetrics (Font font) ch =
 size :: MonadIO m => Font -> Text -> m (Int, Int)
 size (Font font) text =
     liftIO .
-      withText text $ \ptr ->
+      withCString text $ \ptr ->
         alloca $ \w ->
           alloca $ \h ->
-            SDL.Raw.Font.sizeUNICODE font (castPtr ptr) w h
+            SDL.Raw.Font.sizeUTF8 font (castPtr ptr) w h
               >>= \case
                 0 -> do
                   w' <- fromIntegral <$> peek w
                   h' <- fromIntegral <$> peek h
                   return (w', h')
                 _ -> do
                   err <- getError
-                  throwIO $ SDLCallFailed "SDL.Font.size" "TTF_SizeUNICODE" err
+                  throwIO $ SDLCallFailed "SDL.Font.size" "TTF_SizeUTF8" err
 
 -- | Same as 'solid', but renders a single glyph instead.
 solidGlyph :: MonadIO m => Font -> Color -> Char -> m SDL.Surface
@@ -505,16 +513,16 @@ blendedGlyph (Font font) (V4 r g b a) ch =
         with (SDL.Raw.Color r g b a) $ \fg ->
           SDL.Raw.Font.renderGlyph_Blended font (fromChar ch) fg
 
--- | Same as 'blended', but renders across multiple lines. 
+-- | Same as 'blended', but renders across multiple lines.
 --   Text is wrapped to multiple lines on line endings and on word boundaries
 --   if it extends beyond wrapLength in pixels.
 blendedWrapped :: MonadIO m => Font -> Color -> Int -> Text -> m SDL.Surface
 blendedWrapped (Font font) (V4 r g b a) wrapLength text =
   fmap unmanaged .
-    throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended_Wrapped" .
-      liftIO . withText text $ \ptr ->
+    throwIfNull "SDL.Font.blended" "TTF_RenderUTF8_Blended_Wrapped" .
+      liftIO . withCString text $ \ptr ->
         with (SDL.Raw.Color r g b a) $ \fg ->
-          SDL.Raw.Font.renderUNICODE_Blended_Wrapped font (castPtr ptr) fg $ fromIntegral wrapLength
+          SDL.Raw.Font.renderUTF8_Blended_Wrapped font (castPtr ptr) fg $ fromIntegral wrapLength
 
 -- | From a given 'Font' get the kerning size of two glyphs.
 getKerningSize :: MonadIO m => Font -> Index -> Index -> m Int
