{-# LANGUAGE ForeignFunctionInterface #-}

-- | Producing 'FunPtr' callbacks from Haskell closures, and a ready-made
-- multithreaded task system.
--
-- The generated bindings take callbacks as raw @'FunPtr' Tag@ (see
-- "Box2D.Tags"); this module is the hand-written counterpart that turns an
-- ordinary Haskell function into such a 'FunPtr' via @foreign import "wrapper"@,
-- and frees it again. Every @mk*@ returns a 'FunPtr' the caller must
-- 'freeHaskellFunPtr' (use the @with*@ brackets to get that for free).
--
-- == Threads
--
-- Box2D invokes these callbacks from its solver, which runs on background
-- worker threads when @worldDefWorkerCount@ > 1 — either its own scheduler, or
-- the 'TaskSystem' installed here. A Haskell closure wrapped as a 'FunPtr' is
-- therefore entered concurrently from several non-Haskell OS threads, so the
-- program must be built with the threaded runtime (@-threaded@) and the
-- closure must be thread-safe. Because the solver's task work re-enters Haskell
-- through these callbacks, the task dispatch is a @safe@ call.
module Box2D.Callbacks
  ( -- * Leaf callbacks
    CustomFilter
  , mkCustomFilterFcn
  , withCustomFilterFcn
  , Friction
  , mkFrictionCallback
  , withFrictionCallback
  , Restitution
  , mkRestitutionCallback
  , withRestitutionCallback

    -- * Query and cast visitors
  , OverlapResult
  , withOverlapResultFcn
  , CastResult
  , withCastResultFcn
  , PreSolve
  , withPreSolveFcn
  , PlaneResultVisitor
  , withPlaneResultFcn

    -- * Dynamic-tree visitors
  , TreeQuery
  , withTreeQueryFcn
  , TreeRayCast
  , withTreeRayCastFcn
  , TreeBoxCast
  , withTreeBoxCastFcn

    -- * A multithreaded task system
  , TaskSystem (..)
  , withThreadPoolTaskSystem
  ) where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (bracket, finally)
import Foreign
import Foreign.C.Types (CBool (..), CInt (..))

import Box2D.Id (ShapeId (..))
import Box2D.MathTypes (Pos, Vec2)
import Box2D.Tags
  ( BoxCastInput
  , CastResultFcn
  , CustomFilterFcn
  , FrictionCallback
  , OverlapResultFcn
  , PlaneResultFcn
  , PreSolveFcn
  , RestitutionCallback
  , TreeBoxCastCallbackFcn
  , TreeQueryCallbackFcn
  , TreeRayCastCallbackFcn
  )
import Box2D.Types (EnqueueTaskCallback, FinishTaskCallback, PlaneResult, RayCastInput)

-- Leaf callbacks ----------------------------------------------------------

-- | Decide whether two shapes should collide (see
-- 'Box2D.World.setCustomFilterCallback'). The 'Ptr' is the user context.
type CustomFilter = ShapeId -> ShapeId -> Ptr () -> IO Bool

type CustomFilterC = ShapeId -> ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapCustomFilter :: CustomFilterC -> IO (FunPtr CustomFilterC)

-- | Wrap a Haskell predicate as a custom-filter callback. Free it with
-- 'freeHaskellFunPtr' when the world no longer references it.
mkCustomFilterFcn :: CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn :: CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn CustomFilter
f =
  FunPtr CustomFilterC -> FunPtr CustomFilterFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr CustomFilterC -> FunPtr CustomFilterFcn)
