dhall-lsp-server: Turn imports into clickable links (#1121)

* Expose `localToPath` in Dhall.Import

Also modifies `localToPath` to return a relative path if the input was
relative, rather than resolving relative paths by appending the current
directory.

* Turn imports into clickable links

This implements a handler for 'Document Link' requests. As a result,
imports are now clickable!

* Recover original behaviour

dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs

@@ -5,6 +5,7 @@ module Dhall.LSP.Backend.Diagnostics
   , diagnose
   , Diagnosis(..)
   , explain
+  , embedsWithRanges
   , offsetToPosition
   , Position
   , positionFromMegaparsec
@@ -16,11 +17,13 @@ where
 
 import Dhall.Parser (SourcedException(..), Src(..), unwrap)
 import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..))
-import Dhall.Core (Expr(Note))
+import Dhall.Core (Expr(Note, Embed), subExpressions)
 
 import Dhall.LSP.Util
 import Dhall.LSP.Backend.Dhall
 
+import Control.Lens (toListOf)
+import Control.Monad.Trans.Writer (Writer, execWriter, tell)
 import Data.Monoid ((<>))
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -137,3 +140,13 @@ positionToOffset txt (line, col) = if line < length ls
 offsetToPosition :: Text -> Int -> Position
 offsetToPosition txt off = (length ls - 1, Text.length (NonEmpty.last ls))
   where ls = lines' (Text.take off txt)
+
+-- | Collect all `Embed` constructors (i.e. imports if the expression has type
+--   `Expr Src Import`) wrapped in a Note constructor and return them together
+--   with their associated range in the source code.
+embedsWithRanges :: Expr Src a -> [(Range, a)]
+embedsWithRanges =
+  map (\(src, a) -> (rangeFromDhall src, a)) . execWriter . go
+  where go :: Expr Src a -> Writer [(Src, a)] ()
+        go (Note src (Embed a)) = tell [(src, a)]
+        go expr = mapM_ go (toListOf subExpressions expr)

dhall-lsp-server/src/Dhall/LSP/Handlers.hs

@@ -8,14 +8,15 @@ import qualified Language.Haskell.LSP.VFS as LSP
 import qualified Data.Aeson as J
 import qualified Yi.Rope as Rope
 
-import Dhall.Core (Expr, pretty)
+import Dhall.Core (Expr, pretty, Import(..), ImportHashed(..), ImportType(..), headers)
+import Dhall.Import (localToPath)
 import Dhall.Parser (Src(..))
 import Dhall.TypeCheck (X)
 
 import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
   fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader)
 import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
-  rangeFromDhall, diagnose)
+  rangeFromDhall, diagnose, embedsWithRanges)
 import Dhall.LSP.Backend.Formatting (formatExprWithHeader)
 import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
 import Dhall.LSP.Backend.Typing (typeAt, annotateLet)
@@ -36,6 +37,7 @@ import qualified Data.Text as Text
 import qualified Network.URI as URI
 import qualified Network.URI.Encode as URI
 import Text.Megaparsec (SourcePos(..), unPos)
+import System.FilePath
 
 
 -- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
@@ -181,6 +183,43 @@ hoverHandler request = do
     _ -> hoverExplain request
 
 
