Rename debounced -> unsafeDebounce

tools/lsp/squirrel/src/Debouncer.hs

@@ -1,5 +1,5 @@
 
-module Debouncer (debounced) where
+module Debouncer (unsafeDebounce) where
 
 import Control.Monad.Catch
 import Control.Monad
@@ -9,14 +9,14 @@ import System.IO.Unsafe
 
 -- | Ensure the function is run in single thread, w/o overlapping.
 --
---   If called concurently, everyone will get results of the winner.
+--   If called concurently, everyone will get result of the winner.
 --
 --   If called, waits for next result to arrive.
 --
 --   If function throws an error, will rethrow it in caller thread.
 --
-debounced :: forall s r. (s -> IO r) -> (s -> IO r)
+unsafeDebounce :: forall s r. (s -> IO r) -> (s -> IO r)
-debounced act = unsafePerformIO do
+unsafeDebounce act = unsafePerformIO do
   i <- newEmptyMVar
   o <- newEmptyMVar
 
@@ -34,7 +34,7 @@ debounced act = unsafePerformIO do
     readMVar o >>= either throwM return
 
 _test :: [Int] -> IO Int
-_test = debounced \s -> do
+_test = unsafeDebounce \s -> do
   threadDelay 2000000
   unless (odd (length s)) do
     error "even"

tools/lsp/squirrel/src/ParseTree.hs

@@ -50,7 +50,7 @@ import           Range
 
 foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
 foreign import ccall unsafe tree_sitter_ReasonLigo :: Ptr Language
-foreign import ccall unsafe tree_sitter_CamlLigo :: Ptr Language
+foreign import ccall unsafe tree_sitter_CameLigo :: Ptr Language
 
 data Source
   = Path       { srcPath :: FilePath }
@@ -105,70 +105,68 @@ instance Pretty1 ParseTree where
 
 -- | Feed file contents into PascaLIGO grammar recogniser.
 toParseTree :: Source -> IO RawTree
-toParseTree = debounced inner
+toParseTree = unsafeDebounce \fin -> do
+  language <- onExt ElimExt
+    { eePascal = tree_sitter_PascaLigo
+    , eeCaml   = tree_sitter_CameLigo
+    , eeReason = tree_sitter_ReasonLigo
+    } (srcPath fin)
+
+  parser <- ts_parser_new
+  -- True   <- ts_parser_set_language parser tree_sitter_PascaLigo
+  True <- ts_parser_set_language parser language
+
+  src <- srcToBytestring fin
+
+  BS.useAsCStringLen src \(str, len) -> do
+    tree <- ts_parser_parse_string parser nullPtr str len
+    withRootNode tree (peek >=> go fin src)
+
   where
-    inner fin = do
+    go :: Source -> ByteString -> Node -> IO RawTree
-      language <- onExt ElimExt
+    go fin src node = do
-        { eePascal = tree_sitter_PascaLigo
+      let count = fromIntegral $ nodeChildCount node
-        , eeCaml   = tree_sitter_CamlLigo
+      allocaArray count $ \children -> do
-        , eeReason = tree_sitter_ReasonLigo
+        alloca $ \tsNodePtr -> do
-        } (srcPath fin)
+          poke tsNodePtr $ nodeTSNode node
+          ts_node_copy_child_nodes tsNodePtr children
+          nodes <- for [0.. count - 1] $ \i -> do
+            peekElemOff children i
 
-      parser <- ts_parser_new
+          trees <- for nodes \node' -> do
-      -- True   <- ts_parser_set_language parser tree_sitter_PascaLigo
+            (only -> (r :> _, tree :: ParseTree RawTree)) <- go fin src node'
-      True <- ts_parser_set_language parser language
+            field <-
+              if nodeFieldName node' == nullPtr
+              then return ""
+              else peekCString $ nodeFieldName node'
+            return $ make (r :> Text.pack field :> Nil, tree)
 
-      src <- srcToBytestring fin
+          ty <- peekCString $ nodeType node
 
-      BS.useAsCStringLen src \(str, len) -> do
+          let
-        tree <- ts_parser_parse_string parser nullPtr str len
+            start2D  = nodeStartPoint node
-        withRootNode tree (peek >=> go src)
+            finish2D = nodeEndPoint   node
+            i = fromIntegral
 
-      where
+          let
-        go :: ByteString -> Node -> IO RawTree
+            range = Range
-        go src node = do
+              { rStart  =
-          let count = fromIntegral $ nodeChildCount node
+                  ( i $ pointRow    start2D + 1
-          allocaArray count $ \children -> do
+                  , i $ pointColumn start2D + 1
-            alloca $ \tsNodePtr -> do
+                  , i $ nodeStartByte node
-              poke tsNodePtr $ nodeTSNode node
+                  )
-              ts_node_copy_child_nodes tsNodePtr children
-              nodes <- for [0.. count - 1] $ \i -> do
-                peekElemOff children i
 
-              trees <- for nodes \node' -> do
+              , rFinish =
-                (only -> (r :> _, tree :: ParseTree RawTree)) <- go src node'
+                  ( i $ pointRow    finish2D + 1
-                field <-
+                  , i $ pointColumn finish2D + 1
-                  if nodeFieldName node' == nullPtr
+                  , i $ nodeEndByte node
-                  then return ""
+                  )
-                  else peekCString $ nodeFieldName node'
+              , rFile = takeFileName $ srcPath fin
-                return $ make (r :> Text.pack field :> Nil, tree)
+              }
 
-              ty <- peekCString $ nodeType node
+          return $ make (range :> "" :> Nil, ParseTree
-
+            { ptName     = Text.pack ty
-              let
+            -- , ptChildren = fromList . fmap (Comment,) $ trees -- TODO
-                start2D  = nodeStartPoint node
+            , ptChildren = trees
-                finish2D = nodeEndPoint   node
+            , ptSource   = cutOut range src
-                i = fromIntegral
+            })
-
-              let
-                range = Range
-                  { rStart  =
-                      ( i $ pointRow    start2D + 1
-                      , i $ pointColumn start2D + 1
-                      , i $ nodeStartByte node
-                      )
-
-                  , rFinish =
-                      ( i $ pointRow    finish2D + 1
-                      , i $ pointColumn finish2D + 1
-                      , i $ nodeEndByte node
-                      )
-                  , rFile = takeFileName $ srcPath fin
-                  }
-
-              return $ make (range :> "" :> Nil, ParseTree
-                { ptName     = Text.pack ty
-                -- , ptChildren = fromList . fmap (Comment,) $ trees -- TODO
-                , ptChildren = trees
-                , ptSource   = cutOut range src
-                })