dhall-lsp-server (empty) → 1.0.0
raw patch · 19 files changed
+1674/−0 lines, 19 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, cryptonite, data-default, dhall, dhall-json, dhall-lsp-server, directory, doctest, dotgen, filepath, haskell-lsp, hslogger, lens, lens-family-core, megaparsec, mtl, network-uri, optparse-applicative, prettyprinter, sorted-list, stm, text, transformers, unordered-containers, uri-encode, yi-rope
Files
- ChangeLog.md +7/−0
- LICENSE +21/−0
- README.md +9/−0
- Setup.hs +2/−0
- app/Main.hs +65/−0
- dhall-lsp-server.cabal +125/−0
- doctest/Main.hs +24/−0
- src/Dhall/LSP/Backend/Dhall.hs +170/−0
- src/Dhall/LSP/Backend/Diagnostics.hs +161/−0
- src/Dhall/LSP/Backend/Formatting.hs +25/−0
- src/Dhall/LSP/Backend/Freezing.hs +57/−0
- src/Dhall/LSP/Backend/Linting.hs +52/−0
- src/Dhall/LSP/Backend/Parsing.hs +124/−0
- src/Dhall/LSP/Backend/ToJSON.hs +21/−0
- src/Dhall/LSP/Backend/Typing.hs +181/−0
- src/Dhall/LSP/Handlers.hs +450/−0
- src/Dhall/LSP/Server.hs +95/−0
- src/Dhall/LSP/State.hs +52/−0
- src/Dhall/LSP/Util.hs +33/−0
+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ dhall-lsp-server.cabal view
@@ -0,0 +1,125 @@+cabal-version: 1.12+name: dhall-lsp-server+version: 1.0.0+description: Please see the README on GitHub at <https://github.com/githubuser/dhall-lsp-server#readme>+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
+ doctest/Main.hs view
@@ -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"+ ]
+ src/Dhall/LSP/Backend/Dhall.hs view
@@ -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
+ src/Dhall/LSP/Backend/Diagnostics.hs view
@@ -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)
+ src/Dhall/LSP/Backend/Formatting.hs view
@@ -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"+
+ src/Dhall/LSP/Backend/Freezing.hs view
@@ -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] ]
+ src/Dhall/LSP/Backend/Linting.hs view
@@ -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 ]
+ src/Dhall/LSP/Backend/Parsing.hs view
@@ -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))
+ src/Dhall/LSP/Backend/ToJSON.hs view
@@ -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 }
+ src/Dhall/LSP/Backend/Typing.hs view
@@ -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
+ src/Dhall/LSP/Handlers.hs view
@@ -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
+ src/Dhall/LSP/Server.hs view
@@ -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+ }
+ src/Dhall/LSP/State.hs view
@@ -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
+ src/Dhall/LSP/Util.hs view
@@ -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