-> IO (FunPtr CustomFilterC) -> IO (FunPtr CustomFilterFcn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomFilterC -> IO (FunPtr CustomFilterC)
wrapCustomFilter (\ShapeId
a ShapeId
b Ptr ()
ctx -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomFilter
f ShapeId
a ShapeId
b Ptr ()
ctx)

-- | Run an action with a custom-filter callback that is freed on exit.
withCustomFilterFcn :: CustomFilter -> (FunPtr CustomFilterFcn -> IO a) -> IO a
withCustomFilterFcn :: forall a. CustomFilter -> (FunPtr CustomFilterFcn -> IO a) -> IO a
withCustomFilterFcn CustomFilter
f = IO (FunPtr CustomFilterFcn)
-> (FunPtr CustomFilterFcn -> IO ())
-> (FunPtr CustomFilterFcn -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn CustomFilter
f) FunPtr CustomFilterFcn -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- | Combine the friction of two materials (see
-- 'Box2D.World.setFrictionCallback'): @frictionA userMatA frictionB userMatB@.
type Friction = Float -> Word64 -> Float -> Word64 -> IO Float

foreign import ccall "wrapper"
  wrapFriction :: Friction -> IO (FunPtr Friction)

-- | Wrap a Haskell function as a friction-mixing callback.
mkFrictionCallback :: Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback :: Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback Friction
f = FunPtr Friction -> FunPtr FrictionCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr Friction -> FunPtr FrictionCallback)
-> IO (FunPtr Friction) -> IO (FunPtr FrictionCallback)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Friction -> IO (FunPtr Friction)
wrapFriction Friction
f

-- | Run an action with a friction callback that is freed on exit.
withFrictionCallback :: Friction -> (FunPtr FrictionCallback -> IO a) -> IO a
withFrictionCallback :: forall a. Friction -> (FunPtr FrictionCallback -> IO a) -> IO a
withFrictionCallback Friction
f = IO (FunPtr FrictionCallback)
-> (FunPtr FrictionCallback -> IO ())
-> (FunPtr FrictionCallback -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback Friction
f) FunPtr FrictionCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- | Combine the restitution of two materials (see
-- 'Box2D.World.setRestitutionCallback'); same shape as 'Friction'.
type Restitution = Float -> Word64 -> Float -> Word64 -> IO Float

foreign import ccall "wrapper"
  wrapRestitution :: Restitution -> IO (FunPtr Restitution)

-- | Wrap a Haskell function as a restitution-mixing callback.
mkRestitutionCallback :: Restitution -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback :: Friction -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback Friction
f = FunPtr Friction -> FunPtr RestitutionCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr Friction -> FunPtr RestitutionCallback)
-> IO (FunPtr Friction) -> IO (FunPtr RestitutionCallback)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Friction -> IO (FunPtr Friction)
wrapRestitution Friction
f

-- | Run an action with a restitution callback that is freed on exit.
withRestitutionCallback :: Restitution -> (FunPtr RestitutionCallback -> IO a) -> IO a
withRestitutionCallback :: forall a. Friction -> (FunPtr RestitutionCallback -> IO a) -> IO a
withRestitutionCallback Friction
f = IO (FunPtr RestitutionCallback)
-> (FunPtr RestitutionCallback -> IO ())
-> (FunPtr RestitutionCallback -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Friction -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback Friction
f) FunPtr RestitutionCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- Query and cast visitors --------------------------------------------------
--
-- The cast and pre-solve callbacks receive b2Pos/b2Vec2 arguments *by value*,
-- which a GHC "wrapper" cannot accept. Each of those routes through a fixed C
-- trampoline (see box2d_shim.h) that takes the structs by value and forwards
-- pointers to the Haskell closure, carried in an hs_b2Closure context.

-- | Overlap query visitor: called for each shape found; return 'True' to
-- continue the query.
type OverlapResult = ShapeId -> IO Bool

type OverlapResultC = ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapOverlapResult :: OverlapResultC -> IO (FunPtr OverlapResultC)

