tree-sitter / tree-sitter-haskell

Haskell grammar for tree-sitter.
MIT License
152 stars 36 forks source link

Error with a file using quasiquotes #44

Closed ocharles closed 3 years ago

ocharles commented 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:

{-# 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));
    }|]
tek commented 3 years ago

thanks, fixed!

ocharles commented 3 years ago

LG - thanks for the speedy fix!