balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Tie all up

Browse Source
This commit is contained in:
Kirill Andreev 2020-08-03 21:31:24 +04:00
parent 9f29dab195
commit 31274e1507
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
8 changed files with 287 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

391
tools/lsp/squirrel/app/Main.hs
View File

@ -1,12 +1,13 @@
import Control.Concurrent import Control.Concurrent
import Control.Arrow
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception as E import Control.Exception as E
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import Data.Default import Data.Default
import Data.Foldable -- import Data.Foldable
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import Data.String (fromString) import Data.String (fromString)
@ -25,6 +26,8 @@ import System.Exit
import qualified System.Log as L import qualified System.Log as L
import Duplo.Pretty import Duplo.Pretty
import Duplo.Error
import Duplo.Tree (collect)
import Parser import Parser
import ParseTree import ParseTree
@ -36,229 +39,229 @@ import qualified AST.Find as Find
main :: IO () main :: IO ()
main = do main = do
return () -- return ()
for_ [1.. 100] \_ -> do -- for_ [1.. 100] \_ -> do
print . length . show . pp =<< sample' "../../../src/test/contracts/loop.ligo" -- print . length . show . pp =<< sample' "../../../src/test/recognises/loop.ligo"
-- errCode <- mainLoop errCode <- mainLoop
-- exit errCode exit errCode
-- mainLoop :: IO Int mainLoop :: IO Int
-- mainLoop = do mainLoop = do
-- chan <- atomically newTChan :: IO (TChan FromClientMessage) chan <- atomically newTChan :: IO (TChan FromClientMessage)
-- let let
-- callbacks = Core.InitializeCallbacks callbacks = Core.InitializeCallbacks
-- { Core.onInitialConfiguration = const $ Right () { Core.onInitialConfiguration = const $ Right ()
-- , Core.onConfigurationChange = const $ Right () , Core.onConfigurationChange = const $ Right ()
-- , Core.onStartup = \lFuns -> do , Core.onStartup = \lFuns -> do
-- _ <- forkIO $ eventLoop lFuns chan _ <- forkIO $ eventLoop lFuns chan
-- return Nothing return Nothing
-- } }
-- Core.setupLogger (Just "log.txt") [] L.INFO Core.setupLogger (Just "log.txt") [] L.INFO
-- CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt") CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt")
-- `catches` `catches`
-- [ Handler \(e :: SomeException) -> do [ Handler \(e :: SomeException) -> do
-- print e print e
-- return 1 return 1
-- ] ]
-- syncOptions :: J.TextDocumentSyncOptions syncOptions :: J.TextDocumentSyncOptions
-- syncOptions = J.TextDocumentSyncOptions syncOptions = J.TextDocumentSyncOptions
-- { J._openClose = Just True { J._openClose = Just True
-- , J._change = Just J.TdSyncIncremental , J._change = Just J.TdSyncIncremental
-- , J._willSave = Just False , J._willSave = Just False
-- , J._willSaveWaitUntil = Just False , J._willSaveWaitUntil = Just False
-- , J._save = Just $ J.SaveOptions $ Just False , J._save = Just $ J.SaveOptions $ Just False
-- } }
-- lspOptions :: Core.Options lspOptions :: Core.Options
-- lspOptions = def lspOptions = def
-- { Core.textDocumentSync = Just syncOptions { Core.textDocumentSync = Just syncOptions
-- , Core.executeCommandCommands = Just ["lsp-hello-command"] , Core.executeCommandCommands = Just ["lsp-hello-command"]
-- } }
-- lspHandlers :: TChan FromClientMessage -> Core.Handlers lspHandlers :: TChan FromClientMessage -> Core.Handlers
-- lspHandlers rin = def lspHandlers rin = def
-- { Core.initializedHandler = Just $ passHandler rin NotInitialized { Core.initializedHandler = Just $ passHandler rin NotInitialized
-- , Core.definitionHandler = Just $ passHandler rin ReqDefinition , Core.definitionHandler = Just $ passHandler rin ReqDefinition
-- , Core.referencesHandler = Just $ passHandler rin ReqFindReferences , Core.referencesHandler = Just $ passHandler rin ReqFindReferences
-- , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
-- , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
-- , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
-- , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
-- , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
-- , Core.responseHandler = Just $ responseHandlerCb rin , Core.responseHandler = Just $ responseHandlerCb rin
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
-- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
-- } }
-- passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
-- passHandler rin c notification = do passHandler rin c notification = do
-- atomically $ writeTChan rin (c notification) atomically $ writeTChan rin (c notification)
-- responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage
-- responseHandlerCb _rin resp = do responseHandlerCb _rin resp = do
-- U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
-- send :: Core.LspFuncs () -> FromServerMessage -> IO () send :: Core.LspFuncs () -> FromServerMessage -> IO ()
-- send = Core.sendFunc send = Core.sendFunc
-- nextID :: Core.LspFuncs () -> IO J.LspId nextID :: Core.LspFuncs () -> IO J.LspId
-- nextID = Core.getNextReqId nextID = Core.getNextReqId
-- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO () eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
-- eventLoop funs chan = do eventLoop funs chan = do
-- forever do forever do
-- msg <- atomically (readTChan chan) msg <- atomically (readTChan chan)
-- U.logs [i|Client: ${msg}|] U.logs [i|Client: ${msg}|]
-- case msg of case msg of
-- RspFromClient {} -> do RspFromClient {} -> do
-- return () return ()
-- NotInitialized _notif -> do NotInitialized _notif -> do
-- let let
-- registration = J.Registration registration = J.Registration
-- "lsp-haskell-registered" "lsp-haskell-registered"
-- J.WorkspaceExecuteCommand J.WorkspaceExecuteCommand
-- Nothing Nothing
-- registrations = J.RegistrationParams $ J.List [registration] registrations = J.RegistrationParams $ J.List [registration]
-- rid <- nextID funs rid <- nextID funs
-- send funs send funs
-- $ ReqRegisterCapability $ ReqRegisterCapability
-- $ fmServerRegisterCapabilityRequest rid registrations $ fmServerRegisterCapabilityRequest rid registrations
-- NotDidOpenTextDocument notif -> do NotDidOpenTextDocument notif -> do
-- let let
-- doc = notif doc = notif
-- ^.J.params ^.J.params
-- .J.textDocument .J.textDocument
-- .J.uri .J.uri
-- ver = notif ver = notif
-- ^.J.params ^.J.params
-- .J.textDocument .J.textDocument
-- .J.version .J.version
-- collectErrors funs collectErrors funs
-- (J.toNormalizedUri doc) (J.toNormalizedUri doc)
-- (J.uriToFilePath doc) (J.uriToFilePath doc)
-- (Just ver) (Just ver)
-- NotDidChangeTextDocument notif -> do NotDidChangeTextDocument notif -> do
-- let let
-- doc = notif doc = notif
-- ^.J.params ^.J.params
-- .J.textDocument .J.textDocument
-- .J.uri .J.uri
-- collectErrors funs collectErrors funs
-- (J.toNormalizedUri doc) (J.toNormalizedUri doc)
-- (J.uriToFilePath doc) (J.uriToFilePath doc)
-- (Just 0) (Just 0)
-- ReqDefinition req -> do ReqDefinition req -> do
-- stopDyingAlready funs req do stopDyingAlready funs req do
-- let uri = req^.J.params.J.textDocument.J.uri let uri = req^.J.params.J.textDocument.J.uri
-- let pos = posToRange $ req^.J.params.J.position let pos = posToRange $ req^.J.params.J.position
-- tree <- loadByVFS funs uri tree <- loadFromVFS funs uri
-- case Find.definitionOf pos tree of case Find.definitionOf pos tree of
-- Just defPos -> do Just defPos -> do
-- respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos] respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos]
-- Nothing -> do Nothing -> do
-- respondWith funs req RspDefinition $ J.MultiLoc [] respondWith funs req RspDefinition $ J.MultiLoc []
-- ReqFindReferences req -> do ReqFindReferences req -> do
-- stopDyingAlready funs req do stopDyingAlready funs req do
-- let uri = req^.J.params.J.textDocument.J.uri let uri = req^.J.params.J.textDocument.J.uri
-- let pos = posToRange $ req^.J.params.J.position let pos = posToRange $ req^.J.params.J.position
-- tree <- loadFromVFS funs uri tree <- loadFromVFS funs uri
-- case Find.referencesOf pos tree of case Find.referencesOf pos tree of
-- Just refs -> do Just refs -> do
-- let locations = J.Location uri . rangeToLoc <$> refs let locations = J.Location uri . rangeToLoc <$> refs
-- respondWith funs req RspFindReferences $ J.List locations respondWith funs req RspFindReferences $ J.List locations
-- Nothing -> do Nothing -> do
-- respondWith funs req RspFindReferences $ J.List [] respondWith funs req RspFindReferences $ J.List []
-- _ -> U.logs "unknown msg" _ -> U.logs "unknown msg"
-- respondWith respondWith
-- :: Core.LspFuncs () :: Core.LspFuncs ()
-- -> J.RequestMessage J.ClientMethod req rsp -> J.RequestMessage J.ClientMethod req rsp
-- -> (J.ResponseMessage rsp -> FromServerMessage) -> (J.ResponseMessage rsp -> FromServerMessage)
-- -> rsp -> rsp
-- -> IO () -> IO ()
-- respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp
-- stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO () stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO ()
-- stopDyingAlready funs req = flip catch \(e :: SomeException) -> do stopDyingAlready funs req = flip catch \(e :: SomeException) -> do
-- Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError
-- $ fromString $ fromString
-- $ "this happened: " ++ show e $ "this happened: " ++ show e
-- posToRange :: J.Position -> Range posToRange :: J.Position -> Range
-- posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) "" posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) ""
-- rangeToLoc :: Range -> J.Range rangeToLoc :: Range -> J.Range
-- rangeToLoc (Range (a, b, _) (c, d, _) _) = rangeToLoc (Range (a, b, _) (c, d, _) _) =
-- J.Range J.Range
-- (J.Position (a - 1) (b - 1)) (J.Position (a - 1) (b - 1))
-- (J.Position (c - 1) (d - 1)) (J.Position (c - 1) (d - 1))
-- loadFromVFS loadFromVFS
-- :: Core.LspFuncs () :: Core.LspFuncs ()
-- -> J.Uri -> J.Uri
-- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) -> IO (LIGO Info')
-- loadFromVFS funs uri = do loadFromVFS funs uri = do
-- Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
-- let txt = virtualFileText vf let txt = virtualFileText vf
-- let Just fin = J.uriToFilePath uri let Just fin = J.uriToFilePath uri
-- (tree, _) <- runParser contract (Text fin txt) (tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt)
-- return $ addLocalScopes tree return $ addLocalScopes tree
-- loadByURI loadByURI
-- :: J.Uri :: J.Uri
-- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) -> IO (LIGO Info')
-- loadByURI uri = do loadByURI uri = do
-- case J.uriToFilePath uri of case J.uriToFilePath uri of
-- Just fin -> do Just fin -> do
-- (tree, _) <- runParser contract (Path fin) (tree, _) <- runParserM . recognise =<< toParseTree (Path fin)
-- return $ addLocalScopes tree return $ addLocalScopes tree
-- Nothing -> do Nothing -> do
-- error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed." error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
-- collectErrors collectErrors
-- :: Core.LspFuncs () :: Core.LspFuncs ()
-- -> J.NormalizedUri -> J.NormalizedUri
-- -> Maybe FilePath -> Maybe FilePath
-- -> Maybe Int -> Maybe Int
-- -> IO () -> IO ()
-- collectErrors funs uri path version = do collectErrors funs uri path version = do
-- case path of case path of
-- Just fin -> do Just fin -> do
-- (tree, errs) <- runParser contract (Path fin) (tree, errs) <- runParserM . recognise =<< toParseTree (Path fin)
-- Core.publishDiagnosticsFunc funs 100 uri version Core.publishDiagnosticsFunc funs 100 uri version
-- $ partitionBySource $ partitionBySource
-- $ map errorToDiag (errs <> errors tree) $ 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 :: (Range, Err Text a) -> J.Diagnostic
-- errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _) _))) = errorToDiag (getRange -> (Range (sl, sc, _) (el, ec, _) _), Err what) =
-- J.Diagnostic J.Diagnostic
-- (J.Range begin end) (J.Range begin end)
-- (Just J.DsError) (Just J.DsError)
-- Nothing Nothing
-- (Just "ligo-lsp") (Just "ligo-lsp")
-- (Text.pack [i|Expected #{what}|]) (Text.pack [i|Expected #{what}|])
-- (Just $ J.List[]) (Just $ J.List[])
-- where where
-- begin = J.Position (sl - 1) (sc - 1) begin = J.Position (sl - 1) (sc - 1)
-- end = J.Position (el - 1) (ec - 1) end = J.Position (el - 1) (ec - 1)
-- exit :: Int -> IO () exit :: Int -> IO ()
-- exit 0 = exitSuccess exit 0 = exitSuccess
-- exit n = exitWith (ExitFailure n) exit n = exitWith (ExitFailure n)

121
tools/lsp/squirrel/src/AST/Find.hs
View File

@ -1,70 +1,75 @@
module AST.Find where module AST.Find where
-- import Control.Monad import Control.Monad
-- import AST.Types import Data.Maybe (listToMaybe)
-- import AST.Scope
-- import AST.Parser
-- import Tree import Duplo.Tree
-- import Range import Duplo.Pretty
-- import Pretty import Duplo.Lattice
-- import Product
-- import Data.Text (Text) import Data.Text (Text)
-- -- import Debug.Trace
-- type CanSearch xs = import AST.Types
-- ( Contains [ScopedDecl] xs import AST.Scope
-- , Contains Range xs
-- , Contains (Maybe Category) xs
-- , Contains [Text] xs
-- , Pretty (Product xs)
-- )
-- findScopedDecl import Product
-- :: CanSearch xs import Range
-- => 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
-- definitionOf -- import Debug.Trace
-- :: CanSearch xs
-- => Range
-- -> Pascal (Product xs)
-- -> Maybe Range
-- definitionOf pos tree =
-- _sdOrigin <$> findScopedDecl pos tree
-- typeOf type CanSearch xs =
-- :: CanSearch xs ( Contains [ScopedDecl] xs
-- => Range , Contains Range xs
-- -> Pascal (Product xs) , Contains (Maybe Category) xs
-- -> Maybe (Either (Pascal ()) Kind) , Contains [Text] xs
-- typeOf pos tree = , Pretty (Product xs)
-- _sdType =<< findScopedDecl pos tree , Eq (Product xs)
)
-- implementationOf findScopedDecl
-- :: CanSearch xs :: CanSearch xs
-- => Range => Range
-- -> Pascal (Product xs) -> LIGO (Product xs)
-- -> Maybe Range -> Maybe ScopedDecl
-- implementationOf pos tree = findScopedDecl pos tree = do
-- _sdBody =<< findScopedDecl pos tree 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 definitionOf
-- :: CanSearch xs :: CanSearch xs
-- => Range => Range
-- -> Pascal (Product xs) -> LIGO (Product xs)
-- -> Maybe [Range] -> Maybe Range
-- referencesOf pos tree = definitionOf pos tree =
-- _sdRefs <$> findScopedDecl 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

8
tools/lsp/squirrel/src/AST/Scope.hs
View File

@ -56,6 +56,12 @@ data ScopedDecl = ScopedDecl
} }
deriving Show via PP 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. -- | The kind.
data Kind = Star data Kind = Star
deriving Show via PP Kind deriving Show via PP Kind
@ -91,6 +97,8 @@ ofCategory Variable _ = True
ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
ofCategory _ _ = False ofCategory _ _ = False
type Info' = Product [[ScopedDecl], Maybe Category, [Text], Range, ShowRange]
instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where
ascribe (ds :> _ :> _ :> r :> _) d = ascribe (ds :> _ :> _ :> r :> _) d =
color 3 (fsep (map (pp . _sdName) ds)) color 3 (fsep (map (pp . _sdName) ds))