-- | Run an action with an overlap visitor and the context to pass alongside
-- it (e.g. to 'Box2D.World.overlapAABB'); both are released on exit.
withOverlapResultFcn :: OverlapResult -> (FunPtr OverlapResultFcn -> Ptr () -> IO a) -> IO a
withOverlapResultFcn :: forall a.
OverlapResult
-> (FunPtr OverlapResultFcn -> Ptr () -> IO a) -> IO a
withOverlapResultFcn OverlapResult
f FunPtr OverlapResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr OverlapResultC)
-> (FunPtr OverlapResultC -> IO ())
-> (FunPtr OverlapResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (OverlapResultC -> IO (FunPtr OverlapResultC)
wrapOverlapResult (\ShapeId
s Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OverlapResult
f ShapeId
s)) FunPtr OverlapResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr OverlapResultC -> IO a) -> IO a)
-> (FunPtr OverlapResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr OverlapResultC
p ->
    FunPtr OverlapResultFcn -> Ptr () -> IO a
act (FunPtr OverlapResultC -> FunPtr OverlapResultFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr OverlapResultC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Cast visitor: called for each shape a world ray\/shape cast finds, with
-- the hit point, normal and fraction. The returned fraction controls the
-- query: 0 terminates, the given fraction clips the ray, 1 continues.
type CastResult = ShapeId -> Pos -> Vec2 -> Float -> IO Float

type CastResultC = ShapeId -> Ptr Pos -> Ptr Vec2 -> Float -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapCastResult :: CastResultC -> IO (FunPtr CastResultC)

foreign import ccall unsafe "&hs_b2CastResultTrampoline"
  p_castResultTrampoline :: FunPtr CastResultFcn

-- | Run an action with a cast visitor and the context to pass alongside it
-- (e.g. to 'Box2D.World.castRay'); both are released on exit.
withCastResultFcn :: CastResult -> (FunPtr CastResultFcn -> Ptr () -> IO a) -> IO a
withCastResultFcn :: forall a.
CastResult -> (FunPtr CastResultFcn -> Ptr () -> IO a) -> IO a
withCastResultFcn CastResult
f FunPtr CastResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr CastResultC)
-> (FunPtr CastResultC -> IO ())
-> (FunPtr CastResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CastResultC -> IO (FunPtr CastResultC)
wrapCastResult CastResultC
forall {p}. ShapeId -> Ptr Pos -> Ptr Pos -> Float -> p -> IO Float
go) FunPtr CastResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr CastResultC -> IO a) -> IO a)
-> (FunPtr CastResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr CastResultC
hsFn ->
    FunPtr (ZonkAny 5) -> (Ptr () -> IO a) -> IO a
forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure (FunPtr CastResultC -> FunPtr (ZonkAny 5)
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr CastResultC
hsFn) ((Ptr () -> IO a) -> IO a) -> (Ptr () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ FunPtr CastResultFcn -> Ptr () -> IO a
act FunPtr CastResultFcn
p_castResultTrampoline
  where
    go :: ShapeId -> Ptr Pos -> Ptr Pos -> Float -> p -> IO Float
go ShapeId
sid Ptr Pos
pPoint Ptr Pos
pNormal Float
frac p
_ctx = do
      point <- Ptr Pos -> IO Pos
forall a. Storable a => Ptr a -> IO a
peek Ptr Pos
pPoint
      normal <- peek pNormal
      f sid point normal frac

-- | Contact gate, called after narrow phase but before the solver: return
-- 'False' to disable the contact. Fired from solver worker threads when the
-- world is multithreaded, so it must be thread-safe. Requires
-- @shapeDefEnablePreSolveEvents@ on the shapes.
type PreSolve = ShapeId -> ShapeId -> Pos -> Vec2 -> IO Bool

type PreSolveC = ShapeId -> ShapeId -> Ptr Pos -> Ptr Vec2 -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapPreSolve :: PreSolveC -> IO (FunPtr PreSolveC)

foreign import ccall unsafe "&hs_b2PreSolveTrampoline"
  p_preSolveTrampoline :: FunPtr PreSolveFcn

-- | Run an action with a pre-solve gate and the context to pass alongside it
-- (to 'Box2D.World.setPreSolveCallback'). Unhook the callback from the world
-- before the action returns: both are released on exit.
withPreSolveFcn :: PreSolve -> (FunPtr PreSolveFcn -> Ptr () -> IO a) -> IO a
withPreSolveFcn :: forall a.
PreSolve -> (FunPtr PreSolveFcn -> Ptr () -> IO a) -> IO a
withPreSolveFcn PreSolve
f FunPtr PreSolveFcn -> Ptr () -> IO a
act =
  IO (FunPtr PreSolveC)
-> (FunPtr PreSolveC -> IO ())
-> (FunPtr PreSolveC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (PreSolveC -> IO (FunPtr PreSolveC)
wrapPreSolve PreSolveC
forall {b} {p}.
Num b =>
ShapeId -> ShapeId -> Ptr Pos -> Ptr Pos -> p -> IO b
go) FunPtr PreSolveC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr PreSolveC -> IO a) -> IO a)
-> (FunPtr PreSolveC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr PreSolveC
hsFn ->
    FunPtr (ZonkAny 4) -> (Ptr () -> IO a) -> IO a
forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure (FunPtr PreSolveC -> FunPtr (ZonkAny 4)
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr PreSolveC
hsFn) ((Ptr () -> IO a) -> IO a) -> (Ptr () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ FunPtr PreSolveFcn -> Ptr () -> IO a
act FunPtr PreSolveFcn
p_preSolveTrampoline
  where
    go :: ShapeId -> ShapeId -> Ptr Pos -> Ptr Pos -> p -> IO b
go ShapeId
a ShapeId
b Ptr Pos
pPoint Ptr Pos
pNormal p
_ctx = do
      point <- Ptr Pos -> IO Pos
forall a. Storable a => Ptr a -> IO a
peek Ptr Pos
pPoint
      normal <- peek pNormal
      fromBool <$> f a b point normal

-- | Mover collision visitor: one collision plane per convex shape the mover
-- capsule touches (see 'Box2D.World.collideMover'); return 'True' to keep
-- gathering planes.
type PlaneResultVisitor = ShapeId -> PlaneResult -> IO Bool

type PlaneResultC = ShapeId -> Ptr PlaneResult -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapPlaneResult :: PlaneResultC -> IO (FunPtr PlaneResultC)

-- | Run an action with a mover-plane visitor and the context to pass
-- alongside it (to 'Box2D.World.collideMover'); both are released on exit.
withPlaneResultFcn :: PlaneResultVisitor -> (FunPtr PlaneResultFcn -> Ptr () -> IO a) -> IO a
withPlaneResultFcn :: forall a.
PlaneResultVisitor
-> (FunPtr PlaneResultFcn -> Ptr () -> IO a) -> IO a
withPlaneResultFcn PlaneResultVisitor
f FunPtr PlaneResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr PlaneResultC)
-> (FunPtr PlaneResultC -> IO ())
-> (FunPtr PlaneResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (PlaneResultC -> IO (FunPtr PlaneResultC)
wrapPlaneResult PlaneResultC
forall {b} {p}. Num b => ShapeId -> Ptr PlaneResult -> p -> IO b
go) FunPtr PlaneResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr PlaneResultC -> IO a) -> IO a)
-> (FunPtr PlaneResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr PlaneResultC
p ->
    FunPtr PlaneResultFcn -> Ptr () -> IO a
act (FunPtr PlaneResultC -> FunPtr PlaneResultFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr PlaneResultC
p) Ptr ()
forall a. Ptr a
nullPtr
  where
    go :: ShapeId -> Ptr PlaneResult -> p -> IO b
go ShapeId
sid Ptr PlaneResult
pPlane p
_ctx = do
      plane <- Ptr PlaneResult -> IO PlaneResult
forall a. Storable a => Ptr a -> IO a
peek Ptr PlaneResult
pPlane
      fromBool <$> f sid plane

-- Dynamic-tree visitors -----------------------------------------------------

-- | Tree query visitor: @proxyId userData@; return 'True' to continue the
-- query.
type TreeQuery = CInt -> Word64 -> IO Bool

type TreeQueryC = CInt -> Word64 -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapTreeQuery :: TreeQueryC -> IO (FunPtr TreeQueryC)

-- | Run an action with a tree-query visitor and the context to pass alongside
-- it (to 'Box2D.DynamicTree.query'); both are released on exit.
withTreeQueryFcn :: TreeQuery -> (FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryFcn :: forall a.
TreeQuery
-> (FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryFcn TreeQuery
f FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeQueryC)
-> (FunPtr TreeQueryC -> IO ())
-> (FunPtr TreeQueryC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeQueryC -> IO (FunPtr TreeQueryC)
wrapTreeQuery (\CInt
i Word64
u Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeQuery
f CInt
i Word64
u)) FunPtr TreeQueryC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeQueryC -> IO a) -> IO a)
-> (FunPtr TreeQueryC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeQueryC
p ->
    FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeQueryC -> FunPtr TreeQueryCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeQueryC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Tree ray-cast visitor: the (possibly clipped) input, @proxyId@ and
-- @userData@. The returned fraction controls the query: 0 terminates, the
-- given fraction clips the ray, 1 continues.
type TreeRayCast = RayCastInput -> CInt -> Word64 -> IO Float

type TreeRayCastC = Ptr RayCastInput -> CInt -> Word64 -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapTreeRayCast :: TreeRayCastC -> IO (FunPtr TreeRayCastC)

-- | Run an action with a tree ray-cast visitor and the context to pass
-- alongside it (to 'Box2D.DynamicTree.rayCast'); both are released on exit.
withTreeRayCastFcn :: TreeRayCast -> (FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeRayCastFcn :: forall a.
TreeRayCast
-> (FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeRayCastFcn TreeRayCast
f FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeRayCastC)
-> (FunPtr TreeRayCastC -> IO ())
-> (FunPtr TreeRayCastC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeRayCastC -> IO (FunPtr TreeRayCastC)
wrapTreeRayCast TreeRayCastC
forall {p}. Ptr RayCastInput -> CInt -> Word64 -> p -> IO Float
go) FunPtr TreeRayCastC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeRayCastC -> IO a) -> IO a)
-> (FunPtr TreeRayCastC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeRayCastC
p ->
    FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeRayCastC -> FunPtr TreeRayCastCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeRayCastC
p) Ptr ()
forall a. Ptr a
nullPtr
  where
    go :: Ptr RayCastInput -> CInt -> Word64 -> p -> IO Float
go Ptr RayCastInput
pInput CInt
i Word64
u p
_ctx = do
      input <- Ptr RayCastInput -> IO RayCastInput
forall a. Storable a => Ptr a -> IO a
peek Ptr RayCastInput
pInput
      f input i u

-- | Tree box-cast visitor. The input stays a raw 'Ptr' ('BoxCastInput' has no
-- 'Storable' yet: it embeds a 'Box2D.Tags.ShapeProxy' point array).
type TreeBoxCast = Ptr BoxCastInput -> CInt -> Word64 -> IO Float

type TreeBoxCastC = Ptr BoxCastInput -> CInt -> Word64 -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapTreeBoxCast :: TreeBoxCastC -> IO (FunPtr TreeBoxCastC)

-- | Run an action with a tree box-cast visitor and the context to pass
-- alongside it (to 'Box2D.DynamicTree.boxCast'); both are released on exit.
withTreeBoxCastFcn :: TreeBoxCast -> (FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeBoxCastFcn :: forall a.
TreeBoxCast
-> (FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeBoxCastFcn TreeBoxCast
f FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeBoxCastC)
-> (FunPtr TreeBoxCastC -> IO ())
-> (FunPtr TreeBoxCastC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeBoxCastC -> IO (FunPtr TreeBoxCastC)
wrapTreeBoxCast (\Ptr BoxCastInput
p CInt
i Word64
u Ptr ()
_ -> TreeBoxCast
f Ptr BoxCastInput
p CInt
i Word64
u)) FunPtr TreeBoxCastC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeBoxCastC -> IO a) -> IO a)
-> (FunPtr TreeBoxCastC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeBoxCastC
p ->
    FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeBoxCastC -> FunPtr TreeBoxCastCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeBoxCastC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Allocate the two-pointer @hs_b2Closure@ a trampoline dereferences: the
-- Haskell-wrapped function and the user context it should receive.
withClosure :: FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure :: forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure FunPtr a
fn Ptr () -> IO b
act =
  Int -> (Ptr (ZonkAny 3) -> IO b) -> IO b
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sz) ((Ptr (ZonkAny 3) -> IO b) -> IO b)
-> (Ptr (ZonkAny 3) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 3)
p -> do
    Ptr (ZonkAny 3) -> Int -> Ptr (ZonkAny 0) -> IO ()
