Tie all up

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/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
+      NotInitialized _notif -> do
--- mainLoop = do
+        let
---     chan <- atomically newTChan :: IO (TChan FromClientMessage)
+          registration = J.Registration
+            "lsp-haskell-registered"
+            J.WorkspaceExecuteCommand
+            Nothing
+          registrations = J.RegistrationParams $ J.List [registration]
 
---     let
+        rid <- nextID funs
---       callbacks = Core.InitializeCallbacks
+        send funs
---         { Core.onInitialConfiguration = const $ Right ()
+          $ ReqRegisterCapability
---         , Core.onConfigurationChange = const $ Right ()
+          $ fmServerRegisterCapabilityRequest rid registrations
---         , Core.onStartup = \lFuns -> do
---             _ <- forkIO $ eventLoop lFuns chan
---             return Nothing
---         }
 
---     Core.setupLogger (Just "log.txt") [] L.INFO
+      NotDidOpenTextDocument notif -> do
---     CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt")
+        let
---   `catches`
+          doc = notif
---     [ Handler \(e :: SomeException) -> do
+            ^.J.params
---         print e
+             .J.textDocument
---         return 1
+             .J.uri
---     ]
 
--- syncOptions :: J.TextDocumentSyncOptions
+          ver = notif
--- syncOptions = J.TextDocumentSyncOptions
+            ^.J.params
---   { J._openClose         = Just True
+             .J.textDocument
---   , J._change            = Just J.TdSyncIncremental
+             .J.version
---   , J._willSave          = Just False
---   , J._willSaveWaitUntil = Just False
---   , J._save              = Just $ J.SaveOptions $ Just False
---   }
 
--- lspOptions :: Core.Options
+        collectErrors funs
--- lspOptions = def
+          (J.toNormalizedUri doc)
---   { Core.textDocumentSync       = Just syncOptions
+          (J.uriToFilePath doc)
---   , Core.executeCommandCommands = Just ["lsp-hello-command"]
+          (Just ver)
---   }
 
--- lspHandlers :: TChan FromClientMessage -> Core.Handlers
+      NotDidChangeTextDocument notif -> do
--- lspHandlers rin = def
+        let
---   { Core.initializedHandler                       = Just $ passHandler rin NotInitialized
+          doc = notif
---   , Core.definitionHandler                        = Just $ passHandler rin ReqDefinition
+            ^.J.params
---   , Core.referencesHandler                        = Just $ passHandler rin ReqFindReferences
+             .J.textDocument
---   , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin NotDidOpenTextDocument
+             .J.uri
---   , 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
+        collectErrors funs
--- passHandler rin c notification = do
+          (J.toNormalizedUri doc)
---   atomically $ writeTChan rin (c notification)
+          (J.uriToFilePath doc)
+          (Just 0)
 
--- responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage
+      ReqDefinition req -> do
--- responseHandlerCb _rin resp = do
+        stopDyingAlready funs req do
---   U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
+          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 ()
+      ReqFindReferences req -> do
--- send = Core.sendFunc
+        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
+      _ -> U.logs "unknown msg"
--- nextID = Core.getNextReqId
 
--- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
+respondWith
--- eventLoop funs chan = do
+  :: Core.LspFuncs ()
---   forever do
+  -> J.RequestMessage J.ClientMethod req rsp
---     msg <- atomically (readTChan chan)
+  -> (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
+posToRange :: J.Position -> Range
---       RspFromClient {} -> do
+posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) ""
---         return ()
 
---       NotInitialized _notif -> do
+rangeToLoc :: Range -> J.Range
---         let
+rangeToLoc (Range (a, b, _) (c, d, _) _) =
---           registration = J.Registration
+  J.Range
---             "lsp-haskell-registered"
+    (J.Position (a - 1) (b - 1))
---             J.WorkspaceExecuteCommand
+    (J.Position (c - 1) (d - 1))
---             Nothing
---           registrations = J.RegistrationParams $ J.List [registration]
 
---         rid <- nextID funs
+loadFromVFS
---         send funs
+  :: Core.LspFuncs ()
---           $ ReqRegisterCapability
+  -> J.Uri
---           $ fmServerRegisterCapabilityRequest rid registrations
+  -> 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
+loadByURI
---         let
+  :: J.Uri
---           doc = notif
+  -> IO (LIGO Info')
---             ^.J.params
+loadByURI uri = do
---              .J.textDocument
+  case J.uriToFilePath uri of
---              .J.uri
+    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
+collectErrors
---             ^.J.params
+  :: Core.LspFuncs ()
---              .J.textDocument
+  -> J.NormalizedUri
---              .J.version
+  -> 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
+    Nothing -> error "TODO: implement URI file loading"
---           (J.toNormalizedUri doc)
---           (J.uriToFilePath doc)
---           (Just ver)
 
---       NotDidChangeTextDocument notif -> do
+errorToDiag :: (Range, Err Text a) -> J.Diagnostic
---         let
+errorToDiag (getRange -> (Range (sl, sc, _) (el, ec, _) _), Err what) =
---           doc = notif
+  J.Diagnostic
---             ^.J.params
+    (J.Range begin end)
---              .J.textDocument
+    (Just J.DsError)
---              .J.uri
+    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
+exit :: Int -> IO ()
---           (J.toNormalizedUri doc)
+exit 0 = exitSuccess
---           (J.uriToFilePath doc)
+exit n = exitWith (ExitFailure n)
---           (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)

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 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

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))

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

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
+        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
           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  =

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 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
   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]
 

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

tools/lsp/squirrel/stack.yaml.lock

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