feat: add Haskell bindings to the UTF-32 buffer API

.github/workflows/ci.yml

@@ -18,5 +18,7 @@ jobs:
       with:
         name: buchstabensuppe
         authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
-    - name: nix-build
+    - name: build library
       run: nix-build
+    - name: build haskell bindings
+      run: nix-build -A haskell-buchstabensuppe

bindings/hs/.envrc

@@ -0,0 +1 @@
+eval "$(lorri direnv)"

bindings/hs/.gitignore

@@ -0,0 +1,2 @@
+dist
+dist-newstyle

bindings/hs/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for haskell-buchstabensuppe
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

bindings/hs/cbits/buchstabensuppe-wrapper.c

@@ -0,0 +1,18 @@
+#include <stdlib.h>
+
+#include "buchstabensuppe-wrapper.h"
+
+void bsw_utf32_buffer_new(size_t s, bs_utf32_buffer_t *buf) {
+  *buf = bs_utf32_buffer_new(s);
+}
+
+void bsw_utf32_buffer_free(bs_utf32_buffer_t *buf) {
+  if(buf != NULL) {
+    bs_utf32_buffer_free(buf);
+    free(buf);
+  }
+}
+
+void bsw_decode_utf8(char *s, size_t l, bs_utf32_buffer_t *buf) {
+  *buf = bs_decode_utf8(s, l);
+}

bindings/hs/cbits/buchstabensuppe-wrapper.h

@@ -0,0 +1,7 @@
+#include <buchstabensuppe.h>
+
+void bsw_utf32_buffer_new(size_t, bs_utf32_buffer_t *);
+
+void bsw_utf32_buffer_free(bs_utf32_buffer_t *);
+
+void bsw_decode_utf8(char *, size_t, bs_utf32_buffer_t *);

bindings/hs/haskell-buchstabensuppe.cabal

@@ -0,0 +1,65 @@
+cabal-version: 2.4
+name: haskell-buchstabensuppe
+version: 0.0.0.0
+
+synopsis: Bindings to the buchstabensuppe font rendering library
+description:
+  Bindings to buchstabensuppe, a toy font rendering library
+  for high contrast, low pixel count displays
+
+bug-reports: https://github.com/sternenseemann/buchstabensuppe/issues
+homepage: https://github.com/sternenseemann/buchstabensuppe
+
+license: BSD-3-Clause
+author: sternenseemann
+maintainer: [email protected]
+
+extra-source-files: CHANGELOG.md
+
+category: Graphics
+
+common basic-settings
+    ghc-options:
+      -Wall -Weverything
+      -Wno-missing-import-lists
+      -Wno-implicit-prelude
+      -Wno-unsafe
+      -Wno-all-missed-specialisations
+      -Wno-prepositive-qualified-module
+    default-language: Haskell2010
+
+library
+    import: basic-settings
+    exposed-modules:
+        Graphics.Buchstabensuppe
+      , Graphics.Buchstabensuppe.Buffer.UTF32
+
+    hs-source-dirs: src
+
+    build-depends:
+        base >=4.15 && <4.16
+      , utf8-light >= 0.3 && < 0.5
+      , bytestring >= 0.10 && < 0.12
+      , text ^>= 1.2 || ^>= 2.0
+
+    pkgconfig-depends:  buchstabensuppe
+
+    include-dirs: cbits
+    c-sources: cbits/buchstabensuppe-wrapper.c
+
+test-suite unit-tests
+    import: basic-settings
+    type: exitcode-stdio-1.0
+    main-is: Main.hs
+    other-modules:
+        Test.Buchstabensuppe.Buffers
+    hs-source-dirs: test
+    build-depends:
+        base
+      , haskell-buchstabensuppe
+      , tasty ^>= 1.4
+      , tasty-quickcheck ^>= 0.10
+      , QuickCheck
+      , text
+      , bytestring
+    ghc-options: -Wno-missing-safe-haskell-mode

bindings/hs/shell.nix

