diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for dhall-lsp-server + +## unreleased + - whole document formatting + - correctly show location of import errors +## 0.0.1.0 + - diagnostic output diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 PanAeon + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# dhall-lsp-server + +This is a [Language Server Protocol](https://microsoft.github.io/language-server-protocol/) server implementation for the [Dhall](https://dhall-lang.org) programming language. + + +For installation or development instructions, see: + +* [`dhall-haskell` - `README`](https://github.com/dhall-lang/dhall-haskell/blob/master/README.md) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,65 @@ +{-| This module contains the top-level entrypoint and options parsing for the + @dhall-lsp-server@ executable +-} + +module Main + ( main + ) +where + +import Options.Applicative (Parser, ParserInfo) +import qualified Options.Applicative +import Control.Applicative ((<|>)) +import Data.Monoid ((<>)) + +import qualified Dhall.LSP.Server + +-- | Top-level program options +data Options = Options { + command :: Mode + , logFile :: Maybe FilePath +} + +-- | The mode in which to run @dhall-lsp-server@ +data Mode = Version | LSPServer + +parseOptions :: Parser Options +parseOptions = + Options <$> parseMode <*> Options.Applicative.optional parseLogFile + where + parseLogFile = Options.Applicative.strOption + (Options.Applicative.long "log" <> Options.Applicative.help + "If present writes debug output to the specified file" + ) + + +subcommand :: String -> String -> Parser a -> Parser a +subcommand name description parser = Options.Applicative.hsubparser + (Options.Applicative.command name parserInfo + <> Options.Applicative.metavar name + ) + where + parserInfo = Options.Applicative.info + parser + (Options.Applicative.fullDesc <> Options.Applicative.progDesc description) + +parseMode :: Parser Mode +parseMode = + subcommand "version" "Display version" (pure Version) <|> pure LSPServer + +parserInfoOptions :: ParserInfo Options +parserInfoOptions = Options.Applicative.info + (Options.Applicative.helper <*> parseOptions) + (Options.Applicative.progDesc "LSP server for the Dhall language" + <> Options.Applicative.fullDesc + ) + +runCommand :: Options -> IO () +runCommand Options {..} = case command of + Version -> putStrLn ("0.0.1.1" :: String) + LSPServer -> Dhall.LSP.Server.run logFile + +-- | Entry point for the @dhall-lsp-server@ executable +main :: IO () +main = do options <- Options.Applicative.execParser parserInfoOptions + runCommand options diff --git a/dhall-lsp-server.cabal b/dhall-lsp-server.cabal new file mode 100644 --- /dev/null +++ b/dhall-lsp-server.cabal @@ -0,0 +1,125 @@ +cabal-version: 1.12 +name: dhall-lsp-server +version: 1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/dhall-lang/dhall-haskell/dhall-lsp-server#readme +bug-reports: https://github.com/dhall-lang/dhall-haskell/issues +author: panaeon +maintainer: Gabriel Gonzalez +copyright: 2019 panaeon +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/dhall-lang/dhall-haskell + +library + exposed-modules: + Dhall.LSP.Backend.Dhall + Dhall.LSP.Backend.Diagnostics + Dhall.LSP.Backend.Freezing + Dhall.LSP.Backend.Formatting + Dhall.LSP.Backend.Linting + Dhall.LSP.Backend.Parsing + Dhall.LSP.Backend.ToJSON + Dhall.LSP.Backend.Typing + Dhall.LSP.Handlers + Dhall.LSP.Server + Dhall.LSP.State + other-modules: + Paths_dhall_lsp_server + Dhall.LSP.Util + hs-source-dirs: + src + default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables + build-depends: + aeson >= 1.3.1.1 && < 1.5 + , aeson-pretty >= 0.8.7 && < 0.9 + , base >= 4.7 && < 5 + , bytestring >= 0.10.8.2 && < 0.11 + , containers >= 0.5.11.0 && < 0.7 + , cryptonite >= 0.25 && < 0.27 + , data-default >= 0.7.1.1 && < 0.8 + , dhall >= 1.25.0 && < 1.26 + , dhall-json >= 1.4 && < 1.5 + , dotgen >= 0.4.2 && < 0.5 + , filepath >= 1.4.2 && < 1.5 + , haskell-lsp >= 0.8.1.0 && < 0.9 + , hslogger >= 1.2.10 && < 1.4 + , lens >= 4.16.1 && < 4.18 + , lens-family-core >= 1.2.3 && < 2.1 + , megaparsec >= 7.0.2 && < 7.1 + , mtl >= 2.2.2 && < 2.3 + , network-uri >= 2.6.1.0 && < 2.7 + , optparse-applicative >= 0.14.3.0 && < 0.16 + , prettyprinter >= 1.2.1 && < 1.4 + , sorted-list >= 0.2.1.0 && < 0.3 + , stm >= 2.4.5.0 && < 2.6 + , text >= 1.2.3.0 && < 1.3 + , transformers >= 0.5.5.0 && < 0.6 + , unordered-containers >= 0.2.9.0 && < 0.3 + , uri-encode >= 1.5.0.5 && < 1.6 + , yi-rope >= 0.11 && < 0.12 + default-language: Haskell2010 + GHC-Options: -Wall -fwarn-incomplete-uni-patterns + if impl(eta) + buildable: False + + +executable dhall-lsp-server + main-is: Main.hs + other-modules: + Paths_dhall_lsp_server + hs-source-dirs: + app + default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables + ghc-options: -rtsopts + build-depends: + aeson + , base >=4.7 && <5 + , containers + , data-default + , dhall + , dhall-lsp-server + , filepath + , haskell-lsp + , hslogger + , lens + , lens-family-core + , megaparsec + , mtl + , optparse-applicative + , prettyprinter + , sorted-list + , stm + , text + , transformers + , unordered-containers + , yi-rope + default-language: Haskell2010 + GHC-Options: -Wall -fwarn-incomplete-uni-patterns + if impl(eta) + buildable: False + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: doctest + Main-Is: Main.hs + GHC-Options: -Wall + Build-Depends: + base , + directory >= 1.3.1.5 && < 1.4 , + filepath < 1.5 , + doctest >= 0.7.0 && < 0.17 + Other-Extensions: OverloadedStrings RecordWildCards + Default-Language: Haskell2010 + -- `doctest` doesn't work with `MIN_VERSION` macros before GHC 8 + -- + -- See: https://ghc.haskell.org/trac/ghc/ticket/10970 + if impl(ghc < 8.0) + Buildable: False diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import Data.Monoid ((<>)) +import System.FilePath (()) + +import qualified GHC.IO.Encoding +import qualified System.Directory +import qualified System.IO +import qualified Test.DocTest + +main :: IO () +main = do + + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + pwd <- System.Directory.getCurrentDirectory + prefix <- System.Directory.makeAbsolute pwd + + Test.DocTest.doctest + [ "--fast" + , "-XOverloadedStrings" + , "-XRecordWildCards" + , "-i" <> (prefix "src") + , prefix "src/Dhall/LSP/Backend/Diagnostics.hs" + ] diff --git a/src/Dhall/LSP/Backend/Dhall.hs b/src/Dhall/LSP/Backend/Dhall.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Dhall.hs @@ -0,0 +1,170 @@ +module Dhall.LSP.Backend.Dhall ( + FileIdentifier, + fileIdentifierFromFilePath, + fileIdentifierFromURI, + hashNormalToCode, + WellTyped, + fromWellTyped, + Normal, + fromNormal, + Cache, + emptyCache, + invalidate, + DhallError(..), + parse, + parseWithHeader, + load, + typecheck, + normalize + ) where + +import Dhall.Parser (Src) +import Dhall.TypeCheck (X) +import Dhall.Core (Expr) + +import qualified Dhall.Binary as Dhall +import qualified Dhall.Core as Dhall +import qualified Dhall.Import as Dhall +import qualified Dhall.Parser as Dhall +import qualified Dhall.TypeCheck as Dhall + +import qualified Data.Graph as Graph +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Network.URI as URI +import qualified Language.Haskell.LSP.Types as LSP.Types +import qualified Data.Text as Text + +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Text (Text) +import System.FilePath (splitDirectories, takeFileName, takeDirectory) +import Lens.Family (view, set) +import Control.Exception (SomeException, catch) +import Control.Monad.Trans.State.Strict (runStateT) +import Network.URI (URI) +import Data.Bifunctor (first) + +-- | A @FileIdentifier@ represents either a local file or a remote url. +newtype FileIdentifier = FileIdentifier Dhall.Chained + +-- | Construct a FileIdentifier from a local file path. +fileIdentifierFromFilePath :: FilePath -> FileIdentifier +fileIdentifierFromFilePath path = + let filename = Text.pack $ takeFileName path + directory = takeDirectory path + components = map Text.pack . reverse . splitDirectories $ directory + file = Dhall.File (Dhall.Directory components) filename + in FileIdentifier $ Dhall.chainedFromLocalHere Dhall.Absolute file Dhall.Code + +-- | Construct a FileIdentifier from a given URI. Supports only "file:" URIs. +fileIdentifierFromURI :: URI -> Maybe FileIdentifier +fileIdentifierFromURI uri + | URI.uriScheme uri == "file:" = do + path <- LSP.Types.uriToFilePath . LSP.Types.Uri . Text.pack + $ URI.uriToString id uri "" + return $ fileIdentifierFromFilePath path +fileIdentifierFromURI _ = Nothing + +-- | A well-typed expression. +newtype WellTyped = WellTyped {fromWellTyped :: Expr Src X} + +-- | A fully normalised expression. +newtype Normal = Normal {fromNormal :: Expr Src X} + +-- An import graph, represented by list of import dependencies. +type ImportGraph = [Dhall.Depends] + +-- | A cache maps Dhall imports to fully normalised expressions. By reusing +-- caches we can speeds up diagnostics etc. significantly! +data Cache = Cache ImportGraph (Map.Map Dhall.Chained Dhall.ImportSemantics) + +-- | The initial cache. +emptyCache :: Cache +emptyCache = Cache [] Map.empty + +-- | Invalidate any _unhashed_ imports of the given file. Hashed imports are +-- kept around as per +-- https://github.com/dhall-lang/dhall-lang/blob/master/standard/imports.md. +-- Transitively invalidates any imports depending on the changed file. +invalidate :: FileIdentifier -> Cache -> Cache +invalidate (FileIdentifier chained) (Cache dependencies cache) = + Cache dependencies' $ Map.withoutKeys cache invalidImports + where + imports = map Dhall.parent dependencies ++ map Dhall.child dependencies + + adjacencyLists = foldr + -- add reversed edges to adjacency lists + (\(Dhall.Depends parent child) -> Map.adjust (parent :) child) + -- starting from the discrete graph + (Map.fromList [ (i,[]) | i <- imports]) + dependencies + + (graph, importFromVertex, vertexFromImport) = Graph.graphFromEdges + [(node, node, neighbours) | (node, neighbours) <- Map.assocs adjacencyLists] + + -- compute the reverse dependencies, i.e. the imports reachable in the transposed graph + reachableImports import_ = + map (\(i,_,_) -> i) . map importFromVertex . concat $ + do vertex <- vertexFromImport import_ + return (Graph.reachable graph vertex) + + codeImport = Dhall.chainedChangeMode Dhall.Code chained + textImport = Dhall.chainedChangeMode Dhall.RawText chained + invalidImports = Set.fromList $ codeImport : reachableImports codeImport + ++ textImport : reachableImports textImport + + dependencies' = filter (\(Dhall.Depends parent child) -> Set.notMember parent invalidImports + && Set.notMember child invalidImports) dependencies + +-- | A Dhall error. Covers parsing, resolving of imports, typechecking and +-- normalisation. +data DhallError = ErrorInternal SomeException + | ErrorImportSourced (Dhall.SourcedException Dhall.MissingImports) + | ErrorTypecheck (Dhall.TypeError Src X) + | ErrorParse Dhall.ParseError + +-- | Parse a Dhall expression. +parse :: Text -> Either DhallError (Expr Src Dhall.Import) +parse = fmap snd . parseWithHeader + +-- | Parse a Dhall expression along with its "header", i.e. whitespace and +-- comments prefixing the actual code. +parseWithHeader :: Text -> Either DhallError (Text, Expr Src Dhall.Import) +parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText "" + +-- | Resolve all imports in an expression. +load :: FileIdentifier -> Expr Src Dhall.Import -> Cache -> + IO (Either DhallError (Cache, Expr Src X)) +load (FileIdentifier chained) expr (Cache graph cache) = do + let emptyStatus = Dhall.emptyStatus "" + status = -- reuse cache and import graph + set Dhall.cache cache . + set Dhall.graph graph . + -- set "root import" + set Dhall.stack (chained :| []) + $ emptyStatus + (do (expr', status') <- runStateT (Dhall.loadWith expr) status + let cache' = view Dhall.cache status' + graph' = view Dhall.graph status' + return . Right $ (Cache graph' cache', expr')) + `catch` (\e -> return . Left $ ErrorImportSourced e) + `catch` (\e -> return . Left $ ErrorInternal e) + +-- | Typecheck a fully resolved expression. Returns a certification that the +-- input was well-typed along with its (well-typed) type. +typecheck :: Expr Src X -> Either DhallError (WellTyped, WellTyped) +typecheck expr = case Dhall.typeOf expr of + Left err -> Left $ ErrorTypecheck err + Right typ -> Right (WellTyped expr, WellTyped typ) + +-- | Normalise a well-typed expression. +normalize :: WellTyped -> Normal +normalize (WellTyped expr) = Normal $ Dhall.normalize expr + +-- | Given a normal expression compute the hash (using the default standard +-- version) of its alpha-normal form. Returns the hash in the format used in +-- Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded). +hashNormalToCode :: Normal -> Text +hashNormalToCode (Normal expr) = + Dhall.hashExpressionToCode Dhall.defaultStandardVersion alphaNormal + where alphaNormal = Dhall.alphaNormalize expr diff --git a/src/Dhall/LSP/Backend/Diagnostics.hs b/src/Dhall/LSP/Backend/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Diagnostics.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE RecordWildCards #-} + +module Dhall.LSP.Backend.Diagnostics + ( DhallError + , diagnose + , Diagnosis(..) + , explain + , embedsWithRanges + , offsetToPosition + , Position + , positionFromMegaparsec + , positionToOffset + , Range(..) + , rangeFromDhall + , subtractPosition + ) +where + +import Dhall.Parser (SourcedException(..), Src(..), unwrap) +import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..)) +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 +import qualified Data.List.NonEmpty as NonEmpty +import qualified Text.Megaparsec as Megaparsec + +-- | A (line, col) pair representing a position in a source file; 0-based. +type Position = (Int, Int) +-- | A source code range. +data Range = Range {left, right :: Position} +-- | A diagnosis, optionally tagged with a source code range. +data Diagnosis = Diagnosis { + -- | Where the diagnosis came from, e.g. Dhall.TypeCheck. + doctor :: Text, + range :: Maybe Range, -- ^ The range of code the diagnosis concerns + diagnosis :: Text + } + + +-- | Give a short diagnosis for a given error that can be shown to the end user. +diagnose :: DhallError -> [Diagnosis] +diagnose (ErrorInternal e) = [Diagnosis { .. }] + where + doctor = "Dhall" + range = Nothing + diagnosis = + "An internal error has occurred while trying to process the Dhall file: " + <> tshow e + +diagnose (ErrorImportSourced (SourcedException src e)) = [Diagnosis { .. }] + where + doctor = "Dhall.Import" + range = Just (rangeFromDhall src) + diagnosis = tshow e + +diagnose (ErrorTypecheck e@(TypeError _ expr _)) = [Diagnosis { .. }] + where + doctor = "Dhall.TypeCheck" + range = fmap rangeFromDhall (note expr) + diagnosis = tshow e + +diagnose (ErrorParse e) = + [ Diagnosis { .. } | (diagnosis, range) <- zip diagnoses (map Just ranges) ] + where + doctor = "Dhall.Parser" + errors = (NonEmpty.toList . Megaparsec.bundleErrors . unwrap) e + diagnoses = map (Text.pack . Megaparsec.parseErrorTextPretty) errors + positions = + map (positionFromMegaparsec . snd) . fst $ Megaparsec.attachSourcePos + Megaparsec.errorOffset + errors + (Megaparsec.bundlePosState (unwrap e)) + texts = map parseErrorText errors + ranges = + [ rangeFromDhall (Src left' left' text) -- bit of a hack, but convenient. + | (left, text) <- zip positions texts + , let left' = positionToMegaparsec left ] + {- Since Dhall doesn't use custom errors (corresponding to the FancyError + ParseError constructor) we only need to handle the case of plain + Megaparsec errors (i.e. TrivialError), and only those who actually + include a list of tokens that we can compute the length of. -} + parseErrorText :: Megaparsec.ParseError Text s -> Text + parseErrorText (Megaparsec.TrivialError _ (Just (Megaparsec.Tokens text)) _) = + Text.pack (NonEmpty.toList text) + parseErrorText _ = "" + +-- | Give a detailed explanation for the given error; if no detailed explanation +-- is available return @Nothing@ instead. +explain :: DhallError -> Maybe Diagnosis +explain (ErrorTypecheck e@(TypeError _ expr _)) = Just + (Diagnosis { .. }) + where + doctor = "Dhall.TypeCheck" + range = fmap rangeFromDhall (note expr) + diagnosis = tshow (DetailedTypeError e) +explain _ = Nothing -- only type errors have detailed explanations so far + + +-- Given an annotated AST return the note at the top-most node. +note :: Expr s a -> Maybe s +note (Note s _) = Just s +note _ = Nothing + + +-- Megaparsec's positions are 1-based while ours are 0-based. +positionFromMegaparsec :: Megaparsec.SourcePos -> Position +positionFromMegaparsec (Megaparsec.SourcePos _ line col) = + (Megaparsec.unPos line - 1, Megaparsec.unPos col - 1) + +-- Line and column numbers can't be negative. Clamps to 0 just in case. +positionToMegaparsec :: Position -> Megaparsec.SourcePos +positionToMegaparsec (line, col) = Megaparsec.SourcePos "" + (Megaparsec.mkPos $ max 0 line + 1) + (Megaparsec.mkPos $ max 0 col + 1) + +addRelativePosition :: Position -> Position -> Position +addRelativePosition (x1, y1) (0, dy2) = (x1, y1 + dy2) +addRelativePosition (x1, _) (dx2, y2) = (x1 + dx2, y2) + +-- | prop> addRelativePosition pos (subtractPosition pos pos') == pos' +subtractPosition :: Position -> Position -> Position +subtractPosition (x1, y1) (x2, y2) | x1 == x2 = (0, y2 - y1) + | otherwise = (x2 - x1, y2) + +-- | Convert a source range from Dhalls @Src@ format. The returned range is +-- "tight", that is, does not contain any trailing whitespace. +rangeFromDhall :: Src -> Range +rangeFromDhall (Src left _right text) = Range (x1,y1) (x2,y2) + where + (x1,y1) = positionFromMegaparsec left + (dx2,dy2) = offsetToPosition text . Text.length $ Text.stripEnd text + (x2,y2) = addRelativePosition (x1,y1) (dx2,dy2) + +-- Convert a (line,column) position into the corresponding character offset +-- and back, such that the two are inverses of eachother. +positionToOffset :: Text -> Position -> Int +positionToOffset txt (line, col) = if line < length ls + then Text.length . unlines' $ take line ls ++ [Text.take col (ls !! line)] + else Text.length txt -- position lies outside txt + where ls = NonEmpty.toList (lines' txt) + +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/src/Dhall/LSP/Backend/Formatting.hs b/src/Dhall/LSP/Backend/Formatting.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Formatting.hs @@ -0,0 +1,25 @@ +module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where + +import Dhall.Core (Expr) +import Dhall.Pretty (CharacterSet(..), layoutOpts, prettyCharacterSet) + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty + +-- | Pretty-print the given Dhall expression. +formatExpr :: Pretty.Pretty b => Expr a b -> Text +formatExpr expr = formatExprWithHeader expr "" + +-- | Pretty-print the given Dhall expression, prepending the given a "header" +-- (usually consisting of comments and whitespace). +formatExprWithHeader :: Pretty.Pretty b => Expr a b -> Text -> Text +formatExprWithHeader expr header = Pretty.renderStrict + (Pretty.layoutSmart layoutOpts doc) + where + doc = + Pretty.pretty header + <> Pretty.unAnnotate (prettyCharacterSet Unicode expr) + <> "\n" + diff --git a/src/Dhall/LSP/Backend/Freezing.hs b/src/Dhall/LSP/Backend/Freezing.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Freezing.hs @@ -0,0 +1,57 @@ +module Dhall.LSP.Backend.Freezing ( + computeSemanticHash, + getAllImportsWithHashPositions, + getImportHashPosition, + stripHash +) where + +import Dhall.Parser (Src(..)) +import Dhall.Core (Expr(..), Import(..), ImportHashed(..), subExpressions) + +import Control.Lens (universeOf) +import Data.Text (Text) +import qualified Data.Text as Text + +import Dhall.LSP.Backend.Dhall (FileIdentifier, Cache, DhallError, typecheck, + normalize, hashNormalToCode, load) +import Dhall.LSP.Backend.Diagnostics (Range(..), rangeFromDhall, + positionFromMegaparsec, positionToOffset, subtractPosition) +import Dhall.LSP.Backend.Parsing (getImportHash) + +-- | Given an expression (potentially still containing imports) compute its +-- 'semantic' hash in the textual representation used to freeze Dhall imports. +computeSemanticHash :: FileIdentifier -> Expr Src Import -> Cache -> + IO (Either DhallError (Cache, Text)) +computeSemanticHash fileid expr cache = do + loaded <- load fileid expr cache + case loaded of + Left err -> return (Left err) + Right (cache', expr') -> case typecheck expr' of + Left err -> return (Left err) + Right (wt,_) -> do + return (Right (cache', hashNormalToCode (normalize wt))) + +stripHash :: Import -> Import +stripHash (Import (ImportHashed _ importType) mode) = + Import (ImportHashed Nothing importType) mode + +getImportHashPosition :: Src -> Maybe Range +getImportHashPosition src@(Src left _ text) = do + Src left' right' _ <- getImportHash src + let p0 = positionFromMegaparsec left + + -- sanitise the starting point + let p1 = positionFromMegaparsec left' + off1 = positionToOffset text (subtractPosition p0 p1) + Range _ left'' = rangeFromDhall (Src left left' (Text.take off1 text)) + + -- sanitise the end point + let Range _ right'' = rangeFromDhall (Src left right' text) + + return (Range left'' right'') + +getAllImportsWithHashPositions :: Expr Src Import -> [(Import, Range)] +getAllImportsWithHashPositions expr = + [ (i, range) | + Note src (Embed i) <- universeOf subExpressions expr, + Just range <- [getImportHashPosition src] ] diff --git a/src/Dhall/LSP/Backend/Linting.hs b/src/Dhall/LSP/Backend/Linting.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Linting.hs @@ -0,0 +1,52 @@ +module Dhall.LSP.Backend.Linting + ( Suggestion(..) + , suggest + , Dhall.lint + ) +where + +import Dhall.Parser (Src) +import Dhall.Core (Expr(..), Binding(..), Var(..), subExpressions, freeIn, Import) +import qualified Dhall.Lint as Dhall + +import Dhall.LSP.Backend.Diagnostics + +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty(..), tails, toList) +import Control.Lens (universeOf) + +data Suggestion = Suggestion { + range :: Range, + suggestion :: Text + } + +-- Diagnose nested let blocks. +diagLetInLet :: Expr Src a -> [Suggestion] +diagLetInLet (Note _ (Let _ (Note src (Let _ _)))) = + [Suggestion (rangeFromDhall src) "Superfluous 'in' before nested let binding"] +diagLetInLet _ = [] + +-- Given a (noted) let block compute all unused variables in the block. +unusedBindings :: Eq a => Expr s a -> [Text] +unusedBindings (Note _ (Let bindings d)) = concatMap + (\case + Binding var _ _ : [] | not (V var 0 `freeIn` d) -> [var] + Binding var _ _ : (b : bs) | not (V var 0 `freeIn` Let (b :| bs) d) -> [var] + _ -> []) + (toList $ tails bindings) +unusedBindings _ = [] + +-- Diagnose unused let bindings. +diagUnusedBinding :: Eq a => Expr Src a -> [Suggestion] +diagUnusedBinding e@(Note src (Let _ _)) = map + (\var -> + Suggestion (rangeFromDhall src) ("Unused let binding '" <> var <> "'")) + (unusedBindings e) +diagUnusedBinding _ = [] + +-- | Given an dhall expression suggest all the possible improvements that would +-- be made by the linter. +suggest :: Expr Src Import -> [Suggestion] +suggest expr = concat [ diagLetInLet e ++ diagUnusedBinding e + | e <- universeOf subExpressions expr ] diff --git a/src/Dhall/LSP/Backend/Parsing.hs b/src/Dhall/LSP/Backend/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Parsing.hs @@ -0,0 +1,124 @@ +module Dhall.LSP.Backend.Parsing + ( getImportHash + , getLetInner + , getLetAnnot + , getLetIdentifier + , getLamIdentifier + , getForallIdentifier) +where + +import Dhall.Src (Src(..)) +import Dhall.Parser +import Dhall.Parser.Token +import Dhall.Parser.Expression + +import Control.Applicative (optional) +import qualified Text.Megaparsec as Megaparsec +import Text.Megaparsec (SourcePos(..)) + + +-- | Parse the outermost binding in a Src descriptor of a let-block and return +-- the rest. Ex. on input `let a = 0 let b = a in b` parses `let a = 0 ` and +-- returns the Src descriptor containing `let b = a in b`. +getLetInner :: Src -> Maybe Src +getLetInner (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetInnerOffset) text + where parseLetInnerOffset = do + setSourcePos left + _let + _ <- label + _ <- optional (do + _ <- _colon + expr) + _equal + _ <- expr + _ <- optional _in + begin <- getSourcePos + tokens <- Megaparsec.takeRest + end <- getSourcePos + return (Src begin end tokens) + +-- | Given an Src of a let expression return the Src containing the type +-- annotation. If the let expression does not have a type annotation return +-- a 0-length Src where we can insert one. +getLetAnnot :: Src -> Maybe Src +getLetAnnot (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetAnnot) text + where parseLetAnnot = do + setSourcePos left + _let + _ <- label + begin <- getSourcePos + (tokens, _) <- Megaparsec.match $ optional (do + _ <- _colon + expr) + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) + +-- | Given an Src of a let expression return the Src containing the bound +-- identifier, i.e. given `let x = ... in ...` return the Src descriptor +-- containing `x`. Returns the original Src if something goes wrong. +getLetIdentifier :: Src -> Src +getLetIdentifier src@(Src left _ text) = + case Megaparsec.parseMaybe (unParser parseLetIdentifier) text of + Just src' -> src' + Nothing -> src + where parseLetIdentifier = do + setSourcePos left + _let + begin <- getSourcePos + (tokens, _) <- Megaparsec.match label + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) + +-- | Cf. `getLetIdentifier`. +getLamIdentifier :: Src -> Src +getLamIdentifier src@(Src left _ text) = + case Megaparsec.parseMaybe (unParser parseLetIdentifier) text of + Just src' -> src' + Nothing -> src + where parseLetIdentifier = do + setSourcePos left + _lambda + _openParens + begin <- getSourcePos + (tokens, _) <- Megaparsec.match label + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) + +-- | Cf. `getLetIdentifier`. +getForallIdentifier :: Src -> Src +getForallIdentifier src@(Src left _ text) = + case Megaparsec.parseMaybe (unParser parseLetIdentifier) text of + Just src' -> src' + Nothing -> src + where parseLetIdentifier = do + setSourcePos left + _forall + _openParens + begin <- getSourcePos + (tokens, _) <- Megaparsec.match label + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) + +-- | Given an Src of a import expression return the Src containing the hash +-- annotation. If the import does not have a hash annotation return a 0-length +-- Src where we can insert one. +getImportHash :: Src -> Maybe Src +getImportHash (Src left _ text) = + Megaparsec.parseMaybe (unParser parseImportHashPosition) text + where parseImportHashPosition = do + setSourcePos left + _ <- importType_ + begin <- getSourcePos + (tokens, _) <- Megaparsec.match $ optional importHash_ + end <- getSourcePos + _ <- Megaparsec.takeRest + return (Src begin end tokens) + +setSourcePos :: SourcePos -> Parser () +setSourcePos src = Megaparsec.updateParserState + (\(Megaparsec.State s o (Megaparsec.PosState i o' _ t l)) -> + Megaparsec.State s o (Megaparsec.PosState i o' src t l)) diff --git a/src/Dhall/LSP/Backend/ToJSON.hs b/src/Dhall/LSP/Backend/ToJSON.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/ToJSON.hs @@ -0,0 +1,21 @@ +module Dhall.LSP.Backend.ToJSON (CompileError, toJSON) where + +import Dhall.JSON as Dhall +import qualified Data.Aeson.Encode.Pretty as Aeson + +import Dhall.LSP.Backend.Dhall + +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.ByteString.Lazy (toStrict) + +-- | Try to convert a given Dhall expression to JSON. +toJSON :: WellTyped -> Either CompileError Text +toJSON expr = fmap (decodeUtf8 . toStrict . Aeson.encodePretty' config) + (Dhall.dhallToJSON $ fromWellTyped expr) + where + config = Aeson.Config + { Aeson.confIndent = Aeson.Spaces 2 + , Aeson.confCompare = compare + , Aeson.confNumFormat = Aeson.Generic + , Aeson.confTrailingNewline = False } diff --git a/src/Dhall/LSP/Backend/Typing.hs b/src/Dhall/LSP/Backend/Typing.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Backend/Typing.hs @@ -0,0 +1,181 @@ +module Dhall.LSP.Backend.Typing (annotateLet, exprAt, srcAt, typeAt) where + +import Dhall.Context (Context, insert, empty) +import Dhall.Core (Expr(..), Binding(..), Const(..), subExpressions, normalize, shift, subst, Var(..)) +import Dhall.TypeCheck (typeWithA, X(..), TypeError(..)) +import Dhall.Parser (Src(..)) + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid ((<>)) +import Control.Lens (toListOf) +import Data.Text (Text) +import Control.Applicative ((<|>)) +import Data.Bifunctor (first) + +import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot, getLetIdentifier, + getLamIdentifier, getForallIdentifier) +import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall) +import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped) + +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import Dhall.Pretty (CharacterSet(..), prettyCharacterSet) + +-- | Find the type of the subexpression at the given position. Assumes that the +-- input expression is well-typed. Also returns the Src descriptor containing +-- that subexpression if possible. +typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src X) +typeAt pos expr = do + expr' <- case splitLets (fromWellTyped expr) of + Just e -> return e + Nothing -> Left "The impossible happened: failed to split let\ + \ blocks when preprocessing for typeAt'." + (mSrc, typ) <- first show $ typeAt' pos empty expr' + case mSrc of + Just src -> return (Just src, normalize typ) + Nothing -> return (srcAt pos expr', normalize typ) + +typeAt' :: Position -> Context (Expr Src X) -> Expr Src X -> Either (TypeError Src X) (Maybe Src, Expr Src X) +-- the user hovered over the bound name in a let expression +typeAt' pos ctx (Note src (Let (Binding _ _ a :| []) _)) | pos `inside` getLetIdentifier src = do + typ <- typeWithA absurd ctx a + return (Just $ getLetIdentifier src, typ) + +-- "..." in a lambda expression +typeAt' pos _ctx (Note src (Lam _ _A _)) | pos `inside` getLamIdentifier src = + return (Just $ getLamIdentifier src, _A) + +-- "..." in a forall expression +typeAt' pos _ctx (Note src (Pi _ _A _)) | pos `inside` getForallIdentifier src = + return (Just $ getForallIdentifier src, _A) + +-- the input only contains singleton lets +typeAt' pos ctx (Let (Binding x _ a :| []) e@(Note src _)) | pos `inside` src = do + _A <- typeWithA absurd ctx a + t <- fmap normalize (typeWithA absurd ctx _A) + case t of + Const Type -> do -- we don't have types depending on values + let ctx' = fmap (shift 1 (V x 0)) (insert x (normalize _A) ctx) + (mSrc, _B) <- typeAt' pos ctx' e + return (mSrc, shift (-1) (V x 0) _B) + _ -> do -- but we do have types depending on types + let a' = shift 1 (V x 0) (normalize a) + typeAt' pos ctx (shift (-1) (V x 0) (subst (V x 0) a' e)) + +typeAt' pos ctx (Lam x _A b@(Note src _)) | pos `inside` src = do + let _A' = Dhall.Core.normalize _A + ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx) + typeAt' pos ctx' b + +typeAt' pos ctx (Pi x _A _B@(Note src _)) | pos `inside` src = do + let _A' = Dhall.Core.normalize _A + ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx) + typeAt' pos ctx' _B + +-- peel off a single Note constructor +typeAt' pos ctx (Note _ expr) = typeAt' pos ctx expr + +-- catch-all +typeAt' pos ctx expr = do + let subExprs = toListOf subExpressions expr + case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of + [] -> do typ <- typeWithA absurd ctx expr -- return type of whole subexpression + return (Nothing, typ) + ((src, e):_) -> typeAt' pos ctx (Note src e) -- continue with leaf-expression + + +-- | Find the smallest Note-wrapped expression at the given position. +exprAt :: Position -> Expr Src a -> Maybe (Expr Src a) +exprAt pos e = do e' <- splitLets e + exprAt' pos e' + +exprAt' :: Position -> Expr Src a -> Maybe (Expr Src a) +exprAt' pos e@(Note _ expr) = exprAt pos expr <|> Just e +exprAt' pos expr = + let subExprs = toListOf subExpressions expr + in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of + [] -> Nothing + ((src,e) : _) -> exprAt' pos e <|> Just (Note src e) + + +-- | Find the smallest Src annotation containing the given position. +srcAt :: Position -> Expr Src a -> Maybe Src +srcAt pos expr = do Note src _ <- exprAt pos expr + return src + + +-- | Given a well-typed expression and a position find the let binder at that +-- position (if there is one) and return a textual update to the source code +-- that inserts the type annotation (or replaces the existing one). If +-- something goes wrong returns a textual error message. +annotateLet :: Position -> WellTyped -> Either String (Src, Text) +annotateLet pos expr = do + expr' <- case splitLets (fromWellTyped expr) of + Just e -> return e + Nothing -> Left "The impossible happened: failed to split let\ + \ blocks when preprocessing for annotateLet'." + annotateLet' pos empty expr' + +annotateLet' :: Position -> Context (Expr Src X) -> Expr Src X -> Either String (Src, Text) +-- the input only contains singleton lets +annotateLet' pos ctx (Note src e@(Let (Binding _ _ a :| []) _)) + | not $ any (pos `inside`) [ src' | Note src' _ <- toListOf subExpressions e ] + = do _A <- first show $ typeWithA absurd ctx a + srcAnnot <- case getLetAnnot src of + Just x -> return x + Nothing -> Left "The impossible happened: failed\ + \ to re-parse a Let expression." + return (srcAnnot, ": " <> printExpr (normalize _A) <> " ") + +-- binders, see typeAt' +annotateLet' pos ctx (Let (Binding x _ a :| []) e@(Note src _)) | pos `inside` src = do + _A <- first show $ typeWithA absurd ctx a + t <- first show $ fmap normalize (typeWithA absurd ctx _A) + case t of + Const Type -> do -- we don't have types depending on values + let ctx' = fmap (shift 1 (V x 0)) (insert x (normalize _A) ctx) + annotateLet' pos ctx' e + _ -> do -- but we do have types depending on types + let a' = shift 1 (V x 0) (normalize a) + annotateLet' pos ctx (shift (-1) (V x 0) (subst (V x 0) a' e)) + +annotateLet' pos ctx (Lam x _A b@(Note src _)) | pos `inside` src = do + let _A' = Dhall.Core.normalize _A + ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx) + annotateLet' pos ctx' b + +annotateLet' pos ctx (Pi x _A _B@(Note src _)) | pos `inside` src = do + let _A' = Dhall.Core.normalize _A + ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx) + annotateLet' pos ctx' _B + +-- we need to unfold Notes to make progress +annotateLet' pos ctx (Note _ expr) = do + annotateLet' pos ctx expr + +-- catch-all +annotateLet' pos ctx expr = do + let subExprs = toListOf subExpressions expr + case [ Note src e | (Note src e) <- subExprs, pos `inside` src ] of + (e:[]) -> annotateLet' pos ctx e + _ -> Left "You weren't pointing at a let binder!" + + +printExpr :: Pretty.Pretty b => Expr a b -> Text +printExpr expr = Pretty.renderStrict $ Pretty.layoutCompact (Pretty.unAnnotate (prettyCharacterSet Unicode expr)) + + +-- Split all multilets into single lets in an expression +splitLets :: Expr Src a -> Maybe (Expr Src a) +splitLets (Note src (Let (b :| (b' : bs)) e)) = do + src' <- getLetInner src + splitLets (Note src (Let (b :| []) (Note src' (Let (b' :| bs) e)))) +splitLets expr = subExpressions splitLets expr + + +-- Check if range lies completely inside a given subexpression. +-- This version takes trailing whitespace into account +-- (c.f. `sanitiseRange` from Backend.Diangostics). +inside :: Position -> Src -> Bool +inside pos src = left <= pos && pos < right + where Range left right = rangeFromDhall src diff --git a/src/Dhall/LSP/Handlers.hs b/src/Dhall/LSP/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Handlers.hs @@ -0,0 +1,450 @@ +module Dhall.LSP.Handlers where + +import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.Messages as LSP +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J +import qualified Language.Haskell.LSP.VFS as LSP +import qualified Data.Aeson as J +import qualified Yi.Rope as Rope + +import Dhall.Core (Expr(Note, Embed), 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, embedsWithRanges) +import Dhall.LSP.Backend.Formatting (formatExprWithHeader) +import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition, + stripHash, getAllImportsWithHashPositions) +import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint) +import Dhall.LSP.Backend.Typing (typeAt, annotateLet, exprAt) +import Dhall.LSP.State + +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar +import Control.Lens ((^.), use, uses, assign, modifying) +import Control.Monad (guard, forM) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Except (throwE, catchE, runExceptT) +import Control.Monad.Trans.State.Strict (execStateT) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map +import Data.Maybe (maybeToList) +import Data.Text (Text) +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 +-- expects a multi-threaded implementation. Reports errors to the user via the +-- LSP `ShowMessage` notification. +wrapHandler + :: MVar ServerState + -> (a -> HandlerM ()) + -> a + -> IO () +wrapHandler vstate handle message = + modifyMVar_ vstate $ + execStateT . runExceptT $ + catchE (handle message) lspUserMessage + +lspUserMessage :: (Severity, Text) -> HandlerM () +lspUserMessage (Log, text) = + lspSendNotification LSP.NotLogMessage J.WindowLogMessage + $ J.LogMessageParams J.MtLog text +lspUserMessage (severity, text) = + lspSendNotification LSP.NotShowMessage J.WindowShowMessage + $ J.ShowMessageParams severity' text + where severity' = case severity of + Error -> J.MtError + Warning -> J.MtWarning + Info -> J.MtInfo + Log -> J.MtLog + + +lspSend :: LSP.FromServerMessage -> HandlerM () +lspSend msg = do + send <- use (lspFuncs . sendFunc) + liftIO $ send msg + +lspRespond :: (J.ResponseMessage response -> LSP.FromServerMessage) + -> J.RequestMessage J.ClientMethod request response -> response -> HandlerM () +lspRespond constructor request response = + lspSend . constructor $ LSP.makeResponseMessage request response + +lspSendNotification + :: (J.NotificationMessage J.ServerMethod params -> LSP.FromServerMessage) + -> J.ServerMethod -> params -> HandlerM () +lspSendNotification constructor method params = + lspSend . constructor $ J.NotificationMessage "2.0" method params + +lspRequest + :: (J.RequestMessage J.ServerMethod params response -> LSP.FromServerMessage) + -> J.ServerMethod -> params -> HandlerM () +lspRequest constructor method params = do + getNextReqId <- uses lspFuncs LSP.getNextReqId + reqId <- liftIO getNextReqId + lspSend . constructor $ J.RequestMessage "2.0" reqId method params + +-- | A helper function to query haskell-lsp's VFS. +readUri :: J.Uri -> HandlerM Text +readUri uri = do + getVirtualFileFunc <- uses lspFuncs LSP.getVirtualFileFunc + mVirtualFile <- liftIO $ getVirtualFileFunc uri + case mVirtualFile of + Just (LSP.VirtualFile _ rope) -> return (Rope.toText rope) + Nothing -> fail $ "Could not find " <> show uri <> " in VFS." + +loadFile :: J.Uri -> HandlerM (Expr Src X) +loadFile uri = do + txt <- readUri uri + fileIdentifier <- fileIdentifierFromUri uri + cache <- use importCache + + expr <- case parse txt of + Right e -> return e + _ -> throwE (Error, "Failed to parse Dhall file.") + + loaded <- liftIO $ load fileIdentifier expr cache + (cache', expr') <- case loaded of + Right x -> return x + _ -> throwE (Error, "Failed to resolve imports.") + -- Update cache. Don't cache current expression because it might not have been + -- written to disk yet (readUri reads from the VFS). + assign importCache cache' + return expr' + +-- helper +fileIdentifierFromUri :: J.Uri -> HandlerM FileIdentifier +fileIdentifierFromUri uri = + let mFileIdentifier = fmap fileIdentifierFromFilePath (J.uriToFilePath uri) + <|> (do uri' <- (URI.parseURI . Text.unpack . J.getUri) uri + fileIdentifierFromURI uri') + in case mFileIdentifier of + Just fileIdentifier -> return fileIdentifier + Nothing -> throwE (Error, J.getUri uri <> " is not a valid name for a dhall file.") + +-- helper +rangeToJSON :: Range -> J.Range +rangeToJSON (Range (x1,y1) (x2,y2)) = J.Range (J.Position x1 y1) (J.Position x2 y2) + +hoverExplain :: J.HoverRequest -> HandlerM () +hoverExplain request = do + let uri = request ^. J.params . J.textDocument . J.uri + J.Position line col = request ^. J.params . J.position + mError <- uses errors $ Map.lookup uri + let isHovered (Diagnosis _ (Just (Range left right)) _) = + left <= (line,col) && (line,col) <= right + isHovered _ = False + + hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = + let _range = Just $ J.Range (uncurry J.Position left) + (uncurry J.Position right) + encodedDiag = URI.encode (Text.unpack diagnosis) + command = "[Explain error](dhall-explain:?" + <> Text.pack encodedDiag <> " )" + _contents = J.List [J.PlainString command] + in Just J.Hover { .. } + hoverFromDiagnosis _ = Nothing + + mHover = do err <- mError + explanation <- explain err + guard (isHovered explanation) + hoverFromDiagnosis explanation + lspRespond LSP.RspHover request mHover + +hoverType :: J.HoverRequest -> HandlerM () +hoverType request = do + let uri = request ^. J.params . J.textDocument . J.uri + J.Position line col = request ^. J.params . J.position + expr <- loadFile uri + (welltyped, _) <- case typecheck expr of + Left _ -> throwE (Info, "Can't infer type; code does not type-check.") + Right wt -> return wt + case typeAt (line,col) welltyped of + Left err -> throwE (Error, Text.pack err) + Right (mSrc, typ) -> + let _range = fmap (rangeToJSON . rangeFromDhall) mSrc + _contents = J.List [J.PlainString (pretty typ)] + hover = J.Hover{..} + in lspRespond LSP.RspHover request (Just hover) + +hoverHandler :: J.HoverRequest -> HandlerM () +hoverHandler request = do + let uri = request ^. J.params . J.textDocument . J.uri + errorMap <- use errors + case Map.lookup uri errorMap of + Nothing -> hoverType request + _ -> 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 + fileIdentifier <- fileIdentifierFromUri uri + -- make sure we don't keep a stale version around + modifying importCache (invalidate fileIdentifier) + cache <- use importCache + + errs <- flip catchE (return . Just) $ do + expr <- case parse txt of + Right e -> return e + Left err -> throwE err + loaded <- liftIO $ load fileIdentifier expr cache + (cache', expr') <- case loaded of + Right x -> return x + Left err -> throwE err + _ <- case typecheck expr' of + Right (wt, _typ) -> return wt + Left err -> throwE err + assign importCache cache' + return Nothing + + let suggestions = + case parse txt of + Right expr -> suggest expr + _ -> [] + + suggestionToDiagnostic Suggestion {..} = + let _range = rangeToJSON range + _severity = Just J.DsHint + _source = Just "Dhall.Lint" + _code = Nothing + _message = suggestion + _relatedInformation = Nothing + in J.Diagnostic {..} + + diagnosisToDiagnostic Diagnosis {..} = + let _range = case range of + Just range' -> + rangeToJSON range' + Nothing -> J.Range (J.Position 0 0) (J.Position 0 0) + _severity = Just J.DsError + _source = Just doctor + _code = Nothing + _message = diagnosis + _relatedInformation = Nothing + in J.Diagnostic {..} + + diagnostics = concatMap (map diagnosisToDiagnostic . diagnose) (maybeToList errs) + ++ map suggestionToDiagnostic suggestions + + modifying errors (Map.alter (const errs) uri) -- cache errors + lspSendNotification LSP.NotPublishDiagnostics J.TextDocumentPublishDiagnostics + (J.PublishDiagnosticsParams uri (J.List diagnostics)) + + +documentFormattingHandler :: J.DocumentFormattingRequest -> HandlerM () +documentFormattingHandler request = do + let uri = request ^. J.params . J.textDocument . J.uri + txt <- readUri uri + + (header, expr) <- case parseWithHeader txt of + Right res -> return res + _ -> throwE (Warning, "Failed to format dhall code; parse error.") + + let formatted = formatExprWithHeader expr header + numLines = Text.length txt + range = J.Range (J.Position 0 0) (J.Position numLines 0) + edits = J.List [J.TextEdit range formatted] + + lspRespond LSP.RspDocumentFormatting request edits + + +executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM () +executeCommandHandler request + | command == "dhall.server.lint" = executeLintAndFormat request + | command == "dhall.server.annotateLet" = executeAnnotateLet request + | command == "dhall.server.freezeImport" = executeFreezeImport request + | command == "dhall.server.freezeAllImports" = executeFreezeAllImports request + | otherwise = throwE (Warning, "Command '" <> command + <> "' not known; ignored.") + where command = request ^. J.params . J.command + +getCommandArguments :: J.FromJSON a => J.ExecuteCommandRequest -> HandlerM a +getCommandArguments request = do + json <- case request ^. J.params . J.arguments of + Just (J.List (x : _)) -> return x + _ -> throwE (Error, "Failed to execute command; arguments missing.") + case J.fromJSON json of + J.Success args -> return args + _ -> throwE (Error, "Failed to execute command; failed to parse arguments.") + + +-- implements dhall.server.lint +executeLintAndFormat :: J.ExecuteCommandRequest -> HandlerM () +executeLintAndFormat request = do + uri <- getCommandArguments request + txt <- readUri uri + + (header, expr) <- case parseWithHeader txt of + Right res -> return res + _ -> throwE (Warning, "Failed to lint dhall code; parse error.") + + let linted = formatExprWithHeader (lint expr) header + numLines = Text.length txt + range = J.Range (J.Position 0 0) (J.Position numLines 0) + edit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List [J.TextEdit range linted]))) Nothing + + lspRespond LSP.RspExecuteCommand request J.Null + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams edit) + + +executeAnnotateLet :: J.ExecuteCommandRequest -> HandlerM () +executeAnnotateLet request = do + args :: J.TextDocumentPositionParams <- getCommandArguments request + let uri = args ^. J.textDocument . J.uri + line = args ^. J.position . J.line + col = args ^. J.position . J.character + + expr <- loadFile uri + (welltyped, _) <- case typecheck expr of + Left _ -> throwE (Warning, "Failed to annotate let binding; not well-typed.") + Right e -> return e + + (Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _, txt) + <- case annotateLet (line, col) welltyped of + Right x -> return x + Left msg -> throwE (Warning, Text.pack msg) + + let range = J.Range (J.Position (unPos x1 - 1) (unPos y1 - 1)) + (J.Position (unPos x2 - 1) (unPos y2 - 1)) + edit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List [J.TextEdit range txt]))) Nothing + + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams edit) + + +executeFreezeAllImports :: J.ExecuteCommandRequest -> HandlerM () +executeFreezeAllImports request = do + uri <- getCommandArguments request + + fileIdentifier <- fileIdentifierFromUri uri + txt <- readUri uri + expr <- case parse txt of + Right e -> return e + Left _ -> throwE (Warning, "Could not freeze imports; did not parse.") + + let importRanges = getAllImportsWithHashPositions expr + edits <- forM importRanges $ \(import_, Range (x1, y1) (x2, y2)) -> do + cache <- use importCache + let importExpr = Embed (stripHash import_) + + hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + (cache', hash) <- case hashResult of + Right (c, t) -> return (c, t) + Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") + assign importCache cache' + + let range = J.Range (J.Position x1 y1) (J.Position x2 y2) + return (J.TextEdit range (" " <> hash)) + + let workspaceEdit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List edits))) Nothing + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams workspaceEdit) + + +executeFreezeImport :: J.ExecuteCommandRequest -> HandlerM () +executeFreezeImport request = do + args :: J.TextDocumentPositionParams <- getCommandArguments request + let uri = args ^. J.textDocument . J.uri + line = args ^. J.position . J.line + col = args ^. J.position . J.character + + txt <- readUri uri + expr <- case parse txt of + Right e -> return e + Left _ -> throwE (Warning, "Could not freeze import; did not parse.") + + (src, import_) + <- case exprAt (line, col) expr of + Just (Note src (Embed i)) -> return (src, i) + _ -> throwE (Warning, "You weren't pointing at an import!") + + Range (x1, y1) (x2, y2) <- case getImportHashPosition src of + Just range -> return range + Nothing -> throwE (Error, "Failed to re-parse import!") + + fileIdentifier <- fileIdentifierFromUri uri + cache <- use importCache + let importExpr = Embed (stripHash import_) + + hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + (cache', hash) <- case hashResult of + Right (c, t) -> return (c, t) + Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") + assign importCache cache' + + let range = J.Range (J.Position x1 y1) (J.Position x2 y2) + edit = J.WorkspaceEdit + (Just (HashMap.singleton uri (J.List [J.TextEdit range (" " <> hash)]))) Nothing + + lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit + (J.ApplyWorkspaceEditParams edit) + + +-- handler that doesn't do anything. Useful for example to make haskell-lsp shut +-- up about unhandled DidChangeTextDocument notifications (which are already +-- handled haskell-lsp itself). +nullHandler :: a -> HandlerM () +nullHandler _ = return () + +didOpenTextDocumentNotificationHandler + :: J.DidOpenTextDocumentNotification -> HandlerM () +didOpenTextDocumentNotificationHandler notification = do + let uri = notification ^. J.params . J.textDocument . J.uri + diagnosticsHandler uri + +didSaveTextDocumentNotificationHandler + :: J.DidSaveTextDocumentNotification -> HandlerM () +didSaveTextDocumentNotificationHandler notification = do + let uri = notification ^. J.params . J.textDocument . J.uri + diagnosticsHandler uri diff --git a/src/Dhall/LSP/Server.hs b/src/Dhall/LSP/Server.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Server.hs @@ -0,0 +1,95 @@ +{-| This is the entry point for the LSP server. -} +module Dhall.LSP.Server(run) where + +import Control.Concurrent.MVar +import Data.Default +import qualified Language.Haskell.LSP.Control as LSP.Control +import qualified Language.Haskell.LSP.Core as LSP.Core + +import qualified Language.Haskell.LSP.Types as J + +import Data.Text (Text) +import qualified System.Log.Logger + +import Dhall.LSP.State +import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler, + didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler, + executeCommandHandler, documentFormattingHandler, documentLinkHandler) + +-- | The main entry point for the LSP server. +run :: Maybe FilePath -> IO () +run mlog = do + setupLogger mlog + state <- newEmptyMVar + _ <- LSP.Control.run (makeConfig, initCallback state) (lspHandlers state) + lspOptions Nothing + return () + where + -- Callback that is called when the LSP server is started; makes the lsp + -- state (LspFuncs) available to the message handlers through the vlsp MVar. + initCallback + :: MVar ServerState + -> LSP.Core.LspFuncs () + -> IO (Maybe J.ResponseError) + initCallback state lsp = do + putMVar state (initialState lsp) + return Nothing + + -- Interpret DidChangeConfigurationNotification; pointless at the moment + -- since we don't use a configuration. + makeConfig :: J.DidChangeConfigurationNotification -> Either Text () + makeConfig _ = Right () + +-- | sets the output logger. +-- | if no filename is provided then logger is disabled, if input is string `[OUTPUT]` then log goes to stderr, +-- | which then redirects inside VSCode to the output pane of the plugin. +setupLogger :: Maybe FilePath -> IO () -- TODO: ADD verbosity +setupLogger Nothing = pure () +setupLogger (Just "[OUTPUT]") = LSP.Core.setupLogger Nothing [] System.Log.Logger.DEBUG +setupLogger file = LSP.Core.setupLogger file [] System.Log.Logger.DEBUG + + +-- Tells the LSP client to notify us about file changes. Handled behind the +-- scenes by haskell-lsp (in Language.Haskell.LSP.VFS); we don't handle the +-- corresponding notifications ourselves. +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 + } + +-- Server capabilities. Tells the LSP client that we can execute commands etc. +lspOptions :: LSP.Core.Options +lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions + , LSP.Core.executeCommandProvider = + -- Note that this registers the dhall.server.lint command + -- with VSCode, which means that our plugin can't expose a + -- command of the same name. In the case of dhall.lint we + -- name the server-side command dhall.server.lint to work + -- around this peculiarity. + Just (J.ExecuteCommandOptions + (J.List ["dhall.server.lint", + "dhall.server.annotateLet", + "dhall.server.freezeImport", + "dhall.server.freezeAllImports"])) + , LSP.Core.documentLinkProvider = + Just (J.DocumentLinkOptions { _resolveProvider = Just False }) + } + +lspHandlers :: MVar ServerState -> LSP.Core.Handlers +lspHandlers state + = def { LSP.Core.initializedHandler = Just $ wrapHandler state nullHandler + , LSP.Core.hoverHandler = Just $ wrapHandler state hoverHandler + , LSP.Core.didOpenTextDocumentNotificationHandler = Just $ wrapHandler state didOpenTextDocumentNotificationHandler + , LSP.Core.didChangeTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler + , LSP.Core.didSaveTextDocumentNotificationHandler = Just $ wrapHandler state didSaveTextDocumentNotificationHandler + , LSP.Core.didCloseTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler + , LSP.Core.cancelNotificationHandler = Just $ wrapHandler state nullHandler + , 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/src/Dhall/LSP/State.hs b/src/Dhall/LSP/State.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/State.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +module Dhall.LSP.State where + +import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.Messages as LSP +import qualified Language.Haskell.LSP.Types as J + +import Control.Lens.TH (makeLenses) +import Lens.Family (LensLike') +import Data.Map.Strict (Map, empty) +import Data.Dynamic (Dynamic) +import Dhall.LSP.Backend.Dhall (DhallError, Cache, emptyCache) +import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.State.Strict (StateT) + +-- Inside a handler we have access to the ServerState. The exception layer +-- allows us to fail gracefully, displaying a message to the user via the +-- "ShowMessage" mechanism of the lsp standard. +type HandlerM = ExceptT (Severity, Text) (StateT ServerState IO) + +data Severity = Error + -- ^ Error displayed to the user. + | Warning + -- ^ Warning displayed to the user. + | Info + -- ^ Information displayed to the user. + | Log + -- ^ Log message, not displayed by default. + +data ServerState = ServerState + { _importCache :: Cache -- ^ The dhall import cache + , _errors :: Map J.Uri DhallError -- ^ Map from dhall files to their errors + , _httpManager :: Maybe Dynamic + -- ^ The http manager used by dhall's import infrastructure + , _lspFuncs :: LSP.LspFuncs () + -- ^ Access to the lsp functions supplied by haskell-lsp + } + +makeLenses ''ServerState + +sendFunc :: Functor f => + LensLike' f (LSP.LspFuncs ()) (LSP.FromServerMessage -> IO ()) +sendFunc k s = fmap (\x -> s {LSP.sendFunc = x}) (k (LSP.sendFunc s)) + +initialState :: LSP.LspFuncs () -> ServerState +initialState lsp = ServerState {..} + where + _importCache = emptyCache + _errors = empty + _httpManager = Nothing + _lspFuncs = lsp diff --git a/src/Dhall/LSP/Util.hs b/src/Dhall/LSP/Util.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/LSP/Util.hs @@ -0,0 +1,33 @@ +-- | Miscellaneous utility functions + +module Dhall.LSP.Util ( + tshow, + lines', + rightToMaybe, + unlines' +) where + +import Data.Text +import Data.List.NonEmpty + +-- | Shorthand for @pack . show@. Useful since we are mostly working with Text +-- rather than String. +tshow :: Show a => a -> Text +tshow = pack . show + +-- | A variant of @Data.Text.lines@ that does not swallow the last empty. Always +-- returns at least the empty line! +lines' :: Text -> NonEmpty Text +lines' text = + case split (== '\n') text of + [] -> "" :| [] -- this case never occurs! + l : ls -> l :| ls + +-- | A variant of @Data.Text.unlines@ that is the exact inverse to @lines'@ (and +-- vice-versa). +unlines' :: [Text] -> Text +unlines' = intercalate "\n" + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Right b) = Just b +rightToMaybe (Left _) = Nothing