Skip to content

Commit 5ce12d5

Browse files
bolt12bolt12
authored
Merge pull request #1291 from well-typed/bolt12/1255
Organise the manual modules
2 parents c38b64b + 19b6ebe commit 5ce12d5

File tree

14 files changed

+1005
-760
lines changed

14 files changed

+1005
-760
lines changed

‎manual/hs/manual/app/Manual.hs‎

Lines changed: 62 additions & 759 deletions
Large diffs are not rendered by default.

‎manual/hs/manual/app/Manual/BindingSpecifications.hs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
module Manual.BindingSpecifications (examples) where
2+
3+
import Foreign as F
4+
5+
import Manual.Tools
6+
7+
import Game.Player.Safe
8+
import Game.State
9+
import Game.World.Safe
10+
import Vector.Length.Safe
11+
import Vector.Rotate.Safe
12+
import Vector.Safe
13+
14+
{-------------------------------------------------------------------------------
15+
Examples
16+
-------------------------------------------------------------------------------}
17+
18+
examples :: IO ()
19+
examples = do
20+
section "External binding specifications"
21+
22+
v <- new_vector 2 1
23+
print =<< peek v
24+
print =<< vector_length v
25+
v' <- vector_rotate v (30 * pi / 180)
26+
print =<< peek v'
27+
print =<< vector_length v'
28+
29+
move_world $ Game_state nullPtr
30+
move_player $ Game_state nullPtr

‎manual/hs/manual/app/Manual/Functions/FirstOrder.hs‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
module Manual.Functions.FirstOrder (examples) where
4+
5+
import Control.Monad ((<=<))
6+
import Foreign as F
7+
import Foreign.C (withCString)
8+
import Foreign.C qualified as FC
9+
import System.IO.Unsafe
10+
11+
import HsBindgen.Runtime.FunPtr
12+
13+
import Manual.Tools
14+
15+
import Example.Unsafe
16+
import FunctionPointers qualified as FunPtr
17+
import FunctionPointers.FunPtr qualified as FunPtr
18+
import FunctionPointers.Global qualified as FunPtr
19+
import FunctionPointers.Safe qualified as FunPtr
20+
21+
{-------------------------------------------------------------------------------
22+
Function attributes
23+
-------------------------------------------------------------------------------}
24+
25+
hashSafe :: String -> Int
26+
hashSafe s = fromIntegral $ unsafePerformIO $ withCString s hash
27+
28+
{-------------------------------------------------------------------------------
29+
Function pointer instances
30+
-------------------------------------------------------------------------------}
31+
32+
foreign import ccall "dynamic" mkApply1Fun ::
33+
F.FunPtr (F.FunPtr FunPtr.Int2int -> FC.CInt -> IO FC.CInt)
34+
-> F.FunPtr FunPtr.Int2int
35+
-> FC.CInt
36+
-> IO FC.CInt
37+
38+
instance FromFunPtr (F.FunPtr FunPtr.Int2int -> FC.CInt -> IO FC.CInt) where
39+
fromFunPtr = mkApply1Fun
40+
41+
{-------------------------------------------------------------------------------
42+
Examples
43+
-------------------------------------------------------------------------------}
44+
45+
examples :: IO ()
46+
examples = do
47+
section "Function attributes"
48+
49+
withCString "\DC1" $ (print <=< hash)
50+
print (hashSafe "abc")
51+
print (square 2)
52+
53+
section "Function pointers"
54+
55+
print =<< FunPtr.apply1 FunPtr.square_ptr 4
56+
print =<< FunPtr.apply1 FunPtr.square_ptr 5
57+
print =<< FunPtr.apply1 FunPtr.square_ptr 6
58+
59+
print =<< FunPtr.apply2 FunPtr.plus_ptr 7 8
60+
print =<< FunPtr.apply2 FunPtr.plus_ptr 9 10
61+
print =<< FunPtr.apply2 FunPtr.plus_ptr 11 12
62+
63+
subsection "Implicit function to pointer conversion"
64+
do
65+
-- function pointer type in function parameter
66+
print =<< FunPtr.apply1_pointer_arg (F.castFunPtr FunPtr.square_ptr) 4
67+
print =<< FunPtr.apply1_pointer_arg (F.castFunPtr FunPtr.square_ptr) 5
68+
print =<< FunPtr.apply1_pointer_arg (F.castFunPtr FunPtr.square_ptr) 6
69+
70+
-- function type in function parameter
71+
print =<< FunPtr.apply1_nopointer_arg (F.castFunPtr FunPtr.square_ptr) 4
72+
print =<< FunPtr.apply1_nopointer_arg (F.castFunPtr FunPtr.square_ptr) 5
73+
print =<< FunPtr.apply1_nopointer_arg (F.castFunPtr FunPtr.square_ptr) 6
74+
75+
subsubsection "Parameters of function type can occur almost anywhere!"
76+
do -- function type in function result
77+
apply1FunPtr <- FunPtr.apply1_nopointer_res
78+
let apply1Fun = fromFunPtr apply1FunPtr
79+
print =<< apply1Fun (F.castFunPtr FunPtr.square_ptr) 4
80+
do -- function type in global
81+
let apply1FunPtr = FunPtr.apply1_nopointer_var
82+
apply1Fun = fromFunPtr apply1FunPtr
83+
print =<< apply1Fun (F.castFunPtr FunPtr.square_ptr) 5
84+
do -- function type in struct field
85+
let apply1FunPtr = FunPtr.apply1Struct_apply1_nopointer_struct_field FunPtr.apply1_struct
86+
apply1Fun = fromFunPtr apply1FunPtr
87+
print =<< apply1Fun (F.castFunPtr FunPtr.square_ptr) 6
88+
do -- function type in union field
89+
let apply1FunPtr = FunPtr.get_apply1Union_apply1_nopointer_union_field FunPtr.apply1_union
90+
apply1Fun = fromFunPtr apply1FunPtr
91+
print =<< apply1Fun (F.castFunPtr FunPtr.square_ptr) 7

