diff --git a/tools/lsp/squirrel/src/Debouncer.hs b/tools/lsp/squirrel/src/Debouncer.hs index 762ccedd8..c66f0dd0a 100644 --- a/tools/lsp/squirrel/src/Debouncer.hs +++ b/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) -debounced act = unsafePerformIO do +unsafeDebounce :: forall s r. (s -> IO r) -> (s -> IO r) +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" diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 598656672..c187bad4e 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/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 - language <- onExt ElimExt - { eePascal = tree_sitter_PascaLigo - , eeCaml = tree_sitter_CamlLigo - , eeReason = tree_sitter_ReasonLigo - } (srcPath fin) + go :: Source -> ByteString -> Node -> IO RawTree + go fin src node = do + let count = fromIntegral $ nodeChildCount node + allocaArray count $ \children -> do + alloca $ \tsNodePtr -> do + 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 - -- True <- ts_parser_set_language parser tree_sitter_PascaLigo - True <- ts_parser_set_language parser language + trees <- for nodes \node' -> do + (only -> (r :> _, tree :: ParseTree RawTree)) <- go fin src node' + 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 - tree <- ts_parser_parse_string parser nullPtr str len - withRootNode tree (peek >=> go src) + let + start2D = nodeStartPoint node + finish2D = nodeEndPoint node + i = fromIntegral - where - go :: ByteString -> Node -> IO RawTree - go src node = do - let count = fromIntegral $ nodeChildCount node - allocaArray count $ \children -> do - alloca $ \tsNodePtr -> do - poke tsNodePtr $ nodeTSNode node - ts_node_copy_child_nodes tsNodePtr children - nodes <- for [0.. count - 1] $ \i -> do - peekElemOff children i + let + range = Range + { rStart = + ( i $ pointRow start2D + 1 + , i $ pointColumn start2D + 1 + , i $ nodeStartByte node + ) - trees <- for nodes \node' -> do - (only -> (r :> _, tree :: ParseTree RawTree)) <- go src node' - field <- - if nodeFieldName node' == nullPtr - then return "" - else peekCString $ nodeFieldName node' - return $ make (r :> Text.pack field :> Nil, tree) + , rFinish = + ( i $ pointRow finish2D + 1 + , i $ pointColumn finish2D + 1 + , i $ nodeEndByte node + ) + , rFile = takeFileName $ srcPath fin + } - ty <- peekCString $ nodeType node - - let - start2D = nodeStartPoint node - finish2D = nodeEndPoint node - 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 - }) + return $ make (range :> "" :> Nil, ParseTree + { ptName = Text.pack ty + -- , ptChildren = fromList . fmap (Comment,) $ trees -- TODO + , ptChildren = trees + , ptSource = cutOut range src + })