+documentLinkHandler :: J.DocumentLinkRequest -> HandlerM ()
+documentLinkHandler req = do
+  let uri = req ^. J.params . J.textDocument . J.uri
+  path <- case J.uriToFilePath uri of
+    Nothing -> throwE (Log, "Could not process document links; failed to convert\
+                            \ URI to file path.")
+    Just p -> return p
+  txt <- readUri uri
+  expr <- case parse txt of
+    Right e -> return e
+    Left _ -> throwE (Log, "Could not process document links; did not parse.")
+
+  let imports = embedsWithRanges expr :: [(Range, Import)]
+
+  let basePath = takeDirectory path
+
+  let go :: (Range, Import) -> IO [J.DocumentLink]
+      go (range, Import (ImportHashed _ (Local prefix file)) _) = do
+        filePath <- localToPath prefix file
+        let filePath' = basePath </> filePath  -- absolute file path
+        let url' = J.filePathToUri filePath'
+        let _range = rangeToJSON range
+        let _target = Just (J.getUri url')
+        return [J.DocumentLink {..}]
+
+      go (range, Import (ImportHashed _ (Remote url)) _) = do
+        let _range = rangeToJSON range
+        let url' = url { headers = Nothing }
+        let _target = Just (pretty url')
+        return [J.DocumentLink {..}]
+
+      go _ = return []
+
+  links <- liftIO $ mapM go imports
+  lspRespond LSP.RspDocumentLink req (J.List (concat links))
+
+
 diagnosticsHandler :: J.Uri -> HandlerM ()
 diagnosticsHandler uri = do
   txt <- readUri uri

dhall-lsp-server/src/Dhall/LSP/Server.hs

@@ -14,7 +14,7 @@ import qualified System.Log.Logger
 import Dhall.LSP.State
 import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler,
   didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler,
-  executeCommandHandler, documentFormattingHandler)
+  executeCommandHandler, documentFormattingHandler, documentLinkHandler)
 
 -- | The main entry point for the LSP server.
 run :: Maybe FilePath -> IO ()
@@ -73,6 +73,8 @@ lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
                      Just (J.ExecuteCommandOptions
                        (J.List ["dhall.server.lint",
                                 "dhall.server.annotateLet"]))
+                 , LSP.Core.documentLinkProvider =
+                    Just (J.DocumentLinkOptions { _resolveProvider = Just False })
                  }
 
 lspHandlers :: MVar ServerState -> LSP.Core.Handlers
@@ -87,4 +89,5 @@ lspHandlers state
         , LSP.Core.responseHandler                          = Just $ wrapHandler state nullHandler
         , LSP.Core.executeCommandHandler                    = Just $ wrapHandler state executeCommandHandler
         , LSP.Core.documentFormattingHandler                = Just $ wrapHandler state documentFormattingHandler
+        , LSP.Core.documentLinkHandler                      = Just $ wrapHandler state documentLinkHandler
         }

dhall/src/Dhall/Import.hs

@@ -104,6 +104,7 @@ module Dhall.Import (
     , exprToImport
     , load
     , loadWith
+    , localToPath
     , hashExpression
     , hashExpressionToCode
     , assertNoImports
@@ -437,6 +438,8 @@ instance Show HashMismatch where
         <>  "\n"
         <>  "↳ " <> show actualHash <> "\n"
 
+-- | Construct the file path corresponding to a local import. If the import is
+--   _relative_ then the resulting path is also relative.
 localToPath :: MonadIO io => FilePrefix -> File -> io FilePath
 localToPath prefix file_ = liftIO $ do
     let File {..} = file_
@@ -451,11 +454,10 @@ localToPath prefix file_ = liftIO $ do
             return "/"
 
         Parent -> do
-            pwd <- Directory.getCurrentDirectory
+            return ".."
-            return (FilePath.takeDirectory pwd)
 
         Here -> do
-            Directory.getCurrentDirectory
+            return "."
 
     let cs = map Text.unpack (file : components)
 
@@ -611,6 +613,7 @@ exprFromUncachedImport import_@(Import {..}) = do
     let resolveImport importType' = case importType' of
           Local prefix file -> liftIO $ do
               path   <- localToPath prefix file
+              absolutePath <- Directory.makeAbsolute path
               exists <- Directory.doesFileExist path
 
               if exists
@@ -619,7 +622,7 @@ exprFromUncachedImport import_@(Import {..}) = do
 
               text <- Data.Text.IO.readFile path
 
-              return (path, text, import_)
+              return (absolutePath, text, import_)
 
           Remote url@URL { headers = maybeHeadersExpression } -> do
               maybeHeadersAndExpression <- case maybeHeadersExpression of