‎manual/hs/manual/app/Manual/Functions/HigherOrder.hs‎

Lines changed: 234 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,234 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
module Manual.Functions.HigherOrder (examples) where
4+
5+
import Control.Monad (when, (>=>))
6+
import Foreign as F
7+
import Foreign.C qualified as FC
8+
9+
import HsBindgen.Runtime.FunPtr
10+
11+
import Manual.Tools
12+
13+
import Callbacks
14+
import Callbacks.Safe
15+
16+
{-------------------------------------------------------------------------------
17+
Instances for nested callback scaling function
18+
-------------------------------------------------------------------------------}
19+
20+
-- Manual instances for nested callback scaling function
21+
foreign import ccall "wrapper" mkScaleFunPtr ::
22+
(FC.CDouble -> FC.CInt -> IO FC.CDouble)
23+
-> IO (F.FunPtr (FC.CDouble -> FC.CInt -> IO FC.CDouble))
24+
25+
foreign import ccall "dynamic" fromScaleFunPtr ::
26+
F.FunPtr (FC.CDouble -> FC.CInt -> IO FC.CDouble)
27+
-> FC.CDouble
28+
-> FC.CInt
29+
-> IO FC.CDouble
30+
31+
instance ToFunPtr (FC.CDouble -> FC.CInt -> IO FC.CDouble) where
32+
toFunPtr = mkScaleFunPtr
33+
34+
instance FromFunPtr (FC.CDouble -> FC.CInt -> IO FC.CDouble) where
35+
fromFunPtr = fromScaleFunPtr
36+
37+
{-------------------------------------------------------------------------------
38+
Examples
39+
-------------------------------------------------------------------------------}
40+
41+
examples :: IO ()
42+
examples = do
43+
section "Callbacks (Passing Haskell functions to C callbacks)"
44+
45+
withToFunPtr (FileOpenedNotification_Deref $ putStrLn "")
46+
(onFileOpened . FileOpenedNotification)
47+
48+
putStrLn ""
49+
withToFunPtr
50+
(ProgressUpdate_Deref $ \progress -> putStrLn $ "Progress: " ++ show progress ++ "%")
51+
(onProgressChanged . ProgressUpdate)
52+
53+
putStrLn ""
54+
withToFunPtr
55+
(DataValidator_Deref $ \value -> do
56+
putStrLn $ "Validating: " ++ show value
57+
return $ if value > 0 then 1 else 0)
58+
$ (\validator -> do
59+
result1 <- validateInput validator 50
60+
result2 <- validateInput validator (-10)
61+
putStrLn $ "Validation results: " ++ show result1 ++ ", " ++ show result2
62+
) . DataValidator
63+
64+
putStrLn ""
65+
withToFunPtr
66+
(MeasurementReceived_Deref $ peek >=> print)
67+
(onNewMeasurement . MeasurementReceived)
68+
69+
putStrLn ""
70+
subsection "Nested callbacks"
71+
72+
alloca $ \measurementPtr -> do
73+
poke measurementPtr $ Measurement { measurement_value = 100.0, measurement_timestamp = 1.0 }
74+
75+
transformerFunPtr <- toFunPtr $ \mPtr innerScaleFunPtr factor -> do
76+
m <- peek mPtr
77+
putStrLn $ " Transforming measurement: " ++ show (measurement_value m) ++ ", factor=" ++ show factor
78+
newValue <- if innerScaleFunPtr == F.nullFunPtr
79+
then do
80+
putStrLn " (Scaling function was NULL, using direct multiplication)"
81+
return $ measurement_value m * fromIntegral factor
82+
else do
83+
putStrLn " (Using provided scaling function)"
84+
let scaleFun = fromFunPtr innerScaleFunPtr
85+
scaleFun (measurement_value m) factor
86+
poke mPtr $ m { measurement_value = newValue }
87+
putStrLn $ " New value: " ++ show newValue
88+
89+
putStrLn "Testing transformMeasurement with nested callbacks:"
90+
transformMeasurement measurementPtr transformerFunPtr
91+
92+
finalMeasurement <- peek measurementPtr
93+
putStrLn $ "Final measurement: " ++ show finalMeasurement
94+
95+
putStrLn ""
96+
alloca $ \measurementPtr -> do
97+
poke measurementPtr $ Measurement { measurement_value = 42.0, measurement_timestamp = 2.0 }
98+
99+
handlerFunPtr <- toFunPtr $ \(mPtr :: Ptr Measurement)
100+
(notify :: FileOpenedNotification)
101+
(priority :: FC.CInt) -> do
102+
m <- peek mPtr
103+
putStrLn $ " Handler called: value=" ++ show (measurement_value m)
104+
++ ", priority=" ++ show priority
105+
if un_FileOpenedNotification notify /= F.nullFunPtr
106+
then do
107+
let (FileOpenedNotification_Deref notifyFn) = fromFunPtr (un_FileOpenedNotification notify)
108+
notifyFn
109+
else putStrLn " (Notification callback was NULL)"
110+
111+
putStrLn "Testing processWithCallbacks with multiple callbacks:"
112+
processWithCallbacks handlerFunPtr
113+
114+
putStrLn ""
115+
subsection "Callbacks with structs and unions"
116+
117+
putStrLn ""
118+
-- Test MeasurementHandler struct (struct with function pointers)
119+
putStrLn "Testing registerHandler (struct with multiple function pointers):"
120+
alloca $ \handlerPtr -> do
121+
onReceivedFunPtr <- toFunPtr $ \mPtr -> do
122+
m <- peek mPtr
123+
putStrLn $ " [onReceived] Measurement: " ++ show (measurement_value m)
124+
125+
validateFunPtr <- toFunPtr $ \mPtr -> do
126+
m <- peek mPtr
127+
let isValid = measurement_value m > 0
128+
putStrLn $ " [validate] Measurement value " ++ show (measurement_value m)
129+
++ " is " ++ (if isValid then "valid" else "invalid")
130+
return $ if isValid then 1 else 0
131+
132+
onErrorFunPtr <- toFunPtr $ \errorCode -> do
133+
putStrLn $ " [onError] Error code: " ++ show errorCode
134+
135+
poke handlerPtr $ MeasurementHandler
136+
{ measurementHandler_onReceived = onReceivedFunPtr
137+
, measurementHandler_validate = validateFunPtr
138+
, measurementHandler_onError = onErrorFunPtr
139+
}
140+
141+
registerHandler handlerPtr
142+
143+
putStrLn ""
144+
-- Test DataPipeline struct (struct with nested callback types)
145+
putStrLn "Testing executePipeline (struct with nested function pointer types):"
146+
alloca $ \measurementPtr -> do
147+
poke measurementPtr $ Measurement { measurement_value = 50.0, measurement_timestamp = 3.0 }
148+
149+
alloca $ \pipelinePtr -> do
150+
preProcessFunPtr <- toFunPtr $ \mPtr validator -> do
151+
m <- peek mPtr
152+
putStrLn $ " [preProcess] Processing measurement: " ++ show (measurement_value m)
153+
putStrLn $ " [preProcess] Validator present: " ++ show (un_DataValidator validator /= F.nullFunPtr)
154+
155+
processFunPtr <- toFunPtr $ \mPtr -> do
156+
m <- peek mPtr
157+
let newValue = measurement_value m * 2
158+
poke mPtr $ m { measurement_value = newValue }
159+
putStrLn $ " [process] Doubled value to: " ++ show newValue
160+
161+
postProcessFunPtr <- toFunPtr $ \mPtr progressUpdate -> do
162+
m <- peek mPtr
163+
putStrLn $ " [postProcess] Final value: " ++ show (measurement_value m)
164+
putStrLn $ " [postProcess] ProgressUpdate present: " ++ show (un_ProgressUpdate progressUpdate /= F.nullFunPtr)
165+
166+
poke pipelinePtr $ DataPipeline
167+
{ dataPipeline_preProcess = preProcessFunPtr
168+
, dataPipeline_process = processFunPtr
169+
, dataPipeline_postProcess = postProcessFunPtr
170+
}
171+
172+
executePipeline measurementPtr pipelinePtr
173+
finalMeasurement <- peek measurementPtr
174+
putStrLn $ " Final measurement after pipeline: " ++ show finalMeasurement
175+
176+
putStrLn ""
177+
-- Test Processor struct (union with function pointers)
178+
putStrLn "Testing runProcessor (struct with union of function pointers):"
179+
alloca $ \measurementPtr -> do
180+
poke measurementPtr $ Measurement { measurement_value = 25.0, measurement_timestamp = 4.0 }
181+
182+
-- Test MODE_SIMPLE
183+
alloca $ \processorPtr -> do
184+
simpleFunPtr <- toFunPtr $ \mPtr -> do
185+
m <- peek mPtr
186+
putStrLn $ " [simple] Processing: " ++ show (measurement_value m)
187+
188+
let callback = set_processorCallback_simple simpleFunPtr
189+
poke processorPtr $ Processor
190+
{ processor_mode = MODE_SIMPLE
191+
, processor_callback = callback
192+
}
193+
194+
putStrLn " Testing MODE_SIMPLE:"
195+
runProcessor measurementPtr processorPtr
196+
197+
-- Test MODE_VALIDATED
198+
alloca $ \processorPtr -> do
199+
validatedFunPtr <- toFunPtr $ \mPtr validator -> do
200+
m <- peek mPtr
201+
putStrLn $ " [withValidator] Processing: " ++ show (measurement_value m)
202+
putStrLn $ " [withValidator] Validator present: " ++ show (un_DataValidator validator /= F.nullFunPtr)
203+
204+
let callback = set_processorCallback_withValidator validatedFunPtr
205+
poke processorPtr $ Processor
206+
{ processor_mode = MODE_VALIDATED
207+
, processor_callback = callback
208+
}
209+
210+
putStrLn " Testing MODE_VALIDATED:"
211+
runProcessor measurementPtr processorPtr
212+
213+
putStrLn ""
214+
subsection "Third-order callbacks"
215+
216+
-- Test processMeasurementWithValidation (deeply nested callbacks)
217+
putStrLn "Testing processMeasurementWithValidation (third-order function):"
218+
alloca $ \measurementPtr -> do
219+
poke measurementPtr $ Measurement { measurement_value = 75.0, measurement_timestamp = 5.0 }
220+
221+
processorFunPtr <- toFunPtr $ \mPtr transformerFunPtr validatorFunPtr -> do
222+
m <- peek mPtr
223+
putStrLn $ " [processor] Processing measurement: " ++ show (measurement_value m)
224+
putStrLn $ " [processor] Transformer present: " ++ show (transformerFunPtr /= F.nullFunPtr)
225+
putStrLn $ " [processor] Validator present: " ++ show (un_DataValidator validatorFunPtr /= F.nullFunPtr)
226+
227+
when (transformerFunPtr /= F.nullFunPtr) $ do
228+
let transformerFun = fromFunPtr transformerFunPtr
229+
transformerFun mPtr validatorFunPtr 10
230+
231+
processMeasurementWithValidation measurementPtr processorFunPtr
232+
233+
finalMeasurement <- peek measurementPtr
234+
putStrLn $ " Final measurement: " ++ show finalMeasurement

‎manual/hs/manual/app/Manual/GeneratedNames.hs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE CPP #-}
2+
3+
module Manual.GeneratedNames (examples) where
4+
5+
import Manual.Tools
6+
7+
import Example.Unsafe
8+
9+
{-------------------------------------------------------------------------------
10+
Examples
11+
-------------------------------------------------------------------------------}
12+
13+
examples :: IO ()
14+
examples = do
15+
section "Awkward names"
16+
17+
-- There's a quirk with Apple assembler and LLVM IR that do not accept
18+
-- Unicode characters. So make sure to set SUPPORTS_UNICODE environment
19+
-- variable only if you know your system supports it.
20+
#if defined(SUPPORTS_UNICODE)
21+
-- On supporting platforms, call the functions with Unicode names.
22+
拜拜
23+
cϒ
24+
#else
25+
-- On macOS/LLVM (e.g.), call the safe functions defined in your bindings module.
26+
-- We assume they are named `gamma` and `byeBye` in Haskell.
27+
byeBye
28+
gamma
29+
#endif
30+
31+
import'

0 commit comments

Comments
 (0)