diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -15,11 +15,13 @@ import qualified Data.Version import qualified Dhall.LSP.Server import qualified Paths_dhall_lsp_server +import qualified GHC.IO.Encoding -- | Top-level program options data Options = Options { command :: Mode , logFile :: Maybe FilePath + , version :: Bool } -- | The mode in which to run @dhall-lsp-server@ @@ -27,14 +29,19 @@ parseOptions :: Parser Options parseOptions = - Options <$> parseMode <*> Options.Applicative.optional parseLogFile + Options <$> parseMode <*> Options.Applicative.optional parseLogFile <*> parseVersion where parseLogFile = Options.Applicative.strOption (Options.Applicative.long "log" <> Options.Applicative.help "If present writes debug output to the specified file" ) + parseVersion = Options.Applicative.switch + ( Options.Applicative.long "version" + <> Options.Applicative.help "Display version" + ) + subcommand :: String -> String -> Parser a -> Parser a subcommand name description parser = Options.Applicative.hsubparser (Options.Applicative.command name parserInfo @@ -57,11 +64,20 @@ ) runCommand :: Options -> IO () -runCommand Options {..} = case command of - Version -> putStrLn (Data.Version.showVersion Paths_dhall_lsp_server.version) - LSPServer -> Dhall.LSP.Server.run logFile +runCommand Options {..} = do + if version + then printVersion + else case command of + Version -> printVersion + LSPServer -> Dhall.LSP.Server.run logFile + where + printVersion = putStrLn (Data.Version.showVersion Paths_dhall_lsp_server.version) -- | Entry point for the @dhall-lsp-server@ executable main :: IO () -main = do options <- Options.Applicative.execParser parserInfoOptions - runCommand options +main = do + GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 + + options <- Options.Applicative.execParser parserInfoOptions + + runCommand options diff --git a/dhall-lsp-server.cabal b/dhall-lsp-server.cabal --- a/dhall-lsp-server.cabal +++ b/dhall-lsp-server.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: dhall-lsp-server -Version: 1.0.1 +Version: 1.0.2 synopsis: Language Server Protocol (LSP) server for Dhall homepage: https://github.com/dhall-lang/dhall-haskell/dhall-lsp-server#readme bug-reports: https://github.com/dhall-lang/dhall-haskell/issues @@ -13,6 +13,10 @@ extra-source-files: README.md ChangeLog.md + tests/fixtures/completion/*.dhall + tests/fixtures/diagnostics/*.dhall + tests/fixtures/linting/*.dhall + tests/fixtures/hovering/*.dhall source-repository head type: git @@ -46,10 +50,10 @@ , containers >= 0.5.11.0 && < 0.7 , data-default >= 0.7.1.1 && < 0.8 , directory >= 1.2.2.0 && < 1.4 - , dhall >= 1.26.0 && < 1.27 - , dhall-json >= 1.4 && < 1.5 + , dhall >= 1.26.0 && < 1.28 + , dhall-json >= 1.4 && < 1.6 , filepath >= 1.4.2 && < 1.5 - , haskell-lsp >= 0.15.0.0 && < 0.16 + , haskell-lsp >= 0.15.0.0 && < 0.17 , rope-utf16-splay >= 0.3.1.0 && < 0.4 , hslogger >= 1.2.10 && < 1.4 , lens >= 4.16.1 && < 4.19 @@ -102,3 +106,17 @@ -- See: https://ghc.haskell.org/trac/ghc/ticket/10970 if impl(ghc < 8.0) Buildable: False + +Test-Suite tests + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: Main.hs + GHC-Options: -Wall + Build-Depends: + base , + haskell-lsp-types >= 0.15.0 && < 0.16 , + lsp-test >= 0.6 && < 0.7 , + tasty >= 0.11.2 && < 1.3 , + tasty-hspec >= 1.1 && < 1.2 , + text >= 0.11 && < 1.3 + Default-Language: Haskell2010 diff --git a/src/Dhall/LSP/Backend/Dhall.hs b/src/Dhall/LSP/Backend/Dhall.hs --- a/src/Dhall/LSP/Backend/Dhall.hs +++ b/src/Dhall/LSP/Backend/Dhall.hs @@ -19,7 +19,6 @@ ) where import Dhall.Parser (Src) -import Dhall.TypeCheck (X) import Dhall.Core (Expr) import qualified Dhall.Core as Dhall @@ -36,6 +35,7 @@ import Data.List.NonEmpty (NonEmpty((:|))) import Data.Text (Text) +import Data.Void (Void) import System.FilePath (splitDirectories, takeFileName, takeDirectory) import Lens.Family (view, set) import Control.Exception (SomeException, catch) @@ -65,10 +65,10 @@ fileIdentifierFromURI _ = Nothing -- | A well-typed expression. -newtype WellTyped = WellTyped {fromWellTyped :: Expr Src X} +newtype WellTyped = WellTyped {fromWellTyped :: Expr Src Void} -- | A fully normalised expression. -newtype Normal = Normal {fromNormal :: Expr Src X} +newtype Normal = Normal {fromNormal :: Expr Src Void} -- An import graph, represented by list of import dependencies. type ImportGraph = [Dhall.Depends] @@ -119,7 +119,7 @@ -- normalisation. data DhallError = ErrorInternal SomeException | ErrorImportSourced (Dhall.SourcedException Dhall.MissingImports) - | ErrorTypecheck (Dhall.TypeError Src X) + | ErrorTypecheck (Dhall.TypeError Src Void) | ErrorParse Dhall.ParseError -- | Parse a Dhall expression. @@ -133,7 +133,7 @@ -- | Resolve all imports in an expression. load :: FileIdentifier -> Expr Src Dhall.Import -> Cache -> - IO (Either DhallError (Cache, Expr Src X)) + IO (Either DhallError (Cache, Expr Src Void)) load (FileIdentifier chained) expr (Cache graph cache) = do let emptyStatus = Dhall.emptyStatus "" status = -- reuse cache and import graph @@ -151,7 +151,7 @@ -- | 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 Src Void -> Either DhallError (WellTyped, WellTyped) typecheck expr = case Dhall.typeOf expr of Left err -> Left $ ErrorTypecheck err Right typ -> Right (WellTyped expr, WellTyped typ) diff --git a/src/Dhall/LSP/Backend/Parsing.hs b/src/Dhall/LSP/Backend/Parsing.hs --- a/src/Dhall/LSP/Backend/Parsing.hs +++ b/src/Dhall/LSP/Backend/Parsing.hs @@ -137,7 +137,7 @@ setSourcePos left begin <- getSourcePos (tokens, _) <- - Megaparsec.match $ (localRaw *> return ()) <|> (httpRaw *> return ()) + Megaparsec.match $ (localOnly *> return ()) <|> (httpRaw *> return ()) end <- getSourcePos _ <- Megaparsec.takeRest return (Src begin end tokens) diff --git a/src/Dhall/LSP/Backend/Typing.hs b/src/Dhall/LSP/Backend/Typing.hs --- a/src/Dhall/LSP/Backend/Typing.hs +++ b/src/Dhall/LSP/Backend/Typing.hs @@ -2,7 +2,7 @@ import Dhall.Context (Context, insert, empty) import Dhall.Core (Binding(..), Expr(..), subExpressions, normalize, shift, subst, Var(..), pretty) -import Dhall.TypeCheck (typeWithA, X, TypeError(..)) +import Dhall.TypeCheck (typeWithA, TypeError(..)) import Dhall.Parser (Src(..)) import Data.Monoid ((<>)) @@ -10,7 +10,7 @@ import Data.Text (Text) import Control.Applicative ((<|>)) import Data.Bifunctor (first) -import Data.Void (absurd) +import Data.Void (absurd, Void) import Dhall.LSP.Backend.Parsing (getLetAnnot, getLetIdentifier, getLamIdentifier, getForallIdentifier) @@ -20,7 +20,7 @@ -- | 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 :: Position -> WellTyped -> Either String (Maybe Src, Expr Src Void) typeAt pos expr = do let expr' = fromWellTyped expr (mSrc, typ) <- first show $ typeAt' pos empty expr' @@ -28,7 +28,7 @@ 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) +typeAt' :: Position -> Context (Expr Src Void) -> Expr Src Void -> Either (TypeError Src Void) (Maybe Src, Expr Src Void) -- the user hovered over the bound name in a let expression typeAt' pos ctx (Note src (Let (Binding { value = a }) _)) | pos `inside` getLetIdentifier src = do typ <- typeWithA absurd ctx a @@ -96,7 +96,7 @@ annotateLet pos expr = do annotateLet' pos empty (fromWellTyped expr) -annotateLet' :: Position -> Context (Expr Src X) -> Expr Src X -> Either String (Src, Text) +annotateLet' :: Position -> Context (Expr Src Void) -> Expr Src Void -> Either String (Src, Text) -- the input only contains singleton lets annotateLet' pos ctx (Note src e@(Let (Binding { value = a }) _)) | not $ any (pos `inside`) [ src' | Note src' _ <- toListOf subExpressions e ] diff --git a/src/Dhall/LSP/Handlers.hs b/src/Dhall/LSP/Handlers.hs --- a/src/Dhall/LSP/Handlers.hs +++ b/src/Dhall/LSP/Handlers.hs @@ -8,10 +8,10 @@ import qualified Data.Aeson as J import qualified Data.Rope.UTF16 as Rope +import Data.Void (Void) 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.Completion (Completion(..), completionQueryAt, completeEnvironmentImport, completeLocalImport, buildCompletionContext, completeProjections, completeFromContext) @@ -104,7 +104,7 @@ 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 :: J.Uri -> HandlerM (Expr Src Void) loadFile uri = do txt <- readUri uri fileIdentifier <- fileIdentifierFromUri uri diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified GHC.IO.Encoding +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types + ( CompletionItem (..), + Diagnostic (..), + DiagnosticSeverity (..), + Hover (..), + HoverContents (..), + MarkupContent (..), + Position (..), + ) +import Test.Tasty +import Test.Tasty.Hspec + +baseDir :: FilePath -> FilePath +baseDir d = "tests/fixtures/" <> d + +hoveringSpec :: FilePath -> Spec +hoveringSpec dir = + describe "Dhall.Hover" + $ it "reports types on hover" + $ runSession "dhall-lsp-server" fullCaps dir + $ do + docId <- openDoc "Types.dhall" "dhall" + let typePos = Position 0 5 + functionPos = Position 2 7 + extractContents = _contents . fromJust + getValue = T.unpack . _value + typeHover <- getHover docId typePos + funcHover <- getHover docId functionPos + liftIO $ do + case (extractContents typeHover, extractContents funcHover) of + (HoverContents typeContent, HoverContents functionContent) -> do + getValue typeContent `shouldBe` "Type" + getValue functionContent `shouldBe` "{ home : Text, name : Text }" + _ -> error "test failed" + pure () + +lintingSpec :: FilePath -> Spec +lintingSpec fixtureDir = + describe "Dhall.Lint" $ do + it "reports unused bindings" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "UnusedBindings.dhall" "dhall" + diags <- waitForDiagnosticsSource "Dhall.Lint" + _ <- + liftIO $ + mapM + ( \diag -> do + _severity diag `shouldBe` Just DsHint + T.unpack (_message diag) `shouldContain` "Unused let binding" + ) + diags + pure () + it "reports multiple hints" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "SuperfluousIn.dhall" "dhall" + diags <- waitForDiagnosticsSource "Dhall.Lint" + liftIO $ length diags `shouldBe` 2 + let diag1 = head diags + diag2 = diags !! 1 + liftIO $ do + _severity diag1 `shouldBe` Just DsHint + T.unpack (_message diag1) `shouldContain` "Superfluous 'in'" + _severity diag2 `shouldBe` Just DsHint + T.unpack (_message diag2) `shouldContain` "Unused let binding" + +codeCompletionSpec :: FilePath -> Spec +codeCompletionSpec fixtureDir = + describe "Dhall.Completion" $ do + it "suggests user defined types" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + docId <- openDoc "CustomTypes.dhall" "dhall" + cs <- getCompletions docId (Position {_line = 2, _character = 35}) + liftIO $ do + let firstItem = head cs + _label firstItem `shouldBe` "Config" + _detail firstItem `shouldBe` Just "Type" + it "suggests user defined functions" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + docId <- openDoc "CustomFunctions.dhall" "dhall" + cs <- getCompletions docId (Position {_line = 6, _character = 7}) + liftIO $ do + let firstItem = head cs + _label firstItem `shouldBe` "makeUser" + _detail firstItem `shouldBe` Just "\8704(user : Text) \8594 { home : Text }" + it "suggests user defined bindings" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + docId <- openDoc "Bindings.dhall" "dhall" + cs <- getCompletions docId (Position {_line = 0, _character = 59}) + liftIO $ do + let firstItem = head cs + _label firstItem `shouldBe` "bob" + _detail firstItem `shouldBe` Just "Text" + it "suggests functions from imports" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + docId <- openDoc "ImportedFunctions.dhall" "dhall" + cs <- getCompletions docId (Position {_line = 0, _character = 33}) + liftIO $ do + let firstItem = head cs + _label firstItem `shouldBe` "makeUser" + _detail firstItem `shouldBe` Just "\8704(user : Text) \8594 { home : Text }" + +diagnosticsSpec :: FilePath -> Spec +diagnosticsSpec fixtureDir = do + describe "Dhall.TypeCheck" $ do + it "reports unbound variables" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "UnboundVar.dhall" "dhall" + [diag] <- waitForDiagnosticsSource "Dhall.TypeCheck" + liftIO $ do + _severity diag `shouldBe` Just DsError + T.unpack (_message diag) `shouldContain` "Unbound variable" + it "reports wrong type" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "WrongType.dhall" "dhall" + [diag] <- waitForDiagnosticsSource "Dhall.TypeCheck" + liftIO $ do + _severity diag `shouldBe` Just DsError + T.unpack (_message diag) `shouldContain` "Expression doesn't match annotation" + describe "Dhall.Import" $ do + it "reports invalid imports" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "InvalidImport.dhall" "dhall" + [diag] <- waitForDiagnosticsSource "Dhall.Import" + liftIO $ do + _severity diag `shouldBe` Just DsError + T.unpack (_message diag) `shouldContain` "Invalid input" + it "reports missing imports" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "MissingImport.dhall" "dhall" + [diag] <- waitForDiagnosticsSource "Dhall.Import" + liftIO $ do + _severity diag `shouldBe` Just DsError + T.unpack (_message diag) `shouldContain` "Missing file" + describe "Dhall.Parser" + $ it "reports invalid syntax" + $ runSession "dhall-lsp-server" fullCaps fixtureDir + $ do + _ <- openDoc "InvalidSyntax.dhall" "dhall" + [diag] <- waitForDiagnosticsSource "Dhall.Parser" + liftIO $ _severity diag `shouldBe` Just DsError + +main :: IO () +main = do + GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 + diagnostics <- testSpec "Diagnostics" (diagnosticsSpec (baseDir "diagnostics")) + linting <- testSpec "Linting" (lintingSpec (baseDir "linting")) + completion <- testSpec "Completion" (codeCompletionSpec (baseDir "completion")) + hovering <- testSpec "Hovering" (hoveringSpec (baseDir "hovering")) + defaultMain + ( testGroup "Tests" + [ diagnostics, + linting, + completion, + hovering + ] + ) diff --git a/tests/fixtures/completion/Bindings.dhall b/tests/fixtures/completion/Bindings.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/completion/Bindings.dhall @@ -0,0 +1,1 @@ +let alice = "Alice" let bob = "Bob" in { result = bob ++ al } diff --git a/tests/fixtures/completion/CustomFunctions.dhall b/tests/fixtures/completion/CustomFunctions.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/completion/CustomFunctions.dhall @@ -0,0 +1,7 @@ +let makeUser = + λ(user : Text) + → let home = "/home/${user}" + + in { home = home } + +in [ m diff --git a/tests/fixtures/completion/CustomTypes.dhall b/tests/fixtures/completion/CustomTypes.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/completion/CustomTypes.dhall @@ -0,0 +1,3 @@ +let Config = { name : Text, age : Natural } + +in { name = "alice", age = 20 } : C diff --git a/tests/fixtures/completion/ImportedFunctions.dhall b/tests/fixtures/completion/ImportedFunctions.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/completion/ImportedFunctions.dhall @@ -0,0 +1,1 @@ +let Lib = ./Library.dhall in Lib. diff --git a/tests/fixtures/completion/Library.dhall b/tests/fixtures/completion/Library.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/completion/Library.dhall @@ -0,0 +1,3 @@ +let makeUser = λ(user : Text) → let home = "/home/${user}" in { home = home } + +in { makeUser = makeUser } diff --git a/tests/fixtures/diagnostics/InvalidImport.dhall b/tests/fixtures/diagnostics/InvalidImport.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/diagnostics/InvalidImport.dhall @@ -0,0 +1,1 @@ +./InvalidSyntax.dhall diff --git a/tests/fixtures/diagnostics/InvalidSyntax.dhall b/tests/fixtures/diagnostics/InvalidSyntax.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/diagnostics/InvalidSyntax.dhall @@ -0,0 +1,1 @@ +let a = 2 + 2/ diff --git a/tests/fixtures/diagnostics/MissingImport.dhall b/tests/fixtures/diagnostics/MissingImport.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/diagnostics/MissingImport.dhall @@ -0,0 +1,1 @@ +./NonExistent.dhall diff --git a/tests/fixtures/diagnostics/UnboundVar.dhall b/tests/fixtures/diagnostics/UnboundVar.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/diagnostics/UnboundVar.dhall @@ -0,0 +1,1 @@ +unboundVar diff --git a/tests/fixtures/diagnostics/WrongType.dhall b/tests/fixtures/diagnostics/WrongType.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/diagnostics/WrongType.dhall @@ -0,0 +1,1 @@ +let a = "dhall" : List Text in a diff --git a/tests/fixtures/hovering/Types.dhall b/tests/fixtures/hovering/Types.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/hovering/Types.dhall @@ -0,0 +1,11 @@ +let User = { name : Text, home : Text } + +let mkUser = + λ(_isAdmin : Bool) + → if _isAdmin + + then { name = "admin", home = "/home/admin" } + + else { name = "default", home = "/home/user" } + +in mkUser True : User diff --git a/tests/fixtures/linting/SuperfluousIn.dhall b/tests/fixtures/linting/SuperfluousIn.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/linting/SuperfluousIn.dhall @@ -0,0 +1,3 @@ +let alice = { name = "Alice", age = 20 } + +in let carl = { name = "Carl", age = 22 } in alice diff --git a/tests/fixtures/linting/UnusedBindings.dhall b/tests/fixtures/linting/UnusedBindings.dhall new file mode 100644 --- /dev/null +++ b/tests/fixtures/linting/UnusedBindings.dhall @@ -0,0 +1,7 @@ +let alice = { name = "Alice", age = 20 } + +let bob = { name = "Bob", age = 21 } + +let carl = { name = "Carl", age = 22 } + +in alice