From fe929fbe7022077ba994f68834ac699de7b02b0c Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Fri, 14 Aug 2020 15:40:30 +0400 Subject: [PATCH] Link camligo grammar, get rid of personal loaders --- tools/lsp/squirrel/package.yaml | 1 + tools/lsp/squirrel/src/AST/Camligo/Parser.hs | 16 +++++++++ tools/lsp/squirrel/src/AST/Parser.hs | 19 ++++------ .../lsp/squirrel/src/AST/Pascaligo/Parser.hs | 8 ++--- .../lsp/squirrel/src/AST/Reasonligo/Parser.hs | 10 +++--- tools/lsp/squirrel/src/Debouncer.hs | 8 +++-- tools/lsp/squirrel/src/Extension.hs | 36 +++++++++++++++++++ tools/lsp/squirrel/src/ParseTree.hs | 22 ++++++------ 8 files changed, 84 insertions(+), 36 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Camligo/Parser.hs create mode 100644 tools/lsp/squirrel/src/Extension.hs diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 62f14f251..757094453 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -63,6 +63,7 @@ library: c-sources: - vendor/pascaligo/parser.c - vendor/reasonligo/parser.c + - vendor/camligo/parser.c executables: squirrel: diff --git a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs new file mode 100644 index 000000000..0783697f9 --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs @@ -0,0 +1,16 @@ + +module AST.Camligo.Parser where + +import Data.Maybe (isJust) + +import AST.Skeleton + +import Duplo.Error +import Duplo.Tree +import Duplo.Pretty + +import Product +import Parser +import ParseTree + +-- import Debug.Trace \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 8d144f566..4412e806d 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -4,24 +4,19 @@ module AST.Parser , parse ) where -import Control.Monad.Catch - -import System.FilePath - import qualified AST.Pascaligo.Parser as Pascal import qualified AST.Reasonligo.Parser as Reason import AST.Skeleton import ParseTree import Parser - -data UnsupportedExtension = UnsupportedExtension String - deriving stock Show - deriving anyclass Exception +import Extension parse :: Source -> IO (LIGO Info, [Msg]) parse src = do - case takeExtension $ srcPath src of - "religo" -> mkRawTreeReason src >>= runParserM . Reason.recognise - "ligo" -> mkRawTreePascal src >>= runParserM . Pascal.recognise - ext -> throwM $ UnsupportedExtension ext + recogniser <- onExt ElimExt + { eePascal = Pascal.recognise + , eeCaml = error "TODO: caml recogniser" + , eeReason = Reason.recognise + } (srcPath src) + toParseTree src >>= runParserM . recogniser diff --git a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs index b2de7bdab..8b75126e8 100644 --- a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs @@ -40,24 +40,24 @@ example = "../../../src/test/contracts/coase.ligo" sample' :: FilePath -> IO (LIGO Info) sample' f - = mkRawTreePascal (Path f) + = toParseTree (Path f) >>= runParserM . recognise >>= return . fst source' :: FilePath -> IO () source' f - = mkRawTreePascal (Path f) + = toParseTree (Path f) >>= print . pp sample :: IO () sample - = mkRawTreePascal (Path example) + = toParseTree (Path example) >>= runParserM . recognise >>= print . pp . fst source :: IO () source - = mkRawTreePascal (Path example) + = toParseTree (Path example) >>= print . pp recognise :: RawTree -> ParserM (LIGO Info) diff --git a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs index fc1bab038..be30bb9cc 100644 --- a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs @@ -35,13 +35,13 @@ example = "./contracts/multisig.religo" -- example = "./contracts/letin.religo" raw :: IO () -raw = mkRawTreeReason (Path example) - >>= print . pp +raw = toParseTree (Path example) + >>= print . pp sample :: IO () -sample = mkRawTreeReason (Path example) - >>= runParserM . recognise - >>= print . pp . fst +sample = toParseTree (Path example) + >>= runParserM . recognise + >>= print . pp . fst recognise :: RawTree -> ParserM (LIGO Info) recognise = descent (\_ -> error . show . pp) $ map usingScope diff --git a/tools/lsp/squirrel/src/Debouncer.hs b/tools/lsp/squirrel/src/Debouncer.hs index 6ddb0cde6..762ccedd8 100644 --- a/tools/lsp/squirrel/src/Debouncer.hs +++ b/tools/lsp/squirrel/src/Debouncer.hs @@ -5,6 +5,8 @@ import Control.Monad.Catch import Control.Monad import Control.Concurrent +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. @@ -13,8 +15,8 @@ import Control.Concurrent -- -- If function throws an error, will rethrow it in caller thread. -- -debounced :: forall s r. (s -> IO r) -> IO (s -> IO r) -debounced act = do +debounced :: forall s r. (s -> IO r) -> (s -> IO r) +debounced act = unsafePerformIO do i <- newEmptyMVar o <- newEmptyMVar @@ -31,7 +33,7 @@ debounced act = do putMVar i i' readMVar o >>= either throwM return -_test :: IO ([Int] -> IO Int) +_test :: [Int] -> IO Int _test = debounced \s -> do threadDelay 2000000 unless (odd (length s)) do diff --git a/tools/lsp/squirrel/src/Extension.hs b/tools/lsp/squirrel/src/Extension.hs new file mode 100644 index 000000000..8359dcdc8 --- /dev/null +++ b/tools/lsp/squirrel/src/Extension.hs @@ -0,0 +1,36 @@ + +module Extension where + +import Control.Monad.Catch + +import System.FilePath + +data Ext + = Pascal + | Caml + | Reason + +data ElimExt a = ElimExt + { eePascal :: a + , eeCaml :: a + , eeReason :: a + } + +data UnsupportedExtension = UnsupportedExtension String + deriving stock Show + deriving anyclass Exception + +getExt :: MonadThrow m => FilePath -> m Ext +getExt path = do + case takeExtension path of + "religo" -> return Reason + "ligo" -> return Pascal + "mligo" -> return Caml + ext -> throwM $ UnsupportedExtension ext + +onExt :: ElimExt a -> FilePath -> IO a +onExt ee path = do + getExt path >>= return . \case + Pascal -> eePascal ee + Caml -> eeCaml ee + Reason -> eeReason ee diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 814744070..598656672 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -16,8 +16,6 @@ module ParseTree -- * Invoke the TreeSitter and get the tree it outputs , toParseTree - , mkRawTreePascal - , mkRawTreeReason ) where @@ -42,17 +40,17 @@ import TreeSitter.Tree hiding (Tree) import System.FilePath (takeFileName) -import System.IO.Unsafe (unsafePerformIO) - import Duplo.Pretty as PP import Duplo.Tree +import Extension import Debouncer import Product 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 data Source = Path { srcPath :: FilePath } @@ -105,17 +103,17 @@ instance Pretty1 ParseTree where (pp forest) ) -mkRawTreePascal :: Source -> IO RawTree -mkRawTreePascal = toParseTree tree_sitter_PascaLigo - -mkRawTreeReason :: Source -> IO RawTree -mkRawTreeReason = toParseTree tree_sitter_ReasonLigo - -- | Feed file contents into PascaLIGO grammar recogniser. -toParseTree :: Ptr Language -> Source -> IO RawTree -toParseTree language = unsafePerformIO $ debounced inner +toParseTree :: Source -> IO RawTree +toParseTree = debounced inner where inner fin = do + language <- onExt ElimExt + { eePascal = tree_sitter_PascaLigo + , eeCaml = tree_sitter_CamlLigo + , 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