Polish second attempt

Author: bolt12

HIGH_LEVEL_DESIGN.md

@@ -0,0 +1,65 @@
+-- | 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.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.
+encodeText
+  :: String
+  -> QR.Qrcodegen_Ecc
+  -> Int
+  -> Int
+  -> QR.Qrcodegen_Mask
+  -> 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)
+  ) 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)
+  ) QR.qrcodegen_getSize
+
+getModule :: IncompleteArray Word8 -> Int -> Int -> IO Bool
+getModule = toHighLevel
+  ( input  withConstIncompleteArrayIn
+  $ input  (pureIn fromIntegral)
+  $ input  (pureIn fromIntegral)
+  $ result (pureRes Marshal.toBool)
+  ) QR.qrcodegen_getModule

HIGH_LEVEL_DESIGN_old.md

@@ -6,25 +6,11 @@ import Control.Monad (guard)
 import Data.Bool (bool)
 import Data.Foldable (for_)
 import Data.Word (Word8)
-import Foreign qualified as F
-import Foreign.C qualified as F
 
-import HsBindgen.Runtime.IncompleteArray qualified as IA
-import HsBindgen.Runtime.IsArray qualified as IsA
-import HsBindgen.Runtime.Prelude
-import HsBindgen.Runtime.PtrConst qualified as PtrConst
+import HsBindgen.Runtime.IncompleteArray (IncompleteArray)
 
+import HighLevel qualified as HL
 import QRCodeGenerator.Generated qualified as QR
-import QRCodeGenerator.Generated.Safe qualified as QR
-
-fromPtr
-  :: forall a .
-    F.Storable a
-  => Int -> F.Ptr a -> IO (IncompleteArray a)
-fromPtr len p = IA.peekArray len p'
-  where
-     p' :: F.Ptr (IncompleteArray a)
-     p' = IA.toPtr p
 
 -- static void printQr(const uint8_t qrcode[]) {
 --  int size = qrcodegen_getSize(qrcode);
@@ -39,41 +25,36 @@ fromPtr len p = IA.peekArray len p'
 -- }
 printQr :: IncompleteArray Word8 -> IO ()
 printQr qrCode = do
-  size <- IsA.withElemPtr qrCode $ \ptr -> QR.qrcodegen_getSize (PtrConst.unsafeFromPtr ptr)
+  size <- HL.getSize qrCode
   let border = 4
       range  = [-border .. size + border - 1]
   for_ range $ \y -> do
     for_ range $ \x -> do
-      str <- bool "  " "██" . F.toBool <$>
-        (IsA.withElemPtr qrCode $ \ptr -> QR.qrcodegen_getModule (PtrConst.unsafeFromPtr ptr) x y)
-      putStr str
+      isOn <- HL.getModule qrCode x y
+      putStr (bool "  " "██" isOn)
     putStr "\n"
   putStr "\n"
 
 -- static void doBasicDemo(void) {
---  const char *text = "Hello, world!";               // User-supplied text
---  enum qrcodegen_Ecc errCorLvl = qrcodegen_Ecc_LOW; // Error correction level
---
---  // Make and print the QR Code symbol
+--  const char *text = "Hello, world!";
+--  enum qrcodegen_Ecc errCorLvl = qrcodegen_Ecc_LOW;
 --  uint8_t qrcode[qrcodegen_BUFFER_LEN_MAX];
 --  uint8_t tempBuffer[qrcodegen_BUFFER_LEN_MAX];
 --  bool ok = qrcodegen_encodeText(text, tempBuffer, qrcode, errCorLvl,
 --    qrcodegen_VERSION_MIN, qrcodegen_VERSION_MAX, qrcodegen_Mask_AUTO, true);
---  if (ok)
---    printQr(qrcode);
+--  if (ok) printQr(qrcode);
 -- }
 basicDemo :: IO ()
 basicDemo = do
-  F.withCAString "Hello, world!" $ \text ->
-    F.allocaArray (fromIntegral QR.qrcodegen_BUFFER_LEN_MAX) $ \tempBuffer -> do
-      F.allocaArray (fromIntegral QR.qrcodegen_BUFFER_LEN_MAX) $ \qrCode -> do
-        b <- QR.qrcodegen_encodeText (PtrConst.unsafeFromPtr text) tempBuffer qrCode QR.Qrcodegen_Ecc_LOW
-                                     QR.qrcodegen_VERSION_MIN QR.qrcodegen_VERSION_MAX
-                                     QR.Qrcodegen_Mask_AUTO (F.fromBool True)
-        qrCodeIA <- IA.peekArray (fromIntegral QR.qrcodegen_BUFFER_LEN_MAX) (IA.toPtr qrCode)
-        guard (F.toBool b)
-        printQr qrCodeIA
+  ((), (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
 
 main :: IO ()
-main = do
-  basicDemo
+main = basicDemo

ISSUE_ANALYSIS.md

@@ -32,6 +32,7 @@ library
 executable c-qrcode
   import:             warnings
   main-is:            Main.hs
+  other-modules:      HighLevel
   build-depends:
     , base
     , c-qrcode

PROPOSAL.md

@@ -0,0 +1,57 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+-- | High-level wrappers around the generated libpcap bindings.
+module HighLevel (
+    PcapError (..)
+  , findAllDevNames
+  ) where
+
+import Control.Exception (Exception, throwIO)
+import Control.Monad (when)
+import Foreign.C.String qualified as C
+import Foreign.C.Types (CInt)
+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 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
+  headPtr <- peek pp
+  names   <- collect [] headPtr
+  Pcap.pcap_freealldevs headPtr
+  pure (names, r)
+  where
+    collect acc ptr
+      | ptr == nullPtr = pure (reverse acc)
+      | otherwise = do
+          dev  <- peek ptr
+          name <- C.peekCString (Pcap.pcap_if_t_name dev)
+          collect (name : acc) (Pcap.pcap_if_t_next dev)
+
+-- | 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
+    ( output peekPcapDeviceNames
+    $ output (peekCStringOut (fromIntegral Pcap.pCAP_ERRBUF_SIZE))
+    $ result (pureRes id)
+    ) Pcap.pcap_findalldevs
+  when (status /= 0) $ throwIO (PcapError errMsg status)
+  pure names