@@ -0,0 +1,19 @@
+{ nixpkgsSrc ? <nixpkgs> }:
+
+let
+  pkgs = import nixpkgsSrc {
+    overlays = [ (import ../../overlay.nix) ];
+  };
+in
+
+pkgs.haskellPackages.shellFor {
+  packages = p: [
+    p.haskell-buchstabensuppe
+  ];
+
+  nativeBuildInputs = [
+    pkgs.cabal-install
+  ];
+
+  withHoogle = true;
+}

bindings/hs/src/Graphics/Buchstabensuppe.hs

@@ -0,0 +1 @@
+module Graphics.Buchstabensuppe () where

bindings/hs/src/Graphics/Buchstabensuppe/Buffer/UTF32.hsc

@@ -0,0 +1,168 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Unsafe #-}
+
+{-|
+Module: Graphics.Buchstabensuppe.Buffer.UTF32
+Description: Bindings to buchstabensuppe's UTF32 buffer functions
+-}
+module Graphics.Buchstabensuppe.Buffer.UTF32
+  ( -- * Constructing Buffers
+    newBuffer
+  , Buffer
+    -- * Converting to Buffers
+  , fromString
+  , fromText
+  , fromUtf8
+    -- * Querying Buffer Info
+  , getCapacity
+  , getLength
+    -- * Extending Buffers
+  , append
+  , appendSingle
+  , append'
+  , appendSingle'
+  ) where
+
+#include <buchstabensuppe.h>
+#include <stdbool.h>
+
+import Codec.Binary.UTF8.Light ( c2w )
+import Control.Monad ( when )
+import Data.Word ( Word32 () )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+import Foreign.C.Error ( throwErrno, throwErrnoIf_
+                       , getErrno, eOK
+                       , resetErrno
+                       )
+import Foreign.C.Types ( CSize (..), CBool (..), CChar (..) )
+import Foreign.ForeignPtr ( ForeignPtr (), newForeignPtr, withForeignPtr )
+import Foreign.Marshal.Alloc ( malloc )
+import Foreign.Marshal.Array ( withArrayLen )
+import Foreign.Ptr ( Ptr (), FunPtr () )
+import Foreign.Storable ( Storable (..) )
+
+-- High-Level Haskell interface
+
+-- | Wrapper around a @bs_utf32_buffer_t@, allocated entirely on the heap.
+newtype Buffer = Buffer { unBuffer :: ForeignPtr BufferRaw }
+
+getCapacity :: Buffer -> IO CSize
+getCapacity (Buffer buf) = withForeignPtr buf $ fmap bufferRawCapacity . peek
+
+getLength :: Buffer -> IO CSize
+getLength (Buffer buf) = withForeignPtr buf $ fmap bufferRawLength . peek
+
+makeBuffer :: Ptr BufferRaw -> IO Buffer
+makeBuffer bufStruct =
+  Buffer <$> newForeignPtr p_bsw_utf32_buffer_free bufStruct
+
+-- | Create a new 'Buffer' of the specified size. If the specified capacity
+--   were to run out, it would be extended automatically.
+--   Note that this action never fails. If it fails to allocate the requested
+--   memory, a buffer with capacity 0 will be returned.
+newBuffer
+  :: CSize
+  -- ^ Initial storage capacity in number of elements.
+  -> IO Buffer
+newBuffer initialSize = do
+  bufStruct <- malloc
+  c_bsw_utf32_buffer_new initialSize bufStruct
+  makeBuffer bufStruct
+
+appendSingle :: Buffer -> Char -> IO ()
+appendSingle buf = appendSingle' buf . c2w
+
+appendSingle' :: Buffer -> Word32 -> IO ()
+appendSingle' (Buffer buf) c = withForeignPtr buf
+  $ \raw ->
+      throwErrnoIf_
+        (not . fromCBool)
+        "Graphics.Buchstabensuppe.Buffer.UTF32.appendSingle'"
+        $ c_bs_utf32_buffer_append_single c raw
+
+append :: Buffer -> String -> IO ()
+append buf = append' buf . map c2w
+
+append' :: Buffer -> [Word32] -> IO ()
+append' (Buffer buf) cs = withForeignPtr buf
+  $ \raw -> withArrayLen cs
+      $ \len arr ->
+          throwErrnoIf_
+            (not . fromCBool)
+            "Graphics.Buchstabensuppe.Buffer.UTF32.append'"
+            -- TODO: integer size?
+            $ c_bs_utf32_buffer_append arr (fromIntegral len) raw
+
+fromUtf8 :: BS.ByteString -> IO Buffer
+fromUtf8 bs = BS.unsafeUseAsCStringLen bs
+  $ \(charPtr, len) -> do
+      bufStruct <- malloc
+
+      resetErrno -- clear errno before invoking because it won't indicate errors
+      -- TODO: integer size?
+      c_bsw_decode_utf8 charPtr (fromIntegral len) bufStruct
+
+      errno <- getErrno
+      when (errno /= eOK)
+        $ throwErrno "Graphics.Buchstabensuppe.Buffer.UTF32.fromUtf8"
+
+      makeBuffer bufStruct
+
+-- TODO: with text 2.0 this should be cheap (could be cheaper ofc),
+-- for earlier versions there's maybe a better option
+fromText :: T.Text -> IO Buffer
+fromText = fromUtf8 . T.encodeUtf8
+
+fromString :: [Char] -> IO Buffer
+fromString cs = do
+  buf <- newBuffer 0
+  buf `append` cs
+  pure buf
+
+-- Utils and Types for interfacing with the C code
+
+fromCBool :: CBool -> Bool
+fromCBool b = b /= #{const false}
+
+data BufferRaw
+  = BufferRaw
+  { bufferRawBuffer :: Ptr Word32
+  , bufferRawCapacity :: CSize
+  , bufferRawLength :: CSize
+  }
+
+instance Storable BufferRaw where
+  alignment _ = #{alignment bs_utf32_buffer_t}
+  sizeOf _ = #{size bs_utf32_buffer_t}
+  peek ptr = do
+    bufferRawBuffer <- #{peek bs_utf32_buffer_t, bs_utf32_buffer} ptr
+    bufferRawCapacity <- #{peek bs_utf32_buffer_t, bs_utf32_buffer_cap} ptr
+    bufferRawLength <- #{peek bs_utf32_buffer_t, bs_utf32_buffer_len} ptr
+    pure $ BufferRaw {..}
+  poke ptr BufferRaw {..} = do
+    #{poke bs_utf32_buffer_t, bs_utf32_buffer} ptr bufferRawBuffer
+    #{poke bs_utf32_buffer_t, bs_utf32_buffer_cap} ptr bufferRawCapacity
+    #{poke bs_utf32_buffer_t, bs_utf32_buffer_len} ptr bufferRawLength
+
+-- FFI
+
+-- Wrapper functions from cbits because Haskell FFI doesn't support returning structs.
+foreign import ccall "bsw_utf32_buffer_new"
+  c_bsw_utf32_buffer_new :: CSize -> Ptr BufferRaw -> IO ()
+
+foreign import ccall "bsw_decode_utf8"
+  c_bsw_decode_utf8 :: Ptr CChar -> CSize -> Ptr BufferRaw -> IO ()
+
+foreign import ccall "&bsw_utf32_buffer_free"
+  p_bsw_utf32_buffer_free :: FunPtr (Ptr BufferRaw -> IO ())
+
+-- Direct bindings to buchstabensuppe
+foreign import ccall "bs_utf32_buffer_append_single"
+  c_bs_utf32_buffer_append_single :: Word32 -> Ptr BufferRaw -> IO CBool
+
+foreign import ccall "bs_utf32_buffer_append"
+  c_bs_utf32_buffer_append :: Ptr Word32 -> CSize -> Ptr BufferRaw -> IO CBool

bindings/hs/test/Main.hs

@@ -0,0 +1,10 @@
+module Main (main) where
+
+import Test.Buchstabensuppe.Buffers
+
+import Test.Tasty
+
+main :: IO ()
+main = defaultMain $ testGroup "Tests"
+  [ buffers
+  ]