forall b. Ptr b -> Int -> Ptr (ZonkAny 0) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (ZonkAny 3)
p Int
0 (FunPtr a -> Ptr (ZonkAny 0)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr a
fn)
    Ptr (ZonkAny 3) -> Int -> Ptr (ZonkAny 1) -> IO ()
forall b. Ptr b -> Int -> Ptr (ZonkAny 1) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (ZonkAny 3)
p Int
sz Ptr (ZonkAny 1)
forall a. Ptr a
nullPtr
    Ptr () -> IO b
act (Ptr (ZonkAny 3) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr (ZonkAny 3)
p)
  where
    sz :: Int
sz = Ptr (ZonkAny 2) -> Int
forall a. Storable a => a -> Int
sizeOf Ptr (ZonkAny 2)
forall a. Ptr a
nullPtr

-- A multithreaded task system --------------------------------------------

-- | The two callbacks (ready to poke into @worldDefEnqueueTask@ /
-- @worldDefFinishTask@) plus the worker count to set on @worldDefWorkerCount@.
data TaskSystem = TaskSystem
  { TaskSystem -> FunPtr EnqueueTaskCallback
taskEnqueue     :: FunPtr EnqueueTaskCallback
  , TaskSystem -> FunPtr FinishTaskCallback
taskFinish      :: FunPtr FinishTaskCallback
  , TaskSystem -> Int
taskWorkerCount :: Int
  }

