Third attempt

Author: bolt12

examples/c-qrcode/hs-project/app/HighLevel.hs

@@ -1,65 +1,67 @@
+{-# LANGUAGE TypeApplications #-}
+
 -- | High-level wrappers around the generated qrcodegen bindings.
+--
 module HighLevel (
     encodeText
   , getSize
   , getModule
   ) where
 
 import Data.Word (Word8)
-import Foreign.Marshal.Utils qualified as Marshal
 import Foreign.Ptr (Ptr)
 
-import HsBindgen.Runtime.HighLevel.Refine (OutMarshaller, input, output,
-                                           peekIncompleteArrayOut, pureIn,
-                                           pureRes, result, scratchOut,
-                                           toHighLevel, withCStringIn,
-                                           withConstIncompleteArrayIn)
+import HsBindgen.Runtime.HighLevel.ToHighLevel (OutMarshaller, input, output,
+                                                pureIn, scratchArray,
+                                                toHighLevel)
+import HsBindgen.Runtime.HighLevel.ToHighLevel.Defaults (defaultIn, defaultRes)
+import HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers (peekIncompleteArrayOut,
+                                                            withCStringIn,
+                                                            withConstIncompleteArrayIn)
 import HsBindgen.Runtime.IncompleteArray (IncompleteArray)
 
 import QRCodeGenerator.Generated qualified as QR
 import QRCodeGenerator.Generated.Safe qualified as QR
 
--- | Lift @qrcodegen_encodeText@. Destructure the leading scratch @()@ at
--- the call site.
+-- | Lift @qrcodegen_encodeText@. @tempBuffer@ is a 'scratchArray', so it adds
+-- nothing to the result: only the QR code and the success flag come back. The
+-- scalar inputs and the result use default marshallers.
 encodeText
   :: String
   -> QR.Qrcodegen_Ecc
   -> Int
   -> Int
   -> QR.Qrcodegen_Mask
   -> Bool
-  -> IO ((), (IncompleteArray Word8, Bool))
+  -> IO (IncompleteArray Word8, Bool)
 encodeText = toHighLevel
-  ( input  withCStringIn
-  $ output tempScratch
-  $ output qrCodeOut
-  $ input  (pureIn id)
-  $ input  (pureIn fromIntegral)
-  $ input  (pureIn fromIntegral)
-  $ input  (pureIn id)
-  $ input  (pureIn Marshal.fromBool)
-  $ result (pureRes Marshal.toBool)
+  ( input   withCStringIn
+  $ scratchArray @Word8 maxLen -- tempBuffer: written, never read
+  $ output  qrCodeOut
+  $ input   (pureIn id)        -- ecc level (enum, passthrough)
+  $ input   defaultIn          -- minVersion (Int -> CInt)
+  $ input   defaultIn          -- maxVersion (Int -> CInt)
+  $ input   (pureIn id)        -- mask (enum, passthrough)
+  $ input   defaultIn          -- boostEcl (Bool -> CBool)
+  $ defaultRes                 -- CBool -> Bool
   ) QR.qrcodegen_encodeText
   where
     maxLen :: Int
     maxLen = fromIntegral QR.qrcodegen_BUFFER_LEN_MAX
 
-    tempScratch :: OutMarshaller (Ptr Word8) ()
-    tempScratch = scratchOut maxLen
-
     qrCodeOut :: OutMarshaller (Ptr Word8) (IncompleteArray Word8)
     qrCodeOut = peekIncompleteArrayOut maxLen
 
 getSize :: IncompleteArray Word8 -> IO Int
 getSize = toHighLevel
   ( input  withConstIncompleteArrayIn
-  $ result (pureRes fromIntegral)
+  $ defaultRes
   ) QR.qrcodegen_getSize
 
 getModule :: IncompleteArray Word8 -> Int -> Int -> IO Bool
 getModule = toHighLevel
   ( input  withConstIncompleteArrayIn
-  $ input  (pureIn fromIntegral)
-  $ input  (pureIn fromIntegral)
-  $ result (pureRes Marshal.toBool)
+  $ input  defaultIn                  -- x (Int -> CInt)
+  $ input  defaultIn                  -- y (Int -> CInt)
+  $ defaultRes                 -- CBool -> Bool
   ) QR.qrcodegen_getModule

examples/c-qrcode/hs-project/app/Main.hs

@@ -2,7 +2,7 @@
 
 module Main where
 
-import Control.Monad (guard)
+import Control.Monad (when)
 import Data.Bool (bool)
 import Data.Foldable (for_)
 import Data.Word (Word8)
@@ -46,15 +46,15 @@ printQr qrCode = do
 -- }
 basicDemo :: IO ()
 basicDemo = do
-  ((), (qrCode, ok)) <- HL.encodeText
-                          "Hello, world!"
+  (qrCode, ok) <- HL.encodeText
+                    "Hello, world!"
                           QR.Qrcodegen_Ecc_LOW
                           (fromIntegral QR.qrcodegen_VERSION_MIN)
                           (fromIntegral QR.qrcodegen_VERSION_MAX)
                           QR.Qrcodegen_Mask_AUTO
                           True
-  guard ok
-  printQr qrCode
+  -- Mirror the C original's `if (ok) printQr(qrcode);` — silently skip on failure.
+  when ok $ printQr qrCode
 
 main :: IO ()
 main = basicDemo

examples/libpcap/hs-project/app/HighLevel.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 
 -- | High-level wrappers around the generated libpcap bindings.
+--
 module HighLevel (
     PcapError (..)
   , findAllDevNames
@@ -14,27 +15,28 @@ import Foreign.Marshal.Alloc (alloca)
 import Foreign.Ptr (Ptr, nullPtr)
 import Foreign.Storable (peek)
 
-import HsBindgen.Runtime.HighLevel.Refine (OutMarshaller (..), output,
-                                           peekCStringOut, pureRes, result,
-                                           toHighLevel)
+import HsBindgen.Runtime.HighLevel.ToHighLevel (OutMarshaller, mkOut, output,
+                                                resultPure, toHighLevel)
+import HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers (peekCStringOut)
 
 import Generated.Pcap qualified as Pcap
 import Generated.Pcap.Safe qualified as Pcap
 
 -- | Thrown by 'findAllDevNames' when @pcap_findalldevs@ reports failure.
+--
 data PcapError = PcapError { msg :: String, code :: CInt }
   deriving stock (Show)
 instance Exception PcapError
 
 -- | Allocate a @pcap_if_t **@, walk the linked list after the call, free it.
+--
 peekPcapDeviceNames
   :: OutMarshaller (Ptr (Ptr Pcap.Pcap_if_t)) [String]
-peekPcapDeviceNames = OutMarshaller $ \k -> alloca $ \pp -> do
-  r       <- k pp
+peekPcapDeviceNames = mkOut alloca $ \pp -> do
   headPtr <- peek pp
   names   <- collect [] headPtr
   Pcap.pcap_freealldevs headPtr
-  pure (names, r)
+  pure names
   where
     collect acc ptr
       | ptr == nullPtr = pure (reverse acc)
@@ -46,12 +48,13 @@ peekPcapDeviceNames = OutMarshaller $ \k -> alloca $ \pp -> do
 -- | Collect the names of all devices visible to libpcap. The status check
 -- runs after the spec rather than inside a 'throwOn' because the error
 -- buffer lives in a separate output position.
+--
 findAllDevNames :: IO [String]
 findAllDevNames = do
-  (names, (errMsg, status)) <- toHighLevel
+  (names, errMsg, status) <- toHighLevel
     ( output peekPcapDeviceNames
     $ output (peekCStringOut (fromIntegral Pcap.pCAP_ERRBUF_SIZE))
-    $ result (pureRes id)
+    $ resultPure id
     ) Pcap.pcap_findalldevs
   when (status /= 0) $ throwIO (PcapError errMsg status)
   pure names

hs-bindgen-runtime/CHANGELOG.md

@@ -13,6 +13,8 @@ None
 * Add `get`/`set` functions that serve as getters/setters for union values.
   These depend `HasField` instances. See [issue #2060][is-2060] and [PR
   #2091][pr-2091].
+* Add a combinator library for hand-writing high-level wrappers over the
+  generated low-level FFI bindings.
 
 ### Minor changes
 

hs-bindgen-runtime/hs-bindgen-runtime.cabal

@@ -77,7 +77,10 @@ library
     HsBindgen.Runtime.FLAM
     HsBindgen.Runtime.HasCBitfield
     HsBindgen.Runtime.HasCField
-    HsBindgen.Runtime.HighLevel.Refine
+    HsBindgen.Runtime.HighLevel.ToHighLevel
+    HsBindgen.Runtime.HighLevel.ToHighLevel.Defaults
+    HsBindgen.Runtime.HighLevel.ToHighLevel.Errors
+    HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers
     HsBindgen.Runtime.IncompleteArray
     HsBindgen.Runtime.Internal.Bitfield
     HsBindgen.Runtime.Internal.ByteArray
@@ -133,7 +136,8 @@ test-suite test-hs-bindgen-runtime
     Test.HsBindgen.Runtime.CEnum
     Test.HsBindgen.Runtime.CEnumArbitrary
     Test.HsBindgen.Runtime.ConstantArray
-    Test.HsBindgen.Runtime.HighLevel.RefineSmoke
+    Test.HsBindgen.Runtime.HighLevel.CoreDump
+    Test.HsBindgen.Runtime.HighLevel.Test
     Test.HsBindgen.Runtime.IncompleteArray
     Test.HsBindgen.Runtime.SizedByteArray
     Test.Util.Orphans