From 31274e1507144197c154b520d5def4383f39da1a Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Mon, 3 Aug 2020 21:31:24 +0400 Subject: [PATCH] Tie all up --- tools/lsp/squirrel/app/Main.hs | 391 ++++++++++++++-------------- tools/lsp/squirrel/src/AST/Find.hs | 121 ++++----- tools/lsp/squirrel/src/AST/Scope.hs | 8 + tools/lsp/squirrel/src/AST/Types.hs | 2 +- tools/lsp/squirrel/src/ParseTree.hs | 19 +- tools/lsp/squirrel/src/Parser.hs | 15 +- tools/lsp/squirrel/stack.yaml | 2 +- tools/lsp/squirrel/stack.yaml.lock | 6 +- 8 files changed, 287 insertions(+), 277 deletions(-) diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index d6a7a9f87..652947351 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -1,12 +1,13 @@ import Control.Concurrent +import Control.Arrow import Control.Concurrent.STM import Control.Exception as E import Control.Lens import Control.Monad import Data.Default -import Data.Foldable +-- import Data.Foldable import qualified Data.Text as Text import Data.Text (Text) import Data.String (fromString) @@ -25,6 +26,8 @@ import System.Exit import qualified System.Log as L import Duplo.Pretty +import Duplo.Error +import Duplo.Tree (collect) import Parser import ParseTree @@ -36,229 +39,229 @@ import qualified AST.Find as Find main :: IO () main = do - return () - for_ [1.. 100] \_ -> do - print . length . show . pp =<< sample' "../../../src/test/contracts/loop.ligo" - -- errCode <- mainLoop - -- exit errCode + -- return () + -- for_ [1.. 100] \_ -> do + -- print . length . show . pp =<< sample' "../../../src/test/recognises/loop.ligo" + errCode <- mainLoop + exit errCode --- mainLoop :: IO Int --- mainLoop = do --- chan <- atomically newTChan :: IO (TChan FromClientMessage) +mainLoop :: IO Int +mainLoop = do + chan <- atomically newTChan :: IO (TChan FromClientMessage) --- let --- callbacks = Core.InitializeCallbacks --- { Core.onInitialConfiguration = const $ Right () --- , Core.onConfigurationChange = const $ Right () --- , Core.onStartup = \lFuns -> do --- _ <- forkIO $ eventLoop lFuns chan --- return Nothing --- } + let + callbacks = Core.InitializeCallbacks + { Core.onInitialConfiguration = const $ Right () + , Core.onConfigurationChange = const $ Right () + , Core.onStartup = \lFuns -> do + _ <- forkIO $ eventLoop lFuns chan + return Nothing + } --- Core.setupLogger (Just "log.txt") [] L.INFO --- CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt") --- `catches` --- [ Handler \(e :: SomeException) -> do --- print e --- return 1 --- ] + Core.setupLogger (Just "log.txt") [] L.INFO + CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt") + `catches` + [ Handler \(e :: SomeException) -> do + print e + return 1 + ] --- syncOptions :: J.TextDocumentSyncOptions --- syncOptions = J.TextDocumentSyncOptions --- { J._openClose = Just True --- , J._change = Just J.TdSyncIncremental --- , J._willSave = Just False --- , J._willSaveWaitUntil = Just False --- , J._save = Just $ J.SaveOptions $ Just False --- } +syncOptions :: J.TextDocumentSyncOptions +syncOptions = J.TextDocumentSyncOptions + { J._openClose = Just True + , J._change = Just J.TdSyncIncremental + , J._willSave = Just False + , J._willSaveWaitUntil = Just False + , J._save = Just $ J.SaveOptions $ Just False + } --- lspOptions :: Core.Options --- lspOptions = def --- { Core.textDocumentSync = Just syncOptions --- , Core.executeCommandCommands = Just ["lsp-hello-command"] --- } +lspOptions :: Core.Options +lspOptions = def + { Core.textDocumentSync = Just syncOptions + , Core.executeCommandCommands = Just ["lsp-hello-command"] + } --- lspHandlers :: TChan FromClientMessage -> Core.Handlers --- lspHandlers rin = def --- { Core.initializedHandler = Just $ passHandler rin NotInitialized --- , Core.definitionHandler = Just $ passHandler rin ReqDefinition --- , Core.referencesHandler = Just $ passHandler rin ReqFindReferences --- , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument --- , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument --- , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument --- , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument --- , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient --- , Core.responseHandler = Just $ responseHandlerCb rin --- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction --- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand --- } +lspHandlers :: TChan FromClientMessage -> Core.Handlers +lspHandlers rin = def + { Core.initializedHandler = Just $ passHandler rin NotInitialized + , Core.definitionHandler = Just $ passHandler rin ReqDefinition + , Core.referencesHandler = Just $ passHandler rin ReqFindReferences + , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument + , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument + , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument + , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument + , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient + , Core.responseHandler = Just $ responseHandlerCb rin + , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction + , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand + } --- passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a --- passHandler rin c notification = do --- atomically $ writeTChan rin (c notification) +passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a +passHandler rin c notification = do + atomically $ writeTChan rin (c notification) --- responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage --- responseHandlerCb _rin resp = do --- U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp +responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage +responseHandlerCb _rin resp = do + U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp --- send :: Core.LspFuncs () -> FromServerMessage -> IO () --- send = Core.sendFunc +send :: Core.LspFuncs () -> FromServerMessage -> IO () +send = Core.sendFunc --- nextID :: Core.LspFuncs () -> IO J.LspId --- nextID = Core.getNextReqId +nextID :: Core.LspFuncs () -> IO J.LspId +nextID = Core.getNextReqId --- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO () --- eventLoop funs chan = do --- forever do --- msg <- atomically (readTChan chan) +eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO () +eventLoop funs chan = do + forever do + msg <- atomically (readTChan chan) --- U.logs [i|Client: ${msg}|] + U.logs [i|Client: ${msg}|] --- case msg of --- RspFromClient {} -> do --- return () + case msg of + RspFromClient {} -> do + return () --- NotInitialized _notif -> do --- let --- registration = J.Registration --- "lsp-haskell-registered" --- J.WorkspaceExecuteCommand --- Nothing --- registrations = J.RegistrationParams $ J.List [registration] + NotInitialized _notif -> do + let + registration = J.Registration + "lsp-haskell-registered" + J.WorkspaceExecuteCommand + Nothing + registrations = J.RegistrationParams $ J.List [registration] --- rid <- nextID funs --- send funs --- $ ReqRegisterCapability --- $ fmServerRegisterCapabilityRequest rid registrations + rid <- nextID funs + send funs + $ ReqRegisterCapability + $ fmServerRegisterCapabilityRequest rid registrations --- NotDidOpenTextDocument notif -> do --- let --- doc = notif --- ^.J.params --- .J.textDocument --- .J.uri + NotDidOpenTextDocument notif -> do + let + doc = notif + ^.J.params + .J.textDocument + .J.uri --- ver = notif --- ^.J.params --- .J.textDocument --- .J.version + ver = notif + ^.J.params + .J.textDocument + .J.version --- collectErrors funs --- (J.toNormalizedUri doc) --- (J.uriToFilePath doc) --- (Just ver) + collectErrors funs + (J.toNormalizedUri doc) + (J.uriToFilePath doc) + (Just ver) --- NotDidChangeTextDocument notif -> do --- let --- doc = notif --- ^.J.params --- .J.textDocument --- .J.uri + NotDidChangeTextDocument notif -> do + let + doc = notif + ^.J.params + .J.textDocument + .J.uri --- collectErrors funs --- (J.toNormalizedUri doc) --- (J.uriToFilePath doc) --- (Just 0) + collectErrors funs + (J.toNormalizedUri doc) + (J.uriToFilePath doc) + (Just 0) --- ReqDefinition req -> do --- stopDyingAlready funs req do --- let uri = req^.J.params.J.textDocument.J.uri --- let pos = posToRange $ req^.J.params.J.position --- tree <- loadByVFS funs uri --- case Find.definitionOf pos tree of --- Just defPos -> do --- respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos] --- Nothing -> do --- respondWith funs req RspDefinition $ J.MultiLoc [] + ReqDefinition req -> do + stopDyingAlready funs req do + let uri = req^.J.params.J.textDocument.J.uri + let pos = posToRange $ req^.J.params.J.position + tree <- loadFromVFS funs uri + case Find.definitionOf pos tree of + Just defPos -> do + respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos] + Nothing -> do + respondWith funs req RspDefinition $ J.MultiLoc [] --- ReqFindReferences req -> do --- stopDyingAlready funs req do --- let uri = req^.J.params.J.textDocument.J.uri --- let pos = posToRange $ req^.J.params.J.position --- tree <- loadFromVFS funs uri --- case Find.referencesOf pos tree of --- Just refs -> do --- let locations = J.Location uri . rangeToLoc <$> refs --- respondWith funs req RspFindReferences $ J.List locations --- Nothing -> do --- respondWith funs req RspFindReferences $ J.List [] + ReqFindReferences req -> do + stopDyingAlready funs req do + let uri = req^.J.params.J.textDocument.J.uri + let pos = posToRange $ req^.J.params.J.position + tree <- loadFromVFS funs uri + case Find.referencesOf pos tree of + Just refs -> do + let locations = J.Location uri . rangeToLoc <$> refs + respondWith funs req RspFindReferences $ J.List locations + Nothing -> do + respondWith funs req RspFindReferences $ J.List [] --- _ -> U.logs "unknown msg" + _ -> U.logs "unknown msg" --- respondWith --- :: Core.LspFuncs () --- -> J.RequestMessage J.ClientMethod req rsp --- -> (J.ResponseMessage rsp -> FromServerMessage) --- -> rsp --- -> IO () --- respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp +respondWith + :: Core.LspFuncs () + -> J.RequestMessage J.ClientMethod req rsp + -> (J.ResponseMessage rsp -> FromServerMessage) + -> rsp + -> IO () +respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp --- stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO () --- stopDyingAlready funs req = flip catch \(e :: SomeException) -> do --- Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError --- $ fromString --- $ "this happened: " ++ show e +stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO () +stopDyingAlready funs req = flip catch \(e :: SomeException) -> do + Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError + $ fromString + $ "this happened: " ++ show e --- posToRange :: J.Position -> Range --- posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) "" +posToRange :: J.Position -> Range +posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) "" --- rangeToLoc :: Range -> J.Range --- rangeToLoc (Range (a, b, _) (c, d, _) _) = --- J.Range --- (J.Position (a - 1) (b - 1)) --- (J.Position (c - 1) (d - 1)) +rangeToLoc :: Range -> J.Range +rangeToLoc (Range (a, b, _) (c, d, _) _) = + J.Range + (J.Position (a - 1) (b - 1)) + (J.Position (c - 1) (d - 1)) --- loadFromVFS --- :: Core.LspFuncs () --- -> J.Uri --- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) --- loadFromVFS funs uri = do --- Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri --- let txt = virtualFileText vf --- let Just fin = J.uriToFilePath uri --- (tree, _) <- runParser contract (Text fin txt) --- return $ addLocalScopes tree +loadFromVFS + :: Core.LspFuncs () + -> J.Uri + -> IO (LIGO Info') +loadFromVFS funs uri = do + Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri + let txt = virtualFileText vf + let Just fin = J.uriToFilePath uri + (tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt) + return $ addLocalScopes tree --- loadByURI --- :: J.Uri --- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) --- loadByURI uri = do --- case J.uriToFilePath uri of --- Just fin -> do --- (tree, _) <- runParser contract (Path fin) --- return $ addLocalScopes tree --- Nothing -> do --- error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed." +loadByURI + :: J.Uri + -> IO (LIGO Info') +loadByURI uri = do + case J.uriToFilePath uri of + Just fin -> do + (tree, _) <- runParserM . recognise =<< toParseTree (Path fin) + return $ addLocalScopes tree + Nothing -> do + error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed." --- collectErrors --- :: Core.LspFuncs () --- -> J.NormalizedUri --- -> Maybe FilePath --- -> Maybe Int --- -> IO () --- collectErrors funs uri path version = do --- case path of --- Just fin -> do --- (tree, errs) <- runParser contract (Path fin) --- Core.publishDiagnosticsFunc funs 100 uri version --- $ partitionBySource --- $ map errorToDiag (errs <> errors tree) +collectErrors + :: Core.LspFuncs () + -> J.NormalizedUri + -> Maybe FilePath + -> Maybe Int + -> IO () +collectErrors funs uri path version = do + case path of + Just fin -> do + (tree, errs) <- runParserM . recognise =<< toParseTree (Path fin) + Core.publishDiagnosticsFunc funs 100 uri version + $ partitionBySource + $ map errorToDiag (errs <> map (getElem *** void) (collect tree)) --- Nothing -> error "TODO: implement URI file loading" + Nothing -> error "TODO: implement URI file loading" --- errorToDiag :: Error ASTInfo -> J.Diagnostic --- errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _) _))) = --- J.Diagnostic --- (J.Range begin end) --- (Just J.DsError) --- Nothing --- (Just "ligo-lsp") --- (Text.pack [i|Expected #{what}|]) --- (Just $ J.List[]) --- where --- begin = J.Position (sl - 1) (sc - 1) --- end = J.Position (el - 1) (ec - 1) +errorToDiag :: (Range, Err Text a) -> J.Diagnostic +errorToDiag (getRange -> (Range (sl, sc, _) (el, ec, _) _), Err what) = + J.Diagnostic + (J.Range begin end) + (Just J.DsError) + Nothing + (Just "ligo-lsp") + (Text.pack [i|Expected #{what}|]) + (Just $ J.List[]) + where + begin = J.Position (sl - 1) (sc - 1) + end = J.Position (el - 1) (ec - 1) --- exit :: Int -> IO () --- exit 0 = exitSuccess --- exit n = exitWith (ExitFailure n) +exit :: Int -> IO () +exit 0 = exitSuccess +exit n = exitWith (ExitFailure n) diff --git a/tools/lsp/squirrel/src/AST/Find.hs b/tools/lsp/squirrel/src/AST/Find.hs index 8c2139999..ffd23278d 100644 --- a/tools/lsp/squirrel/src/AST/Find.hs +++ b/tools/lsp/squirrel/src/AST/Find.hs @@ -1,70 +1,75 @@ module AST.Find where --- import Control.Monad +import Control.Monad --- import AST.Types --- import AST.Scope --- import AST.Parser +import Data.Maybe (listToMaybe) --- import Tree --- import Range --- import Pretty --- import Product +import Duplo.Tree +import Duplo.Pretty +import Duplo.Lattice --- import Data.Text (Text) --- -- import Debug.Trace +import Data.Text (Text) --- type CanSearch xs = --- ( Contains [ScopedDecl] xs --- , Contains Range xs --- , Contains (Maybe Category) xs --- , Contains [Text] xs --- , Pretty (Product xs) --- ) +import AST.Types +import AST.Scope --- findScopedDecl --- :: CanSearch xs --- => Range --- -> Pascal (Product xs) --- -> Maybe ScopedDecl --- findScopedDecl pos tree = do --- pt <- lookupTree pos tree --- let info = infoOf pt --- let fullEnv = getElem info --- do --- categ <- getElem info --- let filtered = filter (ofCategory categ) fullEnv --- lookupEnv (ppToText $ void pt) filtered +import Product +import Range --- definitionOf --- :: CanSearch xs --- => Range --- -> Pascal (Product xs) --- -> Maybe Range --- definitionOf pos tree = --- _sdOrigin <$> findScopedDecl pos tree +-- import Debug.Trace --- typeOf --- :: CanSearch xs --- => Range --- -> Pascal (Product xs) --- -> Maybe (Either (Pascal ()) Kind) --- typeOf pos tree = --- _sdType =<< findScopedDecl pos tree +type CanSearch xs = + ( Contains [ScopedDecl] xs + , Contains Range xs + , Contains (Maybe Category) xs + , Contains [Text] xs + , Pretty (Product xs) + , Eq (Product xs) + ) --- implementationOf --- :: CanSearch xs --- => Range --- -> Pascal (Product xs) --- -> Maybe Range --- implementationOf pos tree = --- _sdBody =<< findScopedDecl pos tree +findScopedDecl + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe ScopedDecl +findScopedDecl pos tree = do + pt <- listToMaybe $ spineTo (\i -> pos `leq` getElem i) tree + let info = extract pt + let fullEnv = getElem info + do + categ <- getElem info + let filtered = filter (ofCategory categ) fullEnv + lookupEnv (ppToText $ void pt) filtered --- referencesOf --- :: CanSearch xs --- => Range --- -> Pascal (Product xs) --- -> Maybe [Range] --- referencesOf pos tree = --- _sdRefs <$> findScopedDecl pos tree +definitionOf + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe Range +definitionOf pos tree = + _sdOrigin <$> findScopedDecl pos tree + +typeOf + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe (Either (LIGO ()) Kind) +typeOf pos tree = + _sdType =<< findScopedDecl pos tree + +implementationOf + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe Range +implementationOf pos tree = + _sdBody =<< findScopedDecl pos tree + +referencesOf + :: CanSearch xs + => Range + -> LIGO (Product xs) + -> Maybe [Range] +referencesOf pos tree = + _sdRefs <$> findScopedDecl pos tree diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 11b7b6418..e3852e9b6 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -56,6 +56,12 @@ data ScopedDecl = ScopedDecl } deriving Show via PP ScopedDecl +instance Eq ScopedDecl where + sd == sd1 = and + [ pp (_sdName sd) == pp (_sdName sd1) + , _sdOrigin sd == _sdOrigin sd1 + ] + -- | The kind. data Kind = Star deriving Show via PP Kind @@ -91,6 +97,8 @@ ofCategory Variable _ = True ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True ofCategory _ _ = False +type Info' = Product [[ScopedDecl], Maybe Category, [Text], Range, ShowRange] + instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where ascribe (ds :> _ :> _ :> r :> _) d = color 3 (fsep (map (pp . _sdName) ds)) diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index c2ce71a6f..47be3e2cc 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -25,7 +25,7 @@ type RawLigoList = [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding , RawContract, TypeName, FieldName, Language - , Err Text, Parameters, Ctor + , Err Text, Parameters, Ctor, Contract ] data Undefined it diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 744e0a8f2..1260e13b5 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -21,7 +21,6 @@ module ParseTree where import Data.ByteString (ByteString) -import Data.IORef import qualified Data.ByteString as BS import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -101,20 +100,13 @@ toParseTree = unsafePerformIO $ debounced inner src <- srcToBytestring fin - idCounter <- newIORef 0 - BS.useAsCStringLen src \(str, len) -> do tree <- ts_parser_parse_string parser nullPtr str len - withRootNode tree (peek >=> go src idCounter) + withRootNode tree (peek >=> go src) where - nextID :: IORef Int -> IO Int - nextID ref = do - modifyIORef' ref (+ 1) - readIORef ref - - go :: ByteString -> IORef Int -> Node -> IO RawTree - go src idCounter node = do + go :: ByteString -> Node -> IO RawTree + go src node = do let count = fromIntegral $ nodeChildCount node allocaArray count \children -> do alloca \tsNodePtr -> do @@ -124,7 +116,7 @@ toParseTree = unsafePerformIO $ debounced inner peekElemOff children i trees <- for nodes \node' -> do - (only -> (r :> _, tree :: ParseTree RawTree)) <- go src idCounter node' + (only -> (r :> _, tree :: ParseTree RawTree)) <- go src node' field <- if nodeFieldName node' == nullPtr then return "" @@ -138,9 +130,6 @@ toParseTree = unsafePerformIO $ debounced inner finish2D = nodeEndPoint node i = fromIntegral - treeID <- nextID idCounter - fID <- nextID idCounter - let range = Range { rStart = diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 75367496f..2c083c56c 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -29,7 +29,7 @@ import Debug.Trace 4) On leaving, move move comments from 2 to 1. -} -runParserM :: ParserM a -> IO (a, [Err Text ()]) +runParserM :: ParserM a -> IO (a, [Msg]) runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p () ([], []) runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a) @@ -40,22 +40,23 @@ runParserM1 cs p = do put s1 return a -type ParserM = RWST () [Err Text ()] ([Text], [Text]) IO -type ParserM1 = MaybeT (RWST [RawTree] [Err Text ()] ([Text], [Text]) IO) +type Msg = (Range, Err Text ()) +type ParserM = RWST () [Msg] ([Text], [Text]) IO +type ParserM1 = MaybeT (RWST [RawTree] [Msg] ([Text], [Text]) IO) data Failure = Failure String deriving stock (Show) deriving anyclass (Exception) instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where - before (_ :> _ :> _) (ParseTree ty cs s) = do + before (r :> _ :> _) (ParseTree ty cs s) = do let (comms, rest) = allComments cs let (comms1, _) = allComments $ reverse rest modify $ first (++ comms) modify $ second (++ reverse comms1) let errs = allErrors cs - tell $ fmap Err errs + tell $ fmap (\t -> (r, Err t)) errs after _ _ = do modify \(x, y) -> (y, []) @@ -112,6 +113,10 @@ data ShowRange = Y | N deriving stock Eq +instance Pretty ShowRange where + pp Y = "Yau" + pp N = "Nah" + type Info = Product [[Text], Range, ShowRange] type PreInfo = Product [Range, ShowRange] diff --git a/tools/lsp/squirrel/stack.yaml b/tools/lsp/squirrel/stack.yaml index 59a133b44..a811c8a56 100644 --- a/tools/lsp/squirrel/stack.yaml +++ b/tools/lsp/squirrel/stack.yaml @@ -41,7 +41,7 @@ extra-deps: - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 - fastsum-0.1.1.1 - git: https://github.com/serokell/duplo.git - commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae + commit: e6e2e382bb381ce629e71ab3d08274396e686ba3 # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a diff --git a/tools/lsp/squirrel/stack.yaml.lock b/tools/lsp/squirrel/stack.yaml.lock index ce3b4676d..5ddeb40e2 100644 --- a/tools/lsp/squirrel/stack.yaml.lock +++ b/tools/lsp/squirrel/stack.yaml.lock @@ -45,11 +45,11 @@ packages: git: https://github.com/serokell/duplo.git pantry-tree: size: 557 - sha256: d8258e8fa560d07da3bf4a5e7f956494a8d1b374e67c3af1b7b6875f8175a309 - commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae + sha256: bdd68d3e171c6a2311ca101cc654a5cca984a1e8ce745e928287a40fa8f5a0ff + commit: e6e2e382bb381ce629e71ab3d08274396e686ba3 original: git: https://github.com/serokell/duplo.git - commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae + commit: e6e2e382bb381ce629e71ab3d08274396e686ba3 snapshots: - completed: size: 493124