-- The engine's per-task work function: @void b2TaskCallback(void* taskContext)@.
type TaskC = Ptr () -> IO ()

-- Calling it re-enters Haskell (the solver work invokes our other callbacks),
-- so it must be a `safe` call.
foreign import ccall safe "dynamic"
  callTask :: FunPtr TaskC -> TaskC

type EnqueueC = FunPtr TaskC -> Ptr () -> Ptr () -> IO (Ptr ())
type FinishC = Ptr () -> Ptr () -> IO ()

foreign import ccall "wrapper" wrapEnqueue :: EnqueueC -> IO (FunPtr EnqueueC)
foreign import ccall "wrapper" wrapFinish :: FinishC -> IO (FunPtr FinishC)

-- | Install a Haskell thread-pool task system for the duration of an action,
-- so the Box2D solver runs across the threaded runtime's capabilities. Set
-- @worldDefWorkerCount@, @worldDefEnqueueTask@ and @worldDefFinishTask@ from the
-- 'TaskSystem' before creating the world.
--
-- Each enqueued task is run on a fresh 'forkIO' thread; @finishTask@ joins it.
-- The task's handle travels through the engine as a 'StablePtr' to its join
-- 'MVar'. Requires @-threaded@.
withThreadPoolTaskSystem :: Int -> (TaskSystem -> IO a) -> IO a
withThreadPoolTaskSystem :: forall a. Int -> (TaskSystem -> IO a) -> IO a
withThreadPoolTaskSystem Int
workers TaskSystem -> IO a
act =
  IO (FunPtr EnqueueC)
