[LIGO-42] Support for document symbols

Problem: We want to be able to extract document symbols from some
ligo contract that are realised by @haskell-lsp@ client.

Solution: Implement `extractDocumentSymbols` and integrate it with
@haskell-lsp@.

tools/lsp/squirrel/app/Main.hs

@@ -104,6 +104,7 @@ lspHandlers rin =
       -- , Core.completionResolveHandler                 = Just $ passHandler rin ReqCompletionItemResolve
     , Core.foldingRangeHandler = Just $ passHandler rin ReqFoldingRange
     , Core.hoverHandler = Just $ passHandler rin ReqHover
+    , Core.documentSymbolHandler = Just $ passHandler rin ReqDocumentSymbols
     }
 
 passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
@@ -209,6 +210,7 @@ eventLoop funs chan = do
         stopDyingAlready funs req $ do
           U.logs $ "got completion resolve request: " <> show req
           respondWith funs req RspCompletionItemResolve (req ^. J.params)
+
       ReqFoldingRange req -> do
         stopDyingAlready funs req $ do
           let uri = req ^. J.params . J.textDocument . J.uri
@@ -233,6 +235,12 @@ eventLoop funs chan = do
                 RspHover $ Core.makeResponseMessage req (hoverDecl pos tree)
           Core.sendFunc funs response
 
+      ReqDocumentSymbols req -> do
+        let uri = req ^. J.params . J.textDocument . J.uri
+        tree <- loadFromVFS funs uri
+        result <- extractDocumentSymbols uri tree
+        respondWith funs req RspDocumentSymbols (J.DSSymbolInformation $ J.List result)
+
       _ -> U.logs "unknown msg"
 
 respondWith

tools/lsp/squirrel/src/AST/Capabilities.hs

@@ -5,3 +5,4 @@ import AST.Capabilities.Completion as Exports
 import AST.Capabilities.Find as Exports
 import AST.Capabilities.Folding as Exports
 import AST.Capabilities.Hover as Exports
+import AST.Capabilities.DocumentSymbol as Exports

tools/lsp/squirrel/src/AST/Capabilities/DocumentSymbol.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module AST.Capabilities.DocumentSymbol where
+
+import Control.Monad.Catch.Pure (MonadCatch)
+import Control.Monad.Writer.Strict
+import Data.Maybe (fromMaybe)
+import Data.Text
+import Duplo (match)
+import Duplo.Pretty
+import Duplo.Tree (Visit (Visit), visit)
+import Language.Haskell.LSP.Types (SymbolInformation (..))
+import qualified Language.Haskell.LSP.Types as J
+
+import AST.Capabilities.Find
+import AST.Scope
+import AST.Skeleton
+import Product
+import Range
+-- | Extract document symbols for some specific parsed ligo contract which
+-- is realisable by @haskell-lsp@ client.
+extractDocumentSymbols
+  :: forall m.
+     (MonadCatch m)
+  => J.Uri
+  -> LIGO Info'
+  -> m [SymbolInformation]
+extractDocumentSymbols uri tree = execWriterT . visit handlers $ tree
+  where
+    handlers =
+      [ Visit @Binding $ \case
+          (_, Function _ (match @Name -> Just (getElem @Range -> r, _)) _ _ _)->
+            tellScopedDecl
+              r
+              J.SkFunction
+              (\_ -> Nothing)
+
+          -- TODO: currently we do not count imports as declarations in scopes
+          (_, Include (match @Constant -> Just (getElem @Range -> r, _))) ->
+            tellSymbolInfo
+              r
+              J.SkNamespace
+              ("some import at " <> pack (show r))
+
+          (_, TypeDecl (match @TypeName -> Just (getElem @Range -> r, _)) _) ->
+            tellScopedDecl
+              r
+              J.SkTypeParameter
+              (\_ -> Nothing)
+
+          (_, Const (match @Name -> Just (getElem @Range -> r, _)) _ _) ->
+            tellScopedDecl
+              r
+              J.SkConstant
+              (\ScopedDecl {_sdName} -> Just ("const " <> _sdName))
+
+          (_, Var (match @Name -> Just (getElem @Range -> r, _)) _ _) ->
+            tellScopedDecl
+              r
+              J.SkVariable
+              (\ScopedDecl {_sdName} -> Just ("var " <> _sdName))
+
+          _ -> pure ()
+      ]
+
+    -- | Tries to find scoped declaration and apply continuation to it or
+    -- ignore the declaration if not found.
+    withScopedDecl
+      :: Range
+      -> (ScopedDecl -> WriterT [SymbolInformation] m ())
+      -> WriterT [SymbolInformation] m ()
+    withScopedDecl r f = maybe (pure ()) f (findScopedDecl r tree)
+
+    -- | Tell to the writer symbol information that we may find in scope or
+    -- just ignore it and return `[]`.
+    tellScopedDecl
+      :: Range
+      -> J.SymbolKind
+      -> (ScopedDecl -> Maybe Text)
+      -> WriterT [SymbolInformation] m ()
+    tellScopedDecl range kind mkName =
+      withScopedDecl range $ \sd@ScopedDecl{..} ->
+        tell
+          [ SymbolInformation
+              { _name = fromMaybe _sdName (mkName sd)
+              , _deprecated = Nothing
+              , _kind = kind
+              , _containerName = matchContainerName kind
+              , _location = J.Location uri $ toLSPRange range
+              }
+          ]
+
+    -- | Tell to the writer some arbitrary symbol info. This is similar to
+    -- @tellScopedDecl@ but it does not search for symbol in scope and always
+    -- returns non-empty value.
+    tellSymbolInfo
+      :: Range
+      -> J.SymbolKind
+      -> Text
+      -> WriterT [SymbolInformation] m ()
+    tellSymbolInfo range kind name =
+        tell
+          [ SymbolInformation
+              { _name = name
+              , _deprecated = Nothing
+              , _kind = kind
+              , _containerName = matchContainerName kind
+              , _location = J.Location uri $ toLSPRange range
+              }
+          ]
+
+    -- | Helper function that associates container name with its container type
+    -- defined for the sole purpose of minimising the amount of arguments for `tellScopedDecl`.
+    matchContainerName = \case
+      J.SkTypeParameter -> Just "type"
+      J.SkNamespace -> Just "import"
+      J.SkConstant -> Just "const declaration"
+      J.SkVariable -> Just "var declaration"
+      J.SkFunction -> Just "function"
+      _ -> Nothing

tools/lsp/squirrel/src/Range.hs

@@ -58,13 +58,14 @@ instance Contains Range xs => HasRange (Product xs) where
   getRange = getElem
 
 -- | Convert `squirrel` range to `haskell-lsp` range.
+-- Note that we consider the first line to be at position 1.
 toLSPRange :: Range -> LSP.Range
 toLSPRange Range
   { rStart  = (rsl, rsc, _)
   , rFinish = (rfl, rfc, _)
   } = LSP.Range
-  { LSP._start = LSP.Position { LSP._line = rsl, LSP._character = rsc }
+  { LSP._start = LSP.Position { LSP._line = rsl - 1, LSP._character = rsc }
-  , LSP._end   = LSP.Position { LSP._line = rfl, LSP._character = rfc }
+  , LSP._end   = LSP.Position { LSP._line = rfl - 1, LSP._character = rfc }
   }
 
 -- | Extract textual representation of given range.