diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs index a2daae2..1da5549 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Diagnostics.hs +++ b/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) diff --git a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs index 1866c01..592abcb 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs +++ b/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 diff --git a/dhall-lsp-server/src/Dhall/LSP/Server.hs b/dhall-lsp-server/src/Dhall/LSP/Server.hs index 6118e08..75f8e6f 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Server.hs +++ b/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 } diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 0b541a6..dce791b 100644 --- a/dhall/src/Dhall/Import.hs +++ b/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 (FilePath.takeDirectory pwd) + return ".." 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