-> (FunPtr EnqueueC -> IO ()) -> (FunPtr EnqueueC -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (EnqueueC -> IO (FunPtr EnqueueC)
wrapEnqueue EnqueueC
enqueue) FunPtr EnqueueC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr EnqueueC -> IO a) -> IO a)
-> (FunPtr EnqueueC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr EnqueueC
enq ->
    IO (FunPtr FinishC)
-> (FunPtr FinishC -> IO ()) -> (FunPtr FinishC -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FinishC -> IO (FunPtr FinishC)
wrapFinish FinishC
finish) FunPtr FinishC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr FinishC -> IO a) -> IO a)
-> (FunPtr FinishC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr FinishC
fin ->
      TaskSystem -> IO a
act
        TaskSystem
          { taskEnqueue :: FunPtr EnqueueTaskCallback
taskEnqueue = FunPtr EnqueueC -> FunPtr EnqueueTaskCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr EnqueueC
enq
          , taskFinish :: FunPtr FinishTaskCallback
taskFinish = FunPtr FinishC -> FunPtr FinishTaskCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr FinishC
fin
          , taskWorkerCount :: Int
taskWorkerCount = Int
workers
          }
  where
    enqueue :: EnqueueC
    enqueue :: EnqueueC
enqueue FunPtr TaskC
task Ptr ()
taskCtx Ptr ()
_userCtx = do
      done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      _ <- forkIO (callTask task taskCtx `finally` putMVar done ())
      castStablePtrToPtr <$> newStablePtr done

    finish :: FinishC
    finish :: FinishC
finish Ptr ()
userTask Ptr ()
_userCtx = do
      let sp :: StablePtr (MVar ())
sp = Ptr () -> StablePtr (MVar ())
forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
userTask :: StablePtr (MVar ())
      done <- StablePtr (MVar ()) -> IO (MVar ())
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (MVar ())
sp
      takeMVar done
      freeStablePtr sp