2
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -25,7 +25,7 @@ type RawLigoList =
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
, RawContract, TypeName, FieldName, Language , RawContract, TypeName, FieldName, Language
, Err Text, Parameters, Ctor , Err Text, Parameters, Ctor, Contract
] ]
data Undefined it data Undefined it

19
tools/lsp/squirrel/src/ParseTree.hs
View File

@ -21,7 +21,6 @@ module ParseTree
where where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.IORef
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
@ -101,20 +100,13 @@ toParseTree = unsafePerformIO $ debounced inner
src <- srcToBytestring fin src <- srcToBytestring fin
idCounter <- newIORef 0
BS.useAsCStringLen src \(str, len) -> do BS.useAsCStringLen src \(str, len) -> do
tree <- ts_parser_parse_string parser nullPtr str len tree <- ts_parser_parse_string parser nullPtr str len
withRootNode tree (peek >=> go src idCounter) withRootNode tree (peek >=> go src)
where where
nextID :: IORef Int -> IO Int go :: ByteString -> Node -> IO RawTree
nextID ref = do go src node = do
modifyIORef' ref (+ 1)
readIORef ref
go :: ByteString -> IORef Int -> Node -> IO RawTree
go src idCounter node = do
let count = fromIntegral $ nodeChildCount node let count = fromIntegral $ nodeChildCount node
allocaArray count \children -> do allocaArray count \children -> do
alloca \tsNodePtr -> do alloca \tsNodePtr -> do
@ -124,7 +116,7 @@ toParseTree = unsafePerformIO $ debounced inner
peekElemOff children i peekElemOff children i
trees <- for nodes \node' -> do trees <- for nodes \node' -> do
(only -> (r :> _, tree :: ParseTree RawTree)) <- go src idCounter node' (only -> (r :> _, tree :: ParseTree RawTree)) <- go src node'
field <- field <-
if nodeFieldName node' == nullPtr if nodeFieldName node' == nullPtr
then return "" then return ""
@ -138,9 +130,6 @@ toParseTree = unsafePerformIO $ debounced inner
finish2D = nodeEndPoint node finish2D = nodeEndPoint node
i = fromIntegral i = fromIntegral
treeID <- nextID idCounter
fID <- nextID idCounter
let let
range = Range range = Range
{ rStart = { rStart =

15
tools/lsp/squirrel/src/Parser.hs
View File

@ -29,7 +29,7 @@ import Debug.Trace
4) On leaving, move move comments from 2 to 1. 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 () ([], []) runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p () ([], [])
runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a) runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a)
@ -40,22 +40,23 @@ runParserM1 cs p = do
put s1 put s1
return a return a
type ParserM = RWST () [Err Text ()] ([Text], [Text]) IO type Msg = (Range, Err Text ())
type ParserM1 = MaybeT (RWST [RawTree] [Err Text ()] ([Text], [Text]) IO) type ParserM = RWST () [Msg] ([Text], [Text]) IO
type ParserM1 = MaybeT (RWST [RawTree] [Msg] ([Text], [Text]) IO)
data Failure = Failure String data Failure = Failure String
deriving stock (Show) deriving stock (Show)
deriving anyclass (Exception) deriving anyclass (Exception)
instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where 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 (comms, rest) = allComments cs
let (comms1, _) = allComments $ reverse rest let (comms1, _) = allComments $ reverse rest
modify $ first (++ comms) modify $ first (++ comms)
modify $ second (++ reverse comms1) modify $ second (++ reverse comms1)
let errs = allErrors cs let errs = allErrors cs
tell $ fmap Err errs tell $ fmap (\t -> (r, Err t)) errs
after _ _ = do after _ _ = do
modify \(x, y) -> (y, []) modify \(x, y) -> (y, [])
@ -112,6 +113,10 @@ data ShowRange
= Y | N = Y | N
deriving stock Eq deriving stock Eq
instance Pretty ShowRange where
pp Y = "Yau"
pp N = "Nah"
type Info = Product [[Text], Range, ShowRange] type Info = Product [[Text], Range, ShowRange]
type PreInfo = Product [Range, ShowRange] type PreInfo = Product [Range, ShowRange]

2
tools/lsp/squirrel/stack.yaml
View File

@ -41,7 +41,7 @@ extra-deps:
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
- fastsum-0.1.1.1 - fastsum-0.1.1.1
- git: https://github.com/serokell/duplo.git - git: https://github.com/serokell/duplo.git
commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
# - acme-missiles-0.3 # - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

6
tools/lsp/squirrel/stack.yaml.lock
View File

@ -45,11 +45,11 @@ packages:
git: https://github.com/serokell/duplo.git git: https://github.com/serokell/duplo.git
pantry-tree: pantry-tree:
size: 557 size: 557
sha256: d8258e8fa560d07da3bf4a5e7f956494a8d1b374e67c3af1b7b6875f8175a309 sha256: bdd68d3e171c6a2311ca101cc654a5cca984a1e8ce745e928287a40fa8f5a0ff
commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
original: original:
git: https://github.com/serokell/duplo.git git: https://github.com/serokell/duplo.git
commit: 3bb313af0c78c669c1b39ab2f912508b148e8aae commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
snapshots: snapshots:
- completed: - completed:
size: 493124 size: 493124