Tie all up
This commit is contained in:
Kirill Andreev
parent
9f29dab195
commit
31274e1507
@ -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/recognises/loop.ligo"
|
||||
errCode <- mainLoop
|
||||
exit errCode
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
send :: Core.LspFuncs () -> FromServerMessage -> IO ()
|
||||
send = Core.sendFunc
|
||||
|
||||
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)
|
||||
|
||||
U.logs [i|Client: ${msg}|]
|
||||
|
||||
case msg of
|
||||
RspFromClient {} -> do
|
||||
return ()
|
||||
for_ [1.. 100] \_ -> do
|
||||
print . length . show . pp =<< sample' "../../../src/test/contracts/loop.ligo"
|
||||
-- errCode <- mainLoop
|
||||
-- exit errCode
|
||||
|
||||
-- mainLoop :: IO Int
|
||||
-- mainLoop = do
|
||||
-- chan <- atomically newTChan :: IO (TChan FromClientMessage)
|
||||
NotInitialized _notif -> do
|
||||
let
|
||||
registration = J.Registration
|
||||
"lsp-haskell-registered"
|
||||
J.WorkspaceExecuteCommand
|
||||
Nothing
|
||||
registrations = J.RegistrationParams $ J.List [registration]
|
||||
|
||||
-- let
|
||||
-- callbacks = Core.InitializeCallbacks
|
||||
-- { Core.onInitialConfiguration = const $ Right ()
|
||||
-- , Core.onConfigurationChange = const $ Right ()
|
||||
-- , Core.onStartup = \lFuns -> do
|
||||
-- _ <- forkIO $ eventLoop lFuns chan
|
||||
-- return Nothing
|
||||
-- }
|
||||
rid <- nextID funs
|
||||
send funs
|
||||
$ ReqRegisterCapability
|
||||
$ fmServerRegisterCapabilityRequest rid registrations
|
||||
|
||||
-- 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
|
||||
-- ]
|
||||
NotDidOpenTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.uri
|
||||
|
||||
-- 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
|
||||
-- }
|
||||
ver = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.version
|
||||
|
||||
-- lspOptions :: Core.Options
|
||||
-- lspOptions = def
|
||||
-- { Core.textDocumentSync = Just syncOptions
|
||||
-- , Core.executeCommandCommands = Just ["lsp-hello-command"]
|
||||
-- }
|
||||
collectErrors funs
|
||||
(J.toNormalizedUri doc)
|
||||
(J.uriToFilePath doc)
|
||||
(Just ver)
|
||||
|
||||
-- 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
|
||||
-- }
|
||||
NotDidChangeTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.uri
|
||||
|
||||
-- passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
|
||||
-- passHandler rin c notification = do
|
||||
-- atomically $ writeTChan rin (c notification)
|
||||
collectErrors funs
|
||||
(J.toNormalizedUri doc)
|
||||
(J.uriToFilePath doc)
|
||||
(Just 0)
|
||||
|
||||
-- responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage
|
||||
-- responseHandlerCb _rin resp = do
|
||||
-- U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
|
||||
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 []
|
||||
|
||||
-- send :: Core.LspFuncs () -> FromServerMessage -> IO ()
|
||||
-- send = Core.sendFunc
|
||||
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 []
|
||||
|
||||
-- nextID :: Core.LspFuncs () -> IO J.LspId
|
||||
-- nextID = Core.getNextReqId
|
||||
_ -> U.logs "unknown msg"
|
||||
|
||||
-- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
|
||||
-- eventLoop funs chan = do
|
||||
-- forever do
|
||||
-- msg <- atomically (readTChan chan)
|
||||
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
|
||||
|
||||
-- U.logs [i|Client: ${msg}|]
|
||||
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
|
||||
|
||||
-- case msg of
|
||||
-- RspFromClient {} -> do
|
||||
-- return ()
|
||||
posToRange :: J.Position -> Range
|
||||
posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) ""
|
||||
|
||||
-- NotInitialized _notif -> do
|
||||
-- let
|
||||
-- registration = J.Registration
|
||||
-- "lsp-haskell-registered"
|
||||
-- J.WorkspaceExecuteCommand
|
||||
-- Nothing
|
||||
-- registrations = J.RegistrationParams $ J.List [registration]
|
||||
rangeToLoc :: Range -> J.Range
|
||||
rangeToLoc (Range (a, b, _) (c, d, _) _) =
|
||||
J.Range
|
||||
(J.Position (a - 1) (b - 1))
|
||||
(J.Position (c - 1) (d - 1))
|
||||
|
||||
-- rid <- nextID funs
|
||||
-- send funs
|
||||
-- $ ReqRegisterCapability
|
||||
-- $ fmServerRegisterCapabilityRequest rid registrations
|
||||
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
|
||||
|
||||
-- NotDidOpenTextDocument notif -> do
|
||||
-- let
|
||||
-- doc = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.uri
|
||||
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."
|
||||
|
||||
-- ver = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.version
|
||||
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))
|
||||
|
||||
-- collectErrors funs
|
||||
-- (J.toNormalizedUri doc)
|
||||
-- (J.uriToFilePath doc)
|
||||
-- (Just ver)
|
||||
Nothing -> error "TODO: implement URI file loading"
|
||||
|
||||
-- NotDidChangeTextDocument notif -> do
|
||||
-- let
|
||||
-- doc = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.uri
|
||||
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)
|
||||
|
||||
-- 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 []
|
||||
|
||||
-- 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"
|
||||
|
||||
-- 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
|
||||
|
||||
-- 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))
|
||||
|
||||
-- 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
|
||||
|
||||
-- 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."
|
||||
|
||||
-- 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)
|
||||
|
||||
-- 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)
|
||||
|
||||
-- exit :: Int -> IO ()
|
||||
-- exit 0 = exitSuccess
|
||||
-- exit n = exitWith (ExitFailure n)
|
||||
exit :: Int -> IO ()
|
||||
exit 0 = exitSuccess
|
||||
exit n = exitWith (ExitFailure n)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user