Closed ocharles closed 3 years ago
If I open tree-sitter-playground on this file, I get a bunch of error nodes, though the file compiles just fine:
tree-sitter-playground
{-# language BlockArguments #-} {-# language QuasiQuotes #-} {-# language RecordWildCards #-} {-# language TemplateHaskell #-} module CircuitHub.PNP.Camera ( -- * Initialising Pylon Pylon , withPylon -- * Opening cameras , Camera , maxNumBuffers , withCamera , startGrabbing , onImageGrabbed , PylonImage , cloneGrabResultImage , saveTiff ) where -- StateVar import Data.StateVar ( SettableStateVar, makeSettableStateVar ) -- base import Foreign.C.Types ( CInt ) import Foreign.C ( withCString ) import Foreign.Ptr ( Ptr ) -- inline-c import qualified Language.C.Inline as C -- inline-c-cpp import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Cpp.Exceptions as C -- pnp import CircuitHub.PNP.Camera.Context ( CGrabResultPtr, CInstantCamera, CPylonImage, pylonCtx ) -- unliftio import UnliftIO ( MonadIO, MonadUnliftIO, bracket, bracket_, liftIO, withRunInIO ) C.context (C.cppCtx <> C.funCtx <> pylonCtx) C.include "pylon/PylonIncludes.h" C.include "HardwareTriggerConfiguration.h" C.include "SaveHandler.h" C.include "RTSSignal.h" C.using "namespace Pylon" C.using "namespace CircuitHub" data Pylon = Pylon -- | Initialize the Pylon SDK. Pylon must be initialized before any other -- functions can be called. withPylon :: MonadUnliftIO m => (Pylon -> m a) -> m a withPylon k = bracket_ create destroy $ k Pylon where create = liftIO do [C.exp| void { PylonInitialize() } |] destroy = liftIO do [C.exp| void { PylonTerminate() } |] -- | The Pylon SDK doesn't do a good job of dealing with interupted syscalls, -- which can happen when GHC's RTS sends VALRM signals. This wrapped blocks -- these signals, allowing foreign code to execute without interuption. withBlockedSignals :: MonadUnliftIO m => m a -> m a withBlockedSignals k = bracket block unblock \_ -> k where block = liftIO do [C.exp| void* { new RtsSignalBlocker() } |] unblock rtsSignalBlocker = liftIO do [C.exp| void { delete (RtsSignalBlocker*)$(void* rtsSignalBlocker) } |] -- | The maximum number of buffers available by the camera's grab loop. maxNumBuffers :: Camera -> SettableStateVar CInt maxNumBuffers (Camera cameraPtr) = makeSettableStateVar \n -> [C.throwBlock| void { $(CInstantCamera* cameraPtr)->MaxNumBuffer = $(int n); } |] newtype Camera = Camera (Ptr CInstantCamera) -- | Open a Basler camera. withCamera :: MonadUnliftIO m => Pylon -> (Camera -> m a) -> m a withCamera _ = bracket create destroy where create = withBlockedSignals $ liftIO $ Camera <$> [C.throwBlock| CInstantCamera* { CInstantCamera* camera = new CInstantCamera(CTlFactory::GetInstance().CreateFirstDevice()); camera->RegisterConfiguration( new HardwareTriggerConfiguration, RegistrationMode_ReplaceAll, Cleanup_Delete ); return camera; }|] destroy (Camera camera) = liftIO do [C.exp| void { delete $(CInstantCamera* camera) } |] startGrabbing :: MonadIO m => Camera -> m () startGrabbing (Camera cameraPtr) = liftIO do [C.throwBlock| void { $(CInstantCamera* cameraPtr)->StartGrabbing( GrabStrategy_OneByOne, GrabLoop_ProvidedByInstantCamera ); } |] newtype GrabResultPtr = GrabResultPtr (Ptr CGrabResultPtr) onImageGrabbed :: MonadUnliftIO m => Camera -> (Camera -> GrabResultPtr -> m ()) -> m () onImageGrabbed (Camera cameraPtr) callback = withRunInIO \run -> do callbackPtr <- liftIO do $( C.mkFunPtr [t| Ptr CInstantCamera -> Ptr CGrabResultPtr -> IO () |] ) \cameraPtr' cGrabResultPtrPtr -> run $ callback (Camera cameraPtr') (GrabResultPtr cGrabResultPtrPtr) [C.throwBlock| void { $(CInstantCamera* cameraPtr)->RegisterImageEventHandler( new SaveHandler( $(void (*callbackPtr)(CInstantCamera*, const CGrabResultPtr*)) ), RegistrationMode_Append, Cleanup_Delete ); } |] newtype PylonImage = PylonImage (Ptr CPylonImage) cloneGrabResultImage :: MonadUnliftIO m => GrabResultPtr -> m PylonImage cloneGrabResultImage (GrabResultPtr grabResultPtr) = liftIO $ PylonImage <$> liftIO do [C.throwBlock| CPylonImage* { CPylonImage src; src.AttachGrabResultBuffer(*$(CGrabResultPtr* grabResultPtr)); CPylonImage* pylonImage = new CPylonImage(); pylonImage->CopyImage(src); return pylonImage; } |] saveTiff :: MonadIO m => PylonImage -> FilePath -> m () saveTiff (PylonImage pylonImage) destination = liftIO do withCString destination \destPtr -> [C.throwBlock| void { $(CPylonImage* pylonImage)->Save(ImageFileFormat_Tiff, $(char* destPtr)); }|]
thanks, fixed!
LG - thanks for the speedy fix!
If I open
tree-sitter-playground
on this file, I get a bunch of error nodes, though the file compiles just fine: