Skip to content

Commit e2ad807

Browse files
bolt12bolt12
committed
Fourth attempt
1 parent 1312180 commit e2ad807

21 files changed

Lines changed: 2046 additions & 951 deletions

File tree

‎examples/c-qrcode/generate-and-run.sh‎

Lines changed: 16 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -10,11 +10,14 @@ echo "# "
1010
echo "# Building qrcode C bindings"
1111
echo "# "
1212

13-
git submodule init QR-Code-generator
14-
git submodule update QR-Code-generator
15-
16-
cd "$SCRIPT_DIR/QR-Code-generator/c"
17-
make
13+
# Check out the submodule and build the C library only if it is not already
14+
# built. Delete libqrcodegen.a to force a rebuild.
15+
if [ -e "$SCRIPT_DIR/QR-Code-generator/c/libqrcodegen.a" ]; then
16+
echo "# libqrcodegen.a already built, skipping submodule checkout and make"
17+
else
18+
git submodule update --init "$SCRIPT_DIR/QR-Code-generator"
19+
( cd "$SCRIPT_DIR/QR-Code-generator/c" && make )
20+
fi
1821

1922
echo "# "
2023
echo "# Generating Haskell bindings"
@@ -32,28 +35,27 @@ cabal run hs-bindgen-cli -- \
3235
"$SCRIPT_DIR/QR-Code-generator/c/qrcodegen.h"
3336

3437
echo "# "
35-
echo "# Updating cabal.project.local"
38+
echo "# Writing cabal.project.local"
3639
echo "# "
3740

38-
LINE=$(
39-
cat <<-EOF
41+
# cabal.project.local is gitignored and machine-specific, so rewrite it from
42+
# scratch each run rather than appending (which would accumulate stale paths).
43+
cat > "$SCRIPT_DIR/hs-project/cabal.project.local" <<EOF
4044
package c-qrcode
4145
extra-include-dirs:
4246
$SCRIPT_DIR/QR-Code-generator/c/
4347
extra-lib-dirs:
4448
$SCRIPT_DIR/QR-Code-generator/c/
4549
EOF
46-
)
47-
grep -qxF "$LINE" "$SCRIPT_DIR/hs-project/cabal.project.local" || echo "$LINE" >>"$SCRIPT_DIR/hs-project/cabal.project.local"
4850
cat "$SCRIPT_DIR/hs-project/cabal.project.local"
4951

5052
echo "# "
5153
echo "# Done!"
5254
echo "# "
5355
echo "Running the project"
5456

55-
cd $SCRIPT_DIR/hs-project
56-
export LD_LIBRARY_PATH=$SCRIPT_DIR/QR-Code-generator/c/:\$LD_LIBRARY_PATH
57+
cd "$SCRIPT_DIR/hs-project"
58+
export LD_LIBRARY_PATH="$SCRIPT_DIR/QR-Code-generator/c/:$LD_LIBRARY_PATH"
5759

58-
cabal build
59-
cabal run c-qrcode
60+
cabal build exe:c-qrcode
61+
cabal run exe:c-qrcode

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

Lines changed: 36 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,10 @@
11
{-# LANGUAGE TypeApplications #-}
2+
{-# LANGUAGE TypeFamilies #-}
3+
4+
-- The DefaultIn instances for the generated enums below are orphans: the enum types
5+
-- and the class are both defined elsewhere. The natural home is the generated module
6+
-- (ideally hs-bindgen would emit them), so silence the expected warning here.
7+
{-# OPTIONS_GHC -Wno-orphans #-}
28

39
-- | High-level wrappers around the generated qrcodegen bindings.
410
--
@@ -11,21 +17,33 @@ module HighLevel (
1117
import Data.Word (Word8)
1218
import Foreign.Ptr (Ptr)
1319

14-
import HsBindgen.Runtime.HighLevel.ToHighLevel (OutMarshaller, input, output,
15-
pureIn, scratchArray,
16-
toHighLevel)
17-
import HsBindgen.Runtime.HighLevel.ToHighLevel.Defaults (defaultIn, defaultRes)
18-
import HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers (peekIncompleteArrayOut,
19-
withCStringIn,
20-
withConstIncompleteArrayIn)
20+
import HsBindgen.Runtime.HighLevel (output, scratchArray, toHighLevel)
21+
import HsBindgen.Runtime.HighLevel.Defaults (DefaultIn (..), auto)
22+
import HsBindgen.Runtime.HighLevel.Marshaller (Unmarshaller, scalar)
23+
import HsBindgen.Runtime.HighLevel.Marshaller.Utils (peekIncompleteArrayOut)
2124
import HsBindgen.Runtime.IncompleteArray (IncompleteArray)
2225

2326
import QRCodeGenerator.Generated qualified as QR
2427
import QRCodeGenerator.Generated.Safe qualified as QR
2528

26-
-- | Lift @qrcodegen_encodeText@. @tempBuffer@ is a 'scratchArray', so it adds
27-
-- nothing to the result: only the QR code and the success flag come back. The
28-
-- scalar inputs and the result use default marshallers.
29+
-- | Passthrough defaults for the generated enums: each enum is its own C argument
30+
-- type, so the default marshaller is @scalar id@. With these in scope, 'auto' can
31+
-- fill the @ecc@ and @mask@ arguments of 'encodeText'. These are orphan instances;
32+
-- the natural home is alongside the enum in the generated module, so ideally
33+
-- hs-bindgen would emit them.
34+
instance DefaultIn QR.Qrcodegen_Ecc where
35+
type DefInArrow QR.Qrcodegen_Ecc lo = QR.Qrcodegen_Ecc -> lo
36+
defaultIn = scalar id
37+
38+
instance DefaultIn QR.Qrcodegen_Mask where
39+
type DefInArrow QR.Qrcodegen_Mask lo = QR.Qrcodegen_Mask -> lo
40+
defaultIn = scalar id
41+
42+
-- | Lift @qrcodegen_encodeText@. Only the two positions that need a human decision
43+
-- are explicit: @tempBuffer@ is a 'scratchArray' (the callee writes it, the caller
44+
-- never sees it) and @qrcode@ is the 'output' we keep. 'auto' fills the rest from
45+
-- the signature: the leading 'String', then the two enums, the version 'Int's, the
46+
-- boost 'Bool', and the result.
2947
encodeText
3048
:: String
3149
-> QR.Qrcodegen_Ecc
@@ -35,33 +53,22 @@ encodeText
3553
-> Bool
3654
-> IO (IncompleteArray Word8, Bool)
3755
encodeText = toHighLevel
38-
( input withCStringIn
56+
( auto -- text (String)
3957
$ scratchArray @Word8 maxLen -- tempBuffer: written, never read
40-
$ output qrCodeOut
41-
$ input (pureIn id) -- ecc level (enum, passthrough)
42-
$ input defaultIn -- minVersion (Int -> CInt)
43-
$ input defaultIn -- maxVersion (Int -> CInt)
44-
$ input (pureIn id) -- mask (enum, passthrough)
45-
$ input defaultIn -- boostEcl (Bool -> CBool)
46-
$ defaultRes -- CBool -> Bool
58+
$ output qrCodeOut -- qrcode: the out-parameter we keep
59+
$ auto -- ecc, minVersion, maxVersion, mask, boostEcl, result
4760
) QR.qrcodegen_encodeText
4861
where
4962
maxLen :: Int
5063
maxLen = fromIntegral QR.qrcodegen_BUFFER_LEN_MAX
5164

52-
qrCodeOut :: OutMarshaller (Ptr Word8) (IncompleteArray Word8)
65+
qrCodeOut :: Unmarshaller (Ptr Word8) (IncompleteArray Word8)
5366
qrCodeOut = peekIncompleteArrayOut maxLen
5467

68+
-- | Every position is a default ('IncompleteArray' marshals as a @const@ pointer,
69+
-- 'CInt' \/ 'CBool' scalars), so the whole wrapper is 'auto'.
5570
getSize :: IncompleteArray Word8 -> IO Int
56-
getSize = toHighLevel
57-
( input withConstIncompleteArrayIn
58-
$ defaultRes
59-
) QR.qrcodegen_getSize
71+
getSize = toHighLevel auto QR.qrcodegen_getSize
6072

6173
getModule :: IncompleteArray Word8 -> Int -> Int -> IO Bool
62-
getModule = toHighLevel
63-
( input withConstIncompleteArrayIn
64-
$ input defaultIn -- x (Int -> CInt)
65-
$ input defaultIn -- y (Int -> CInt)
66-
$ defaultRes -- CBool -> Bool
67-
) QR.qrcodegen_getModule
74+
getModule = toHighLevel auto QR.qrcodegen_getModule

‎examples/libpcap/generate-and-run.sh‎

Lines changed: 26 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -5,22 +5,33 @@ set -e
55
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
66
PROJECT_ROOT="$(cd "$SCRIPT_DIR/../.." && pwd)"
77
export PROJECT_ROOT
8+
cd "$SCRIPT_DIR"
89

9-
(
10+
# Download and build libpcap only if it is not already built. Delete the
11+
# ./libpcap directory to force a fresh download and rebuild. (The previous
12+
# version unconditionally deleted and re-downloaded, which fails offline and
13+
# throws away an existing build.)
14+
if [ -e libpcap/libpcap.so ]; then
1015
echo "# "
11-
echo "# Building libpcap"
16+
echo "# libpcap already built in ./libpcap, skipping download"
1217
echo "# "
18+
else
19+
(
20+
echo "# "
21+
echo "# Building libpcap"
22+
echo "# "
1323

14-
rm -rfv libpcap*
15-
wget https://www.tcpdump.org/release/libpcap-1.10.5.tar.xz
16-
tar -xf libpcap-1.10.5.tar.xz
17-
mv libpcap-1.10.5 libpcap
18-
rm libpcap-1.10.5.tar.xz
24+
rm -rfv libpcap libpcap-1.10.5 libpcap-1.10.5.tar.xz
25+
wget https://www.tcpdump.org/release/libpcap-1.10.5.tar.xz
26+
tar -xf libpcap-1.10.5.tar.xz
27+
mv libpcap-1.10.5 libpcap
28+
rm libpcap-1.10.5.tar.xz
1929

20-
cd "libpcap"
21-
cmake .
22-
make
23-
)
30+
cd "libpcap"
31+
cmake .
32+
make
33+
)
34+
fi
2435

2536
LIBPCAP_DIR=$(realpath libpcap)
2637

@@ -31,18 +42,18 @@ echo "# "
3142
./generate.sh
3243

3344
echo "# "
34-
echo "# Updating cabal.project.local"
45+
echo "# Writing cabal.project.local"
3546
echo "# "
3647

37-
LINE=$(cat <<-EOF
48+
# cabal.project.local is gitignored and machine-specific, so rewrite it from
49+
# scratch each run rather than appending (which would accumulate stale paths).
50+
cat > "$SCRIPT_DIR/hs-project/cabal.project.local" <<EOF
3851
package libpcap
3952
extra-include-dirs:
4053
$LIBPCAP_DIR
4154
extra-lib-dirs:
4255
$LIBPCAP_DIR
4356
EOF
44-
)
45-
grep -qxF "$LINE" "$SCRIPT_DIR/hs-project/cabal.project.local" || echo "$LINE" >> "$SCRIPT_DIR/hs-project/cabal.project.local"
4657
cat "$SCRIPT_DIR/hs-project/cabal.project.local"
4758

4859
echo "# "

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

Lines changed: 26 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -10,29 +10,28 @@ module HighLevel (
1010
import Control.Exception (Exception, throwIO)
1111
import Control.Monad (when)
1212
import Foreign.C.String qualified as C
13-
import Foreign.C.Types (CInt)
14-
import Foreign.Marshal.Alloc (alloca)
13+
import Foreign.C.Types (CChar, CInt)
14+
import Foreign.Marshal.Alloc (alloca, allocaBytes)
1515
import Foreign.Ptr (Ptr, nullPtr)
1616
import Foreign.Storable (peek)
1717

18-
import HsBindgen.Runtime.HighLevel.ToHighLevel (OutMarshaller, mkOut, output,
19-
resultPure, toHighLevel)
20-
import HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers (peekCStringOut)
18+
import HsBindgen.Runtime.HighLevel (output, resultIO, scratch, toHighLevel)
19+
import HsBindgen.Runtime.HighLevel.Marshaller (Unmarshaller, unmarshalOutWith)
2120

2221
import Generated.Pcap qualified as Pcap
2322
import Generated.Pcap.Safe qualified as Pcap
2423

2524
-- | Thrown by 'findAllDevNames' when @pcap_findalldevs@ reports failure.
2625
--
27-
data PcapError = PcapError { msg :: String, code :: CInt }
26+
data PcapError = PcapError { msg :: String, code :: Int }
2827
deriving stock (Show)
2928
instance Exception PcapError
3029

3130
-- | Allocate a @pcap_if_t **@, walk the linked list after the call, free it.
3231
--
3332
peekPcapDeviceNames
34-
:: OutMarshaller (Ptr (Ptr Pcap.Pcap_if_t)) [String]
35-
peekPcapDeviceNames = mkOut alloca $ \pp -> do
33+
:: Unmarshaller (Ptr (Ptr Pcap.Pcap_if_t)) [String]
34+
peekPcapDeviceNames = unmarshalOutWith alloca $ \pp -> do
3635
headPtr <- peek pp
3736
names <- collect [] headPtr
3837
Pcap.pcap_freealldevs headPtr
@@ -45,16 +44,24 @@ peekPcapDeviceNames = mkOut alloca $ \pp -> do
4544
name <- C.peekCString (Pcap.pcap_if_t_name dev)
4645
collect (name : acc) (Pcap.pcap_if_t_next dev)
4746

48-
-- | Collect the names of all devices visible to libpcap. The status check
49-
-- runs after the spec rather than inside a 'throwOn' because the error
50-
-- buffer lives in a separate output position.
47+
-- | Collect the names of all devices visible to libpcap. @pcap_findalldevs@
48+
-- signals failure with a non-zero status and writes a message into a separate
49+
-- error buffer. The buffer is pre-allocated and passed as 'scratch', so the
50+
-- 'resultIO' closer can read it and throw on failure, keeping the check inside
51+
-- the spec.
5152
--
5253
findAllDevNames :: IO [String]
53-
findAllDevNames = do
54-
(names, errMsg, status) <- toHighLevel
55-
( output peekPcapDeviceNames
56-
$ output (peekCStringOut (fromIntegral Pcap.pCAP_ERRBUF_SIZE))
57-
$ resultPure id
58-
) Pcap.pcap_findalldevs
59-
when (status /= 0) $ throwIO (PcapError errMsg status)
60-
pure names
54+
findAllDevNames =
55+
allocaBytes (fromIntegral Pcap.pCAP_ERRBUF_SIZE) $ \errbuf -> do
56+
(names, ()) <- toHighLevel
57+
( output peekPcapDeviceNames -- pcap_if_t ** : device names (kept)
58+
$ scratch (\k -> k errbuf) -- char * : pre-allocated errbuf
59+
$ resultIO (throwOnStatus errbuf) -- int : throw on failure
60+
) Pcap.pcap_findalldevs
61+
pure names
62+
where
63+
throwOnStatus :: Ptr CChar -> CInt -> IO ()
64+
throwOnStatus errbuf status =
65+
when (status /= 0) $ do
66+
errMsg <- C.peekCString errbuf
67+
throwIO (PcapError errMsg (fromIntegral status))

‎hs-bindgen-runtime/CHANGELOG.md‎

Lines changed: 31 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,36 @@ None
1313
* Add `get`/`set` functions that serve as getters/setters for union values.
1414
These depend `HasField` instances. See [issue #2060][is-2060] and [PR
1515
#2091][pr-2091].
16-
* Add a combinator library for hand-writing high-level wrappers over the
17-
generated low-level FFI bindings.
16+
* Add a combinator library for hand-writing high-level wrappers over the generated
17+
low-level FFI bindings, in modules under `HsBindgen.Runtime.HighLevel`. `Marshaller`
18+
is the marshaller vocabulary: a single `Marshal` arrow marshals a Haskell value into
19+
the C argument(s) it fills (build one with `scalar` or `bracket`, aim it with `at`,
20+
retag between `Ptr` and `PtrConst` with `asConstArg` / `asMutableArg`, compose fields
21+
with `>>>` from the `Category` instance, and embed a sub-struct with `marshalNested`);
22+
a `MarshalStruct` seals a field chain into a whole-struct marshaller, `Unmarshaller`
23+
handles out-parameters, and `UnmarshalStruct` reads C back into Haskell. Optional
24+
values cross the boundary with `marshalOptional` / `unmarshalOptional`. `HighLevel`
25+
lifts a low-level function into a wrapper with `input` / `output` / `scratch` /
26+
`fixed` and a result closer (`resultPure`, `resultIO`, `discardResult`, and the
27+
error-aware `throwOn` / `throwOnNonZero` / `throwOnOut`), and drops a struct
28+
marshaller into a wrapper position with `asArgument` / `asOutput` / `asResult`; a
29+
by-value struct argument is written into a zeroed slot so its padding reaches C as
30+
zeros. Kept outputs accumulate into a flat result tuple (result last, up to eight
31+
components); `simplify` drops the trailing unit a status closer leaves behind, and
32+
`assertPure` exposes a wrapper over a deterministic C call as a pure function.
33+
Ready-made marshallers live in `Marshaller.Utils` (`withCStringIn`,
34+
`useAsByteStringLenIn`, `constByteStringLenIn`, `peekCStringOut`, and `byteStringOut`
35+
for a caller-sized output buffer) and per-type defaults in `Defaults`, where `auto`
36+
fills the mundane input positions and the closer of a wrapper from its high-level
37+
signature (outputs stay explicit via `output`). A `DefaultIn` default is keyed on
38+
both the Haskell type and its C representation, so one Haskell type may serve several:
39+
a `ByteString` fills any `(const T *, len)` byte-buffer pair, a `Maybe` fills a
40+
nullable pointer, a Haskell function fills a callback, and a general identity passes
41+
through any type a wrapper keeps as-is. The Haskell type in the signature picks the
42+
representation in every position, so `auto` closes a wrapper that keeps the C return
43+
type (`IO CInt`) as readily as one that converts it (`IO Int`). The combinators
44+
(including `auto`) carry `INLINE` pragmas and fuse to the raw `alloca` / `poke` /
45+
`peek` at `-O2`. See [PR #2018][pr-2018].
1846

1947
### Minor changes
2048

@@ -27,6 +55,7 @@ None
2755

2856
[is-2060]: https://github.com/well-typed/hs-bindgen/issues/2060
2957
[pr-2091]: https://github.com/well-typed/hs-bindgen/pull/2091
58+
[pr-2018]: https://github.com/well-typed/hs-bindgen/pull/2018
3059

3160
## 0.1.0-alpha2 -- 2026-03-27
3261

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

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -77,10 +77,13 @@ library
7777
HsBindgen.Runtime.FLAM
7878
HsBindgen.Runtime.HasCBitfield
7979
HsBindgen.Runtime.HasCField
80-
HsBindgen.Runtime.HighLevel.ToHighLevel
81-
HsBindgen.Runtime.HighLevel.ToHighLevel.Defaults
82-
HsBindgen.Runtime.HighLevel.ToHighLevel.Errors
83-
HsBindgen.Runtime.HighLevel.ToHighLevel.Marshallers
80+
HsBindgen.Runtime.HighLevel
81+
HsBindgen.Runtime.HighLevel.Defaults
82+
HsBindgen.Runtime.HighLevel.Internal.Errors
83+
HsBindgen.Runtime.HighLevel.Internal.Threading
84+
HsBindgen.Runtime.HighLevel.Marshaller
85+
HsBindgen.Runtime.HighLevel.Marshaller.Utils
86+
HsBindgen.Runtime.HighLevel.Result
8487
HsBindgen.Runtime.IncompleteArray
8588
HsBindgen.Runtime.Internal.Bitfield
8689
HsBindgen.Runtime.Internal.ByteArray
@@ -136,7 +139,7 @@ test-suite test-hs-bindgen-runtime
136139
Test.HsBindgen.Runtime.CEnum
137140
Test.HsBindgen.Runtime.CEnumArbitrary
138141
Test.HsBindgen.Runtime.ConstantArray
139-
Test.HsBindgen.Runtime.HighLevel.CoreDump
142+
Test.HsBindgen.Runtime.HighLevel.Struct
140143
Test.HsBindgen.Runtime.HighLevel.Test
141144
Test.HsBindgen.Runtime.IncompleteArray
142145
Test.HsBindgen.Runtime.SizedByteArray

0 commit comments

Comments
 (0)