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

14 files changed, 447 insertions, 2 deletions

diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index 8dc65ec..e60a0cb 100644
--- a/.github/workflows/ci.yml
+++ b/.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
diff --git a/bindings/hs/.envrc b/bindings/hs/.envrc
new file mode 100644
index 0000000..051d09d
--- /dev/null
+++ b/bindings/hs/.envrc
@@ -0,0 +1 @@
+eval "$(lorri direnv)"
diff --git a/bindings/hs/.gitignore b/bindings/hs/.gitignore
new file mode 100644
index 0000000..21d9e6c
--- /dev/null
+++ b/bindings/hs/.gitignore
@@ -0,0 +1,2 @@
+dist
+dist-newstyle
diff --git a/bindings/hs/CHANGELOG.md b/bindings/hs/CHANGELOG.md
new file mode 100644
index 0000000..1e4fd72
--- /dev/null
+++ b/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.
diff --git a/bindings/hs/cbits/buchstabensuppe-wrapper.c b/bindings/hs/cbits/buchstabensuppe-wrapper.c
new file mode 100644
index 0000000..0d66c68
--- /dev/null
+++ b/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);
+}
diff --git a/bindings/hs/cbits/buchstabensuppe-wrapper.h b/bindings/hs/cbits/buchstabensuppe-wrapper.h
new file mode 100644
index 0000000..3ed2982
--- /dev/null
+++ b/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 *);
diff --git a/bindings/hs/haskell-buchstabensuppe.cabal b/bindings/hs/haskell-buchstabensuppe.cabal
new file mode 100644
index 0000000..12c94f6
--- /dev/null
+++ b/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: sternenseemann@systemli.org
+
+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
diff --git a/bindings/hs/shell.nix b/bindings/hs/shell.nix
new file mode 100644
index 0000000..ac276ea
--- /dev/null
+++ b/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;
+}
diff --git a/bindings/hs/src/Graphics/Buchstabensuppe.hs b/bindings/hs/src/Graphics/Buchstabensuppe.hs
new file mode 100644
index 0000000..455f0d5
--- /dev/null
+++ b/bindings/hs/src/Graphics/Buchstabensuppe.hs
@@ -0,0 +1 @@
+module Graphics.Buchstabensuppe () where
diff --git a/bindings/hs/src/Graphics/Buchstabensuppe/Buffer/UTF32.hsc b/bindings/hs/src/Graphics/Buchstabensuppe/Buffer/UTF32.hsc
new file mode 100644
index 0000000..99b5439
--- /dev/null
+++ b/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
diff --git a/bindings/hs/test/Main.hs b/bindings/hs/test/Main.hs
new file mode 100644
index 0000000..c30713e
--- /dev/null
+++ b/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
+  ]
diff --git a/bindings/hs/test/Test/Buchstabensuppe/Buffers.hs b/bindings/hs/test/Test/Buchstabensuppe/Buffers.hs
new file mode 100644
index 0000000..980dffd
--- /dev/null
+++ b/bindings/hs/test/Test/Buchstabensuppe/Buffers.hs
@@ -0,0 +1,129 @@
+module Test.Buchstabensuppe.Buffers (buffers) where
+
+import qualified Graphics.Buchstabensuppe.Buffer.UTF32 as Buf
+
+import Control.Exception (catch, throwIO)
+import Control.Monad (when)
+import Control.Monad.IO.Class
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Foreign.C.Error (errnoToIOError, eINVAL)
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck.Monadic
+
+-- Note these properties all assume all allocations will succeed.
+buffers :: TestTree
+buffers = testGroup "Test buchstabensuppe buffer bindings"
+  [ testProperty "Buffer capacity and length are correct after creation" prop_bufferCreate
+  , testProperty "Buffer capacity and length are correct after appendSingle" prop_bufferAppendSingle
+  , testProperty "Buffer capacity and length are correct after append" prop_bufferAppend
+  , testProperty "Appending an empty string to a buffer does nothing" prop_bufferAppendEmpty
+  , testProperty "Decoding an UTF-8 ByteString returns the correct length" prop_bufferDecodeUtf8
+  , testProperty "Decoding a non-UTF-8 ByteString fails" prop_bufferDecodeUtf8Failures
+  , testProperty "Converting from [Char] returns the correct length" prop_bufferFromString
+  , testProperty "Converting from Text returns the correct length" prop_bufferFromText
+  ]
+
+prop_bufferCreate :: Property
+prop_bufferCreate = monadicIO $ do
+  size <- pick $ choose (0, 16384)
+  buf <- liftIO $ Buf.newBuffer size
+  cap <- liftIO $ Buf.getCapacity buf
+  len <- liftIO $ Buf.getLength buf
+  monitorBuffer buf
+  pure $ len == 0 && size == cap
+
+prop_bufferAppendSingle :: Property
+prop_bufferAppendSingle = monadicIO $ do
+  buf <- arbitraryBuffer
+
+  len <- liftIO $ Buf.getLength buf
+  cap <- liftIO $ Buf.getCapacity buf
+
+  monitorBuffer buf
+
+  char <- pick arbitrary
+  liftIO $ buf `Buf.appendSingle` char
+
+  newCap <- liftIO $ Buf.getCapacity buf
+  (&& (len <= cap || newCap == (cap + 1))) <$> expectedLength buf (len + 1)
+
+prop_bufferAppendEmpty :: Property
+prop_bufferAppendEmpty = monadicIO $ do
+  buf <- arbitraryBuffer
+
+  len <- liftIO $ Buf.getLength buf
+
+  liftIO $ buf `Buf.append` ""
+
+  expectedLength buf len
+
+prop_bufferAppend :: Property
+prop_bufferAppend = monadicIO $ do
+  buf <- arbitraryBuffer
+  extraString <- pick $ resize 30 $ listOf arbitrary
+
+  len <- liftIO $ Buf.getLength buf
+
+  liftIO $ buf `Buf.append` extraString
+
+  expectedLength buf $ len + fromIntegral (length extraString)
+
+prop_bufferDecodeUtf8 :: Property
+prop_bufferDecodeUtf8 = monadicIO $ do
+  text <- fmap T.pack $ pick $ resize 1024 $ listOf arbitrary
+  buf <- liftIO $ Buf.fromUtf8 $ T.encodeUtf8 text
+
+  expectedLength buf (T.length text)
+
+prop_bufferDecodeUtf8Failures :: Property
+prop_bufferDecodeUtf8Failures = monadicIO $ do
+  bs <- fmap BS.pack $ pick $ resize 2048 $ listOf arbitrary
+
+  case T.decodeUtf8' bs of
+    Right _ -> pure True -- we ignore random valid UTF-8 strings here
+    Left _ ->
+      liftIO $ (Buf.fromUtf8 bs >> pure False) `catch` \e ->
+        if e == errnoToIOError "Graphics.Buchstabensuppe.Buffer.UTF32.fromUtf8" eINVAL Nothing Nothing
+        then pure True
+        else throwIO e -- rethrowing allows us to see the unexpected exception
+
+prop_bufferFromString :: Property
+prop_bufferFromString = monadicIO $ do
+  str <- pick $ resize 100 $ listOf arbitrary
+  buf <- liftIO $ Buf.fromString str
+  expectedLength buf (length str)
+
+prop_bufferFromText :: Property
+prop_bufferFromText = monadicIO $ do
+  text <- fmap T.pack $ pick $ resize 2048 $ listOf arbitrary
+  buf <- liftIO $ Buf.fromText text
+  expectedLength buf (T.length text)
+
+expectedLength :: Integral a => Buf.Buffer -> a -> PropertyM IO Bool
+expectedLength buf len = do
+  monitorBuffer buf
+  actual <- liftIO $ Buf.getLength buf
+  cap <- liftIO $ Buf.getCapacity buf
+  pure $ actual == fromIntegral len && cap >= fromIntegral len
+
+arbitraryBuffer :: PropertyM IO Buf.Buffer
+arbitraryBuffer = do
+  initialSize <- pick $ choose (0, 16)
+  buf <- liftIO $ Buf.newBuffer initialSize
+
+  addInitialContents <- pick arbitrary
+  when addInitialContents $ do
+    str <- pick $ resize 20 $ listOf arbitrary
+    liftIO $ buf `Buf.append` str
+
+  pure buf
+
+monitorBuffer :: Buf.Buffer -> PropertyM IO ()
+monitorBuffer buf = do
+  len <- liftIO $ Buf.getLength buf
+  cap <- liftIO $ Buf.getCapacity buf
+  monitor $ counterexample
+    $ "Capacity: " ++ show cap ++ "; Length: " ++ show len
diff --git a/default.nix b/default.nix
index a991e4a..0b58e5a 100644
--- a/default.nix
+++ b/default.nix
@@ -6,4 +6,8 @@ let
   };
 in
 
-pkgs.buchstabensuppe
+pkgs.buchstabensuppe.overrideAttrs (old: {
+  passthru = old.passthru or {} // {
+    inherit (pkgs.haskellPackages) haskell-buchstabensuppe;
+  };
+})
diff --git a/overlay.nix b/overlay.nix
index 864b192..73c20d2 100644
--- a/overlay.nix
+++ b/overlay.nix
@@ -34,4 +34,18 @@ in
   buchstabensuppe =
     assert self.lib.versionAtLeast self.libschrift.version "0.10.1";
     self.callPackage buchstabensuppe { };
+
+  haskell = super.haskell // {
+    packageOverrides = self.lib.composeExtensions super.haskell.packageOverrides (
+      hsSelf: hsSuper: {
+        haskell-buchstabensuppe = self.haskell.lib.compose.overrideSrc {
+          version = "unstable";
+          # Ignore some extra files to avoid unnecessary rebuilds
+          src = gi.gitignoreSource [
+            "shell.nix"
+          ] ./bindings/hs;
+        } (hsSelf.callCabal2nix "haskell-buchstabensuppe" ./bindings/hs { });
+      }
+    );
+  };
 }