From 22ec25670a4dc61594c04040de4744ae39e57831 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 Feb 2020 18:12:12 +0000 Subject: [PATCH 1/5] WIP on introducing tasty test suite --- haskell-language-server.cabal | 77 ++++++- hie.yaml.cbl | 5 +- hie.yaml.stack | 2 +- test/Spec.hs | 2 - test/exe/Main.hs | 141 ++++++++++++ test/utils/TestUtils.hs | 412 ++++++++++++++++++++++++++++++++++ 6 files changed, 628 insertions(+), 11 deletions(-) delete mode 100644 test/Spec.hs create mode 100644 test/exe/Main.hs create mode 100644 test/utils/TestUtils.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4ca1680ff3..8589e68caf 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -173,13 +173,51 @@ executable haskell-language-server-wrapper default-language: Haskell2010 -test-suite test +test-suite hls-tests type: exitcode-stdio-1.0 - main-is: Spec.hs + default-language: Haskell2010 + build-tool-depends: + haskell-language-server:haskell-language-server, + ghcide:ghcide-test-preprocessor + build-depends: + base >=4.7 && <5 + , haskell-language-server + , aeson + , base + , bytestring + , containers + , directory + , extra + , filepath + -------------------------------------------------------------- + -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas + -- which require depending on ghc. So the tests need to depend + -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a + -- better solution can be found, but this is a quick solution + -- which works for now. + , ghc + -------------------------------------------------------------- + , ghcide + , ghc-typelits-knownnat + , haddock-library + , haskell-lsp + , haskell-lsp-types + , hls-test-utils + , lens + , lsp-test >= 0.8 + , parser-combinators + , QuickCheck + , quickcheck-instances + , rope-utf16-splay + , tasty + , tasty-expected-failure + , tasty-hunit + , tasty-quickcheck + , text other-modules: Paths_haskell_language_server hs-source-dirs: - test + test/exe ghc-options: -Wall -Wredundant-constraints @@ -187,7 +225,32 @@ test-suite test -threaded -rtsopts -with-rtsopts=-N if flag(pedantic) ghc-options: -Werror - build-depends: - base >=4.7 && <5 - , haskell-language-server - default-language: Haskell2010 + main-is: Main.hs + -- other-modules: + -- Development.IDE.Test + -- Development.IDE.Test.Runfiles + +library hls-test-utils + hs-source-dirs: test/utils + exposed-modules: TestUtils + build-depends: base + , haskell-language-server + , haskell-lsp + , hie-bios + , aeson + , blaze-markup + , containers + , data-default + , directory + , filepath + , hslogger + , hspec + , hspec-core + , stm + , text + , unordered-containers + , yaml + ghc-options: -Wall -Wredundant-constraints + if flag(pedantic) + ghc-options: -Werror + default-language: Haskell2010 diff --git a/hie.yaml.cbl b/hie.yaml.cbl index d68984ceec..c9f53613e8 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -9,7 +9,10 @@ cradle: cabal: - path: "./test" - component: "haskell-language-server:test" + component: "haskell-language-server:hls-tests" + + - path: "./test/utils/" + component: "haskell-language-server:hls-test-utils" - path: "./exe/Main.hs" component: "haskell-language-server:exe:haskell-language-server" diff --git a/hie.yaml.stack b/hie.yaml.stack index 2e841d5763..8d184076ba 100644 --- a/hie.yaml.stack +++ b/hie.yaml.stack @@ -12,7 +12,7 @@ cradle: stack: - path: "./test" - component: "haskell-language-server:test" + component: "haskell-language-server:hls-tests" - path: "./exe/Main.hs" component: "haskell-language-server:exe:haskell-language-server" diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753fc9c..0000000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/test/exe/Main.hs b/test/exe/Main.hs new file mode 100644 index 0000000000..3c6eeeb870 --- /dev/null +++ b/test/exe/Main.hs @@ -0,0 +1,141 @@ +-- Copyright (c) 2019-2020 The DAML and HLS Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.Applicative.Combinators +import Control.Exception (catch) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Char (toLower) +import Data.Foldable +import Data.List +import Data.Rope.UTF16 (Rope) +import qualified Data.Rope.UTF16 as Rope +import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) +import Development.IDE.GHC.Util +import qualified Data.Text as T +import Development.IDE.Spans.Common +-- import Development.IDE.Test +-- import Development.IDE.Test.Runfiles +import Development.IDE.Types.Location +import qualified Language.Haskell.LSP.Test as LSPTest +import Language.Haskell.LSP.Test hiding (openDoc') +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import Language.Haskell.LSP.VFS (applyChange) +import System.Environment.Blank (setEnv) +import System.FilePath +import System.IO.Extra +import System.Directory +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Data.Maybe + +import TestUtils + +-- --------------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "HLS" + [ testSession "open close" $ do + doc <- openDoc' "Testing.hs" "haskell" "" + void (message :: Session WorkDoneProgressCreateRequest) + void (message :: Session WorkDoneProgressBeginNotification) + closeDoc doc + void (message :: Session WorkDoneProgressEndNotification) + ] + +---------------------------------------------------------------------- +-- Utils + + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +{- +testSessionWait :: String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction +pickActionWithTitle title actions = head + [ action + | CACodeAction action@CodeAction{ _title = actionTitle } <- actions + , title == actionTitle ] +-} + +mkRange :: Int -> Int -> Int -> Int -> Range +mkRange a b c d = Range (Position a b) (Position c d) + +run :: Session a -> IO a +run s = withTempDir $ \dir -> do + let ghcideExe = hieCommand + + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ dir ++ "/Data" + + let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir] + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + runSessionWithConfig conf cmd lspTestCaps dir s + where + conf = defaultConfig + -- If you uncomment this you can see all logging + -- which can be quite useful for debugging. + -- { logStdErr = True, logColor = False } + -- If you really want to, you can also see all messages + -- { logMessages = True, logColor = False } + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + openDoc' path "haskell" source + +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions doc range expectedTitles = do + actions <- getCodeActions doc range + let matches = sequence + [ listToMaybe + [ action + | CACodeAction action@CodeAction { _title = actionTitle } <- actions + , actionTitle == expectedTitle ] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + ++ "is not a superset of " + ++ show expectedTitles + liftIO $ case matches of + Nothing -> assertFailure msg + Just _ -> pure () + return (fromJust matches) + +findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction +findCodeAction doc range t = head <$> findCodeActions doc range [t] + +-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events +openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier +openDoc' fp name contents = do + res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents + sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated]) + return res diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs new file mode 100644 index 0000000000..d3ab33f54a --- /dev/null +++ b/test/utils/TestUtils.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns #-} +module TestUtils + -- ( + -- withFileLogging + -- , setupBuildToolFiles + -- , testCommand + -- , runSingle + -- , runSingle' + -- , runSingleReq + -- , makeRequest + -- , runIGM + -- , runIGM' + -- , ghcVersion, GhcVersion(..) + -- , logFilePath + -- , readResolver + -- , hieCommand + -- , hieCommandVomit + -- , hieCommandExamplePlugin + -- , getHspecFormattedConfig + -- , testOptions + -- , flushStackEnvironment + -- , dummyLspFuncs + -- ) +where + +import Control.Concurrent.STM +import Control.Monad +import Data.Aeson.Types (typeMismatch) +import Data.Default +import Data.List (intercalate) +import Data.Text (pack) +import Data.Typeable +import Data.Yaml +import qualified Data.Map as Map +import Data.Maybe +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types +-- import Haskell.Ide.Engine.MonadTypes hiding (withProgress, withIndefiniteProgress) +import qualified Ide.Cradle as Bios +-- import qualified Ide.Engine.Config as Config +import System.Directory +import System.Environment +import System.FilePath +import qualified System.Log.Logger as L +import Test.Hspec +import Test.Hspec.Runner +import Test.Hspec.Core.Formatters +import Text.Blaze.Renderer.String (renderMarkup) +import Text.Blaze.Internal +-- import qualified Haskell.Ide.Engine.PluginApi as HIE (BiosOptions, defaultOptions) + +import HIE.Bios.Types + +-- testOptions :: HIE.BiosOptions +-- testOptions = HIE.defaultOptions { cradleOptsVerbosity = Verbose } + +-- --------------------------------------------------------------------- + + +-- testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) +-- => IdePlugins -> FilePath -> IdeGhcM (IdeResult b) -> PluginId -> CommandId -> a -> IdeResult b -> IO () +-- testCommand testPlugins fp act plugin cmd arg res = do +-- flushStackEnvironment +-- (newApiRes, oldApiRes) <- runIGM testPlugins fp $ do +-- new <- act +-- old <- makeRequest plugin cmd arg +-- return (new, old) +-- newApiRes `shouldBe` res +-- fmap fromDynJSON oldApiRes `shouldBe` fmap Just res + +-- runSingle :: IdePlugins -> FilePath -> IdeGhcM (IdeResult b) -> IO (IdeResult b) +-- runSingle = runSingle' id + +-- runSingle' :: (Config.Config -> Config.Config) -> IdePlugins -> FilePath -> IdeGhcM (IdeResult b) -> IO (IdeResult b) +-- runSingle' modifyConfig testPlugins fp act = runIGM' modifyConfig testPlugins fp act + +-- runSingleReq :: ToJSON a +-- => IdePlugins -> FilePath -> PluginId -> CommandId -> a -> IO (IdeResult DynamicJSON) +-- runSingleReq testPlugins fp plugin com arg = runIGM testPlugins fp (makeRequest plugin com arg) + +-- makeRequest :: ToJSON a => PluginId -> CommandId -> a -> IdeGhcM (IdeResult DynamicJSON) +-- makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg) + +-- runIGM :: IdePlugins -> FilePath -> IdeGhcM a -> IO a +-- runIGM = runIGM' id + +-- runIGM' :: (Config.Config -> Config.Config) -> IdePlugins -> FilePath -> IdeGhcM a -> IO a +-- runIGM' modifyConfig testPlugins fp f = do +-- stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing +-- crdl <- Bios.findLocalCradle fp +-- mlibdir <- Bios.getProjectGhcLibDir crdl +-- let tmpFuncs :: LspFuncs Config.Config +-- tmpFuncs = dummyLspFuncs +-- lspFuncs :: LspFuncs Config.Config +-- lspFuncs = tmpFuncs { config = (fmap . fmap) modifyConfig (config tmpFuncs)} +-- runIdeGhcM mlibdir testPlugins lspFuncs stateVar f + +withFileLogging :: FilePath -> IO a -> IO a +withFileLogging logFile f = do + let logDir = "./test-logs" + logPath = logDir logFile + + dirExists <- doesDirectoryExist logDir + unless dirExists $ createDirectory logDir + + exists <- doesFileExist logPath + when exists $ removeFile logPath + + setupLogger (Just logPath) ["hie"] L.DEBUG + + f + +-- --------------------------------------------------------------------- + +-- If an executable @stack@ is present on the system then setup stack files, +-- otherwise specify a direct cradle with -isrc +setupBuildToolFiles :: IO () +setupBuildToolFiles = do + stack <- findExecutable "stack" + let s = case stack of + Nothing -> setupDirectFilesIn + Just _ -> setupStackFilesIn + forM_ files $ \f -> do + s f + -- Cleanup stack directory in case the presence of stack has changed since + -- the last run + removePathForcibly (f ++ ".stack-work") + +setupStackFilesIn :: FilePath -> IO () +setupStackFilesIn f = do + resolver <- readResolver + writeFile (f ++ "stack.yaml") $ stackFileContents resolver + case f of + "./test/testdata/" -> writeFile (f ++ "hie.yaml") testdataHieYamlCradleStackContents + _ -> writeFile (f ++ "hie.yaml") hieYamlCradleStackContents + +setupDirectFilesIn :: FilePath -> IO () +setupDirectFilesIn f = + writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents + +-- --------------------------------------------------------------------- + +files :: [FilePath] +files = + [ "./test/testdata/" + , "./test/testdata/addPackageTest/cabal-exe/" + , "./test/testdata/addPackageTest/hpack-exe/" + , "./test/testdata/addPackageTest/cabal-lib/" + , "./test/testdata/addPackageTest/hpack-lib/" + , "./test/testdata/addPragmas/" + , "./test/testdata/badProjects/cabal/" + , "./test/testdata/completion/" + , "./test/testdata/definition/" + , "./test/testdata/gototest/" + , "./test/testdata/redundantImportTest/" + , "./test/testdata/wErrorTest/" + ] + +data GhcVersion + = GHC88 + | GHC86 + | GHC84 + deriving (Eq,Show) + +ghcVersion :: GhcVersion +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0))) +ghcVersion = GHC88 +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,0,0))) +ghcVersion = GHC86 +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0))) +ghcVersion = GHC84 +#endif + +stackYaml :: FilePath +stackYaml = +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,2,0))) + "stack-8.8.2.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0))) + "stack-8.8.1.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,5,0))) + "stack-8.6.5.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,4,0))) + "stack-8.6.4.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,3,0))) + "stack-8.6.3.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,2,0))) + "stack-8.6.2.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,1,0))) + "stack-8.6.1.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,4,0))) + "stack-8.4.4.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0))) + "stack-8.4.3.yaml" +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,2,0))) + "stack-8.4.2.yaml" +#endif + +logFilePath :: String +logFilePath = "hie-" ++ stackYaml ++ ".log" + +-- | The command to execute the version of hie for the current compiler. +-- +-- Both @stack test@ and @cabal new-test@ setup the environment so @hie@ is +-- on PATH. Cabal seems to respond to @build-tool-depends@ specifically while +-- stack just puts all project executables on PATH. +hieCommand :: String +hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath + +hieCommandVomit :: String +hieCommandVomit = hieCommand ++ " --vomit" + +hieCommandExamplePlugin :: String +hieCommandExamplePlugin = hieCommand ++ " --example" + +-- |Choose a resolver based on the current compiler, otherwise HaRe/ghc-mod will +-- not be able to load the files +readResolver :: IO String +readResolver = readResolverFrom stackYaml + +newtype StackResolver = StackResolver String + +instance FromJSON StackResolver where + parseJSON (Object x) = StackResolver <$> x .: pack "resolver" + parseJSON invalid = typeMismatch "StackResolver" invalid + +readResolverFrom :: FilePath -> IO String +readResolverFrom yamlPath = do + result <- decodeFileEither yamlPath + case result of + Left err -> error $ yamlPath ++ " parsing failed: " ++ show err + Right (StackResolver res) -> return res + +-- --------------------------------------------------------------------- + +hieYamlCradleStackContents :: String +hieYamlCradleStackContents = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , "cradle:" + , " stack:" + ] + +testdataHieYamlCradleStackContents :: String +testdataHieYamlCradleStackContents = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , "cradle:" + , " stack:" + , " - path: \"ApplyRefact.hs\"" + , " component: \"testdata:exe:applyrefact\"" + , " - path: \"ApplyRefact2.hs\"" + , " component: \"testdata:exe:applyrefact2\"" + , " - path: \"CodeActionRename.hs\"" + , " component: \"testdata:exe:codeactionrename\"" + , " - path: \"Hover.hs\"" + , " component: \"testdata:exe:hover\"" + , " - path: \"Symbols.hs\"" + , " component: \"testdata:exe:symbols\"" + , " - path: \"ApplyRefact2.hs\"" + , " component: \"testdata:exe:applyrefact2\"" + , " - path: \"HlintPragma.hs\"" + , " component: \"testdata:exe:hlintpragma\"" + , " - path: \"HaReCase.hs\"" + , " component: \"testdata:exe:harecase\"" + , " - path: \"HaReDemote.hs\"" + , " component: \"testdata:exe:haredemote\"" + , " - path: \"HaReMoveDef.hs\"" + , " component: \"testdata:exe:haremovedef\"" + , " - path: \"HaReRename.hs\"" + , " component: \"testdata:exe:harerename\"" + , " - path: \"HaReGA1.hs\"" + , " component: \"testdata:exe:haregenapplicative\"" + , " - path: \"FuncTest.hs\"" + , " component: \"testdata:exe:functests\"" + , " - path: \"liquid/Evens.hs\"" + , " component: \"testdata:exe:evens\"" + , " - path: \"FileWithWarning.hs\"" + , " component: \"testdata:exe:filewithwarning\"" + , " - path: ." + , " component: \"testdata:exe:filewithwarning\"" + ] + + +hieYamlCradleDirectContents :: String +hieYamlCradleDirectContents = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , "cradle:" + , " direct:" + , " arguments:" + , " - -isrc" + ] + +stackFileContents :: String -> String +stackFileContents resolver = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , "resolver: " ++ resolver + , "packages:" + , "- '.'" + , "extra-deps: []" + , "flags: {}" + , "extra-package-dbs: []" + ] + +-- --------------------------------------------------------------------- + +getHspecFormattedConfig :: String -> IO Config +getHspecFormattedConfig name = do + -- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables + isCI <- isJust <$> lookupEnv "CI" + + -- Only use the xml formatter on CI since it hides console output + if isCI + then do + let subdir = "test-results" name + createDirectoryIfMissing True subdir + + return $ defaultConfig { configFormatter = Just xmlFormatter + , configOutputFile = Right $ subdir "results.xml" + } + else return defaultConfig + +-- | A Hspec formatter for CircleCI. +-- Originally from https://github.com/LeastAuthority/hspec-jenkins +xmlFormatter :: Formatter +xmlFormatter = silent { + headerFormatter = do + writeLine "" + writeLine "" + , exampleSucceeded + , exampleFailed + , examplePending + , footerFormatter = writeLine "" + } + where + +#if MIN_VERSION_hspec(2,5,0) + exampleSucceeded path _ = +#else + exampleSucceeded path = +#endif + writeLine $ renderMarkup $ testcase path "" + +#if MIN_VERSION_hspec(2,5,0) + exampleFailed path _ err = +#else + exampleFailed path (Left err) = + writeLine $ renderMarkup $ testcase path $ + failure ! message (show err) $ "" + exampleFailed path (Right err) = +#endif + writeLine $ renderMarkup $ testcase path $ + failure ! message (reasonAsString err) $ "" + +#if MIN_VERSION_hspec(2,5,0) + examplePending path _ reason = +#else + examplePending path reason = +#endif + writeLine $ renderMarkup $ testcase path $ + case reason of + Just desc -> skipped ! message desc $ "" + Nothing -> skipped "" + + failure, skipped :: Markup -> Markup + failure = customParent "failure" + skipped = customParent "skipped" + + name, className, message :: String -> Attribute + name = customAttribute "name" . stringValue + className = customAttribute "classname" . stringValue + message = customAttribute "message" . stringValue + + testcase :: Path -> Markup -> Markup + testcase (xs,x) = customParent "testcase" ! name x ! className (intercalate "." xs) + + reasonAsString :: FailureReason -> String + reasonAsString NoReason = "no reason given" + reasonAsString (Reason x) = x + reasonAsString (ExpectedButGot Nothing expected got) = "Expected " ++ expected ++ " but got " ++ got + reasonAsString (ExpectedButGot (Just src) expected got) = src ++ " expected " ++ expected ++ " but got " ++ got +#if MIN_VERSION_hspec(2,5,0) + reasonAsString (Error Nothing err ) = show err + reasonAsString (Error (Just s) err) = s ++ show err +#endif + +-- --------------------------------------------------------------------- + +flushStackEnvironment :: IO () +flushStackEnvironment = do + -- We need to clear these environment variables to prevent + -- collisions with stack usages + -- See https://github.com/commercialhaskell/stack/issues/4875 + unsetEnv "GHC_PACKAGE_PATH" + unsetEnv "GHC_ENVIRONMENT" + unsetEnv "HASKELL_PACKAGE_SANDBOX" + unsetEnv "HASKELL_PACKAGE_SANDBOXES" + +-- --------------------------------------------------------------------- + +dummyLspFuncs :: Default a => LspFuncs a +dummyLspFuncs = LspFuncs { clientCapabilities = def + , config = return (Just def) + , sendFunc = const (return ()) + , getVirtualFileFunc = const (return Nothing) + , persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri)) + , reverseFileMapFunc = return id + , publishDiagnosticsFunc = mempty + , flushDiagnosticsBySourceFunc = mempty + , getNextReqId = pure (IdInt 0) + , rootPath = Nothing + , getWorkspaceFolders = return Nothing + , withProgress = \_ _ f -> f (const (return ())) + , withIndefiniteProgress = \_ _ f -> f + } From 2521a7f965922022471be13cbc6787f7723fbf5a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 Feb 2020 21:16:47 +0000 Subject: [PATCH 2/5] WIP on formatting spec, via hspec We only have an Ormolu formatter at present, want to make sure the circle stuff actually works too. Need to plumb the config values through to the actual formatter. --- haskell-language-server.cabal | 44 +++++-- stack.yaml | 6 +- test/functional/FormatSpec.hs | 207 ++++++++++++++++++++++++++++++ test/functional/FunctionalSpec.hs | 1 + test/functional/Main.hs | 19 +++ test/functional/Utils.hs | 21 +++ test/testdata/BrittanyCRLF.hs | 3 + test/testdata/BrittanyLF.hs | 3 + test/testdata/Format.hs | 9 ++ test/testdata/stack.yaml | 7 + test/testdata/testdata.cabal | 82 ++++++++++++ test/utils/TestUtils.hs | 51 ++++---- 12 files changed, 414 insertions(+), 39 deletions(-) create mode 100644 test/functional/FormatSpec.hs create mode 100644 test/functional/FunctionalSpec.hs create mode 100644 test/functional/Main.hs create mode 100644 test/functional/Utils.hs create mode 100644 test/testdata/BrittanyCRLF.hs create mode 100644 test/testdata/BrittanyLF.hs create mode 100644 test/testdata/Format.hs create mode 100644 test/testdata/stack.yaml create mode 100644 test/testdata/testdata.cabal diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8589e68caf..52bfe13ba7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -173,12 +173,14 @@ executable haskell-language-server-wrapper default-language: Haskell2010 -test-suite hls-tests +test-suite func-test type: exitcode-stdio-1.0 default-language: Haskell2010 - build-tool-depends: - haskell-language-server:haskell-language-server, - ghcide:ghcide-test-preprocessor + build-tool-depends: hspec-discover:hspec-discover + , haskell-language-server:haskell-language-server + , cabal-helper:cabal-helper-main + , ghcide:ghcide-test-preprocessor + build-depends: base >=4.7 && <5 , haskell-language-server @@ -186,6 +188,7 @@ test-suite hls-tests , base , bytestring , containers + , data-default , directory , extra , filepath @@ -204,20 +207,39 @@ test-suite hls-tests , haskell-lsp-types , hls-test-utils , lens - , lsp-test >= 0.8 + , lsp-test >= 0.10.0.0 , parser-combinators , QuickCheck , quickcheck-instances , rope-utf16-splay - , tasty - , tasty-expected-failure - , tasty-hunit - , tasty-quickcheck , text + , hspec + , hspec-core other-modules: - Paths_haskell_language_server + -- CompletionSpec + -- , CommandSpec + -- , DeferredSpec + -- , DefinitionSpec + -- , DiagnosticsSpec + FormatSpec + -- , FunctionalBadProjectSpec + -- , FunctionalCodeActionsSpec + -- , FunctionalLiquidSpec + , FunctionalSpec + -- , HaReSpec + -- , HieBiosSpec + -- , HighlightSpec + -- , HoverSpec + -- , ProgressSpec + -- , ReferencesSpec + -- , RenameSpec + -- , SymbolsSpec + -- , TypeDefinitionSpec + , Utils + , Paths_haskell_language_server + hs-source-dirs: - test/exe + test/functional ghc-options: -Wall -Wredundant-constraints diff --git a/stack.yaml b/stack.yaml index 604898c3f9..095010b52b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,9 +30,9 @@ extra-deps: - temporary-1.2.1.1 - topograph-1 -flags: - haskell-language-server: - pedantic: true +# flags: +# haskell-language-server: +# pedantic: true # allow-newer: true diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs new file mode 100644 index 0000000000..96d2e4fc00 --- /dev/null +++ b/test/functional/FormatSpec.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings #-} +module FormatSpec where + +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.Text as T +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Test.Hspec +import TestUtils + +spec :: Spec +spec = do + describe "format document" $ do + it "works" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize2) + it "works with custom tab size" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 5 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize5) + + describe "format range" $ do + it "works" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize2) + it "works with custom tab size" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + formatRange doc (FormattingOptions 5 True) (Range (Position 4 0) (Position 7 19)) + documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize5) + + describe "formatting provider" $ do + let formatLspConfig provider = + object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] + formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } + + it "respects none" $ runSessionWithConfig (formatConfig "none") hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + orig <- documentContents doc + + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` orig) + + formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + documentContents doc >>= liftIO . (`shouldBe` orig) + + it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize2) + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedFloskell) + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedBrittanyPostFloskell) + + describe "brittany" $ do + it "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "BrittanyLF.hs" "haskell" + let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing + ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts + liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) + "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] + + it "formats a document with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "BrittanyCRLF.hs" "haskell" + let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing + ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts + liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) + "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] + + it "formats a range with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "BrittanyLF.hs" "haskell" + let range = Range (Position 1 0) (Position 2 22) + opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing + ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts + liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) + "foo x y = do\n print x\n return 42\n"] + + it "formats a range with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "BrittanyCRLF.hs" "haskell" + let range = Range (Position 1 0) (Position 2 22) + opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing + ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts + liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) + "foo x y = do\n print x\n return 42\n"] + + describe "ormolu" $ do + let formatLspConfig provider = + object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] + + it "formats correctly" $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + docContent <- documentContents doc + let formatted = liftIO $ docContent `shouldBe` formattedOrmolu + case ghcVersion of + GHC88 -> formatted + GHC86 -> formatted + _ -> liftIO $ docContent `shouldBe` unchangedOrmolu + + +formattedDocTabSize2 :: T.Text +formattedDocTabSize2 = + "module Format where\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\n" + +formattedDocTabSize5 :: T.Text +formattedDocTabSize5 = + "module Format where\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\n" + +formattedRangeTabSize2 :: T.Text +formattedRangeTabSize2 = + "module Format where\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\ + \ \n" + +formattedRangeTabSize5 :: T.Text +formattedRangeTabSize5 = + "module Format where\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\ + \ \n" + +formattedFloskell :: T.Text +formattedFloskell = + "module Format where\n\ + \\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\n\ + \" + +formattedBrittanyPostFloskell :: T.Text +formattedBrittanyPostFloskell = + "module Format where\n\ + \\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\n" + +formattedOrmolu :: T.Text +formattedOrmolu = + "module Format where\n\ + \\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n" + +unchangedOrmolu :: T.Text +unchangedOrmolu = + "module Format where\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n\ + \ \n" diff --git a/test/functional/FunctionalSpec.hs b/test/functional/FunctionalSpec.hs new file mode 100644 index 0000000000..6a7e8ad4ef --- /dev/null +++ b/test/functional/FunctionalSpec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=FunctionalSpec #-} diff --git a/test/functional/Main.hs b/test/functional/Main.hs new file mode 100644 index 0000000000..312ab2b880 --- /dev/null +++ b/test/functional/Main.hs @@ -0,0 +1,19 @@ +module Main where + +import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import qualified FunctionalSpec +import Test.Hspec.Runner (hspecWith) +import TestUtils + +main :: IO () +main = do + setupBuildToolFiles + -- run a test session to warm up the cache to prevent timeouts in other tests + putStrLn "Warming up HIE cache..." + putStrLn $ "hieCommand: " ++ hieCommand + runSessionWithConfig (defaultConfig { messageTimeout = 120 }) hieCommand fullCaps "test/testdata" $ + liftIO $ putStrLn "HIE cache is warmed up" + + config <- getHspecFormattedConfig "functional" + withFileLogging logFilePath $ hspecWith config FunctionalSpec.spec diff --git a/test/functional/Utils.hs b/test/functional/Utils.hs new file mode 100644 index 0000000000..88ba0cf781 --- /dev/null +++ b/test/functional/Utils.hs @@ -0,0 +1,21 @@ +module Utils where + +import Data.Default +import qualified Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Test hiding (message) +import qualified Language.Haskell.LSP.Types.Capabilities as C + +-- --------------------------------------------------------------------- + +noLogConfig :: SessionConfig +noLogConfig = Test.defaultConfig { logMessages = False } + +logConfig :: SessionConfig +logConfig = Test.defaultConfig { logMessages = True } + +codeActionSupportCaps :: C.ClientCapabilities +codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } + where + textDocumentCaps = def { C._codeAction = Just codeActionCaps } + codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport) + literalSupport = C.CodeActionLiteralSupport def diff --git a/test/testdata/BrittanyCRLF.hs b/test/testdata/BrittanyCRLF.hs new file mode 100644 index 0000000000..2ed3293b3d --- /dev/null +++ b/test/testdata/BrittanyCRLF.hs @@ -0,0 +1,3 @@ +foo :: Int -> String-> IO () +foo x y = do print x + return 42 \ No newline at end of file diff --git a/test/testdata/BrittanyLF.hs b/test/testdata/BrittanyLF.hs new file mode 100644 index 0000000000..4662d9b5a8 --- /dev/null +++ b/test/testdata/BrittanyLF.hs @@ -0,0 +1,3 @@ +foo :: Int -> String-> IO () +foo x y = do print x + return 42 \ No newline at end of file diff --git a/test/testdata/Format.hs b/test/testdata/Format.hs new file mode 100644 index 0000000000..76e40c9816 --- /dev/null +++ b/test/testdata/Format.hs @@ -0,0 +1,9 @@ +module Format where +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + diff --git a/test/testdata/stack.yaml b/test/testdata/stack.yaml new file mode 100644 index 0000000000..3644ccf5de --- /dev/null +++ b/test/testdata/stack.yaml @@ -0,0 +1,7 @@ +# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils. IT WILL BE OVERWRITTEN ON EVERY TEST RUN +resolver: lts-14.22 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal new file mode 100644 index 0000000000..c191bbd1f1 --- /dev/null +++ b/test/testdata/testdata.cabal @@ -0,0 +1,82 @@ +name: testdata +version: 0.1.0.0 +cabal-version: >=2.0 +build-type: Simple + +executable applyrefact + build-depends: base + main-is: ApplyRefact.hs + default-language: Haskell2010 + +executable applyrefact2 + build-depends: base + main-is: ApplyRefact2.hs + default-language: Haskell2010 + +executable codeactionrename + build-depends: base + main-is: CodeActionRename.hs + default-language: Haskell2010 + +executable hover + build-depends: base + main-is: Hover.hs + default-language: Haskell2010 + +executable symbols + build-depends: base + main-is: Symbols.hs + default-language: Haskell2010 + + +executable applyrefact2 + build-depends: base + main-is: ApplyRefact2.hs + default-language: Haskell2010 + +executable hlintpragma + build-depends: base + main-is: HlintPragma.hs + default-language: Haskell2010 + +executable harecase + build-depends: base + main-is: HaReCase.hs + default-language: Haskell2010 + +executable haredemote + build-depends: base + main-is: HaReDemote.hs + default-language: Haskell2010 + +executable haremovedef + build-depends: base + main-is: HaReMoveDef.hs + default-language: Haskell2010 + +executable harerename + build-depends: base + main-is: HaReRename.hs + default-language: Haskell2010 + +executable haregenapplicative + build-depends: base + , parsec + main-is: HaReGA1.hs + default-language: Haskell2010 + +executable functests + build-depends: base + main-is: FuncTest.hs + default-language: Haskell2010 + +executable evens + build-depends: base + main-is: Evens.hs + hs-source-dirs: liquid + default-language: Haskell2010 + +executable filewithwarning + build-depends: base + main-is: FileWithWarning.hs + default-language: Haskell2010 diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index d3ab33f54a..4867ae16fd 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns #-} module TestUtils - -- ( - -- withFileLogging - -- , setupBuildToolFiles + ( + withFileLogging + , setupBuildToolFiles -- , testCommand -- , runSingle -- , runSingle' @@ -10,17 +10,17 @@ module TestUtils -- , makeRequest -- , runIGM -- , runIGM' - -- , ghcVersion, GhcVersion(..) - -- , logFilePath - -- , readResolver - -- , hieCommand - -- , hieCommandVomit - -- , hieCommandExamplePlugin - -- , getHspecFormattedConfig + , ghcVersion, GhcVersion(..) + , logFilePath + , readResolver + , hieCommand + , hieCommandVomit + , hieCommandExamplePlugin + , getHspecFormattedConfig -- , testOptions - -- , flushStackEnvironment - -- , dummyLspFuncs - -- ) + , flushStackEnvironment + , dummyLspFuncs + ) where import Control.Concurrent.STM @@ -143,17 +143,17 @@ setupDirectFilesIn f = files :: [FilePath] files = [ "./test/testdata/" - , "./test/testdata/addPackageTest/cabal-exe/" - , "./test/testdata/addPackageTest/hpack-exe/" - , "./test/testdata/addPackageTest/cabal-lib/" - , "./test/testdata/addPackageTest/hpack-lib/" - , "./test/testdata/addPragmas/" - , "./test/testdata/badProjects/cabal/" - , "./test/testdata/completion/" - , "./test/testdata/definition/" - , "./test/testdata/gototest/" - , "./test/testdata/redundantImportTest/" - , "./test/testdata/wErrorTest/" + -- , "./test/testdata/addPackageTest/cabal-exe/" + -- , "./test/testdata/addPackageTest/hpack-exe/" + -- , "./test/testdata/addPackageTest/cabal-lib/" + -- , "./test/testdata/addPackageTest/hpack-lib/" + -- , "./test/testdata/addPragmas/" + -- , "./test/testdata/badProjects/cabal/" + -- , "./test/testdata/completion/" + -- , "./test/testdata/definition/" + -- , "./test/testdata/gototest/" + -- , "./test/testdata/redundantImportTest/" + -- , "./test/testdata/wErrorTest/" ] data GhcVersion @@ -204,7 +204,8 @@ logFilePath = "hie-" ++ stackYaml ++ ".log" -- on PATH. Cabal seems to respond to @build-tool-depends@ specifically while -- stack just puts all project executables on PATH. hieCommand :: String -hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath +-- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath +hieCommand = "haskell-language-server --lsp" hieCommandVomit :: String hieCommandVomit = hieCommand ++ " --vomit" From 769797c49ba4276232bbaf153ad4e437103c43f6 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 Feb 2020 21:49:11 +0000 Subject: [PATCH 3/5] Format tests pass for Ormolu --- .gitignore | 1 + stack.yaml | 6 +- test/functional/FormatSpec.hs | 154 ++++++++++++++++++---------------- test/utils/TestUtils.hs | 12 +-- 4 files changed, 94 insertions(+), 79 deletions(-) diff --git a/.gitignore b/.gitignore index 831a43a763..76fa65c3be 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ stack*.yaml.lock shake.yaml.lock .vscode +/test-logs/ diff --git a/stack.yaml b/stack.yaml index 095010b52b..604898c3f9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,9 +30,9 @@ extra-deps: - temporary-1.2.1.1 - topograph-1 -# flags: -# haskell-language-server: -# pedantic: true +flags: + haskell-language-server: + pedantic: true # allow-newer: true diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 96d2e4fc00..fe7b69db30 100644 --- a/test/functional/FormatSpec.hs +++ b/test/functional/FormatSpec.hs @@ -15,82 +15,86 @@ spec = do it "works" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize2) - it "works with custom tab size" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 5 True) - documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize5) + documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) + it "works with custom tab size" $ do + pendingWith "ormolu does not accept parameters" + -- $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- formatDoc doc (FormattingOptions 5 True) + -- documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize5) describe "format range" $ do it "works" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize2) - it "works with custom tab size" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 5 True) (Range (Position 4 0) (Position 7 19)) - documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize5) - - describe "formatting provider" $ do - let formatLspConfig provider = - object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] - formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } - - it "respects none" $ runSessionWithConfig (formatConfig "none") hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "Format.hs" "haskell" - orig <- documentContents doc - - formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (`shouldBe` orig) - - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) - documentContents doc >>= liftIO . (`shouldBe` orig) - - it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "Format.hs" "haskell" - - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize2) - - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) - formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (`shouldBe` formattedFloskell) - - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (`shouldBe` formattedBrittanyPostFloskell) - - describe "brittany" $ do - it "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "BrittanyLF.hs" "haskell" - let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing - ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts - liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) - "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] - - it "formats a document with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "BrittanyCRLF.hs" "haskell" - let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing - ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts - liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) - "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] - - it "formats a range with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "BrittanyLF.hs" "haskell" - let range = Range (Position 1 0) (Position 2 22) - opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing - ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts - liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) - "foo x y = do\n print x\n return 42\n"] - - it "formats a range with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "BrittanyCRLF.hs" "haskell" - let range = Range (Position 1 0) (Position 2 22) - opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing - ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts - liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) - "foo x y = do\n print x\n return 42\n"] + it "works with custom tab size" $ do + pendingWith "ormolu does not accept parameters" + -- $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- formatRange doc (FormattingOptions 5 True) (Range (Position 4 0) (Position 7 19)) + -- documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize5) + + -- describe "formatting provider" $ do + -- let formatLspConfig provider = + -- object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] + -- formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } + + -- it "respects none" $ runSessionWithConfig (formatConfig "none") hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- orig <- documentContents doc + + -- formatDoc doc (FormattingOptions 2 True) + -- documentContents doc >>= liftIO . (`shouldBe` orig) + + -- formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + -- documentContents doc >>= liftIO . (`shouldBe` orig) + + -- it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "Format.hs" "haskell" + + -- sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + -- formatDoc doc (FormattingOptions 2 True) + -- documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize2) + + -- sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) + -- formatDoc doc (FormattingOptions 2 True) + -- documentContents doc >>= liftIO . (`shouldBe` formattedFloskell) + + -- sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + -- formatDoc doc (FormattingOptions 2 True) + -- documentContents doc >>= liftIO . (`shouldBe` formattedBrittanyPostFloskell) + + -- describe "brittany" $ do + -- it "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "BrittanyLF.hs" "haskell" + -- let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing + -- ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts + -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) + -- "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] + + -- it "formats a document with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "BrittanyCRLF.hs" "haskell" + -- let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing + -- ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts + -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0)) + -- "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n"] + + -- it "formats a range with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "BrittanyLF.hs" "haskell" + -- let range = Range (Position 1 0) (Position 2 22) + -- opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing + -- ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts + -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) + -- "foo x y = do\n print x\n return 42\n"] + + -- it "formats a range with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do + -- doc <- openDoc "BrittanyCRLF.hs" "haskell" + -- let range = Range (Position 1 0) (Position 2 22) + -- opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing + -- ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts + -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) + -- "foo x y = do\n print x\n return 42\n"] describe "ormolu" $ do let formatLspConfig provider = @@ -107,6 +111,16 @@ spec = do GHC86 -> formatted _ -> liftIO $ docContent `shouldBe` unchangedOrmolu +formattedDocOrmolu :: T.Text +formattedDocOrmolu = + "module Format where\n\n\ + \foo :: Int -> Int\n\ + \foo 3 = 2\n\ + \foo x = x\n\n\ + \bar :: String -> IO String\n\ + \bar s = do\n\ + \ x <- return \"hello\"\n\ + \ return \"asdf\"\n" formattedDocTabSize2 :: T.Text formattedDocTabSize2 = diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 4867ae16fd..15f6a78cd3 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -23,33 +23,33 @@ module TestUtils ) where -import Control.Concurrent.STM +-- import Control.Concurrent.STM import Control.Monad import Data.Aeson.Types (typeMismatch) import Data.Default import Data.List (intercalate) import Data.Text (pack) -import Data.Typeable +-- import Data.Typeable import Data.Yaml -import qualified Data.Map as Map +-- import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types -- import Haskell.Ide.Engine.MonadTypes hiding (withProgress, withIndefiniteProgress) -import qualified Ide.Cradle as Bios +-- import qualified Ide.Cradle as Bios -- import qualified Ide.Engine.Config as Config import System.Directory import System.Environment import System.FilePath import qualified System.Log.Logger as L -import Test.Hspec +-- import Test.Hspec import Test.Hspec.Runner import Test.Hspec.Core.Formatters import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal -- import qualified Haskell.Ide.Engine.PluginApi as HIE (BiosOptions, defaultOptions) -import HIE.Bios.Types +-- import HIE.Bios.Types -- testOptions :: HIE.BiosOptions -- testOptions = HIE.defaultOptions { cradleOptsVerbosity = Verbose } From 6db01f6f055d6561ced96d4c5cc1722dcc455c90 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 Feb 2020 22:17:15 +0000 Subject: [PATCH 4/5] Remove unused build-depends entries --- haskell-language-server.cabal | 59 +++++------------------------------ 1 file changed, 8 insertions(+), 51 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 52bfe13ba7..209bc6551a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -38,46 +38,27 @@ library build-depends: base >=4.7 && <5 , aeson - , async , binary - , bytestring , Cabal , cabal-helper >= 1.0 , containers - , data-default , deepseq , directory - , extra , filepath - , fuzzy , ghc , ghcide >= 0.1 , gitrev - , haddock-library , hashable , haskell-lsp == 0.19.* - , haskell-lsp-types == 0.19.* - , hie-bios + , hie-bios >= 0.4 , hslogger - , mtl - , network-uri , optparse-simple - , prettyprinter - , prettyprinter-ansi-terminal - , prettyprinter-ansi-terminal , process , regex-tdfa >= 1.3.1.0 - , rope-utf16-splay - , safe-exceptions , shake >= 0.17.5 - , sorted-list - , stm - , syb , text - , time , transformers , unordered-containers - , utf8-string if impl(ghc >= 8.6) build-depends: ormolu >= 0.0.3.1 @@ -117,16 +98,21 @@ executable haskell-language-server base >=4.7 && <5 , containers , data-default - , directory , extra , filepath + -------------------------------------------------------------- + -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas + -- which require depending on ghc. So the tests need to depend + -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a + -- better solution can be found, but this is a quick solution + -- which works for now. , ghc + -------------------------------------------------------------- , ghc-paths , ghcide , gitrev , haskell-lsp , hie-bios >= 0.4 - , hslogger , haskell-language-server , optparse-applicative , shake >= 0.17.5 @@ -162,14 +148,11 @@ executable haskell-language-server-wrapper , filepath , gitrev , ghc - , ghcide , ghc-paths - , haskell-lsp , hie-bios , haskell-language-server , optparse-applicative , process - , text default-language: Haskell2010 @@ -183,38 +166,12 @@ test-suite func-test build-depends: base >=4.7 && <5 - , haskell-language-server , aeson - , base - , bytestring - , containers , data-default - , directory - , extra - , filepath - -------------------------------------------------------------- - -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas - -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a - -- better solution can be found, but this is a quick solution - -- which works for now. - , ghc - -------------------------------------------------------------- - , ghcide - , ghc-typelits-knownnat - , haddock-library - , haskell-lsp - , haskell-lsp-types , hls-test-utils - , lens , lsp-test >= 0.10.0.0 - , parser-combinators - , QuickCheck - , quickcheck-instances - , rope-utf16-splay , text , hspec - , hspec-core other-modules: -- CompletionSpec -- , CommandSpec From 5e9684b7dbba2d606c5424a81c452312380d9bcd Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 7 Feb 2020 18:18:33 +0000 Subject: [PATCH 5/5] Clean up a bit based on @fendor review --- .gitignore | 7 ++ test/exe/Main.hs | 141 --------------------------------------- test/testdata/stack.yaml | 7 -- 3 files changed, 7 insertions(+), 148 deletions(-) delete mode 100644 test/exe/Main.hs delete mode 100644 test/testdata/stack.yaml diff --git a/.gitignore b/.gitignore index 76fa65c3be..391cea0db2 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,10 @@ shake.yaml.lock .vscode /test-logs/ + +# stack 2.1 stack.yaml lock files +stack*.yaml.lock +shake.yaml.lock + +# ignore hie.yaml's for testdata +test/**/*.yaml diff --git a/test/exe/Main.hs b/test/exe/Main.hs deleted file mode 100644 index 3c6eeeb870..0000000000 --- a/test/exe/Main.hs +++ /dev/null @@ -1,141 +0,0 @@ --- Copyright (c) 2019-2020 The DAML and HLS Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Exception (catch) -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Data.Char (toLower) -import Data.Foldable -import Data.List -import Data.Rope.UTF16 (Rope) -import qualified Data.Rope.UTF16 as Rope -import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) -import Development.IDE.GHC.Util -import qualified Data.Text as T -import Development.IDE.Spans.Common --- import Development.IDE.Test --- import Development.IDE.Test.Runfiles -import Development.IDE.Types.Location -import qualified Language.Haskell.LSP.Test as LSPTest -import Language.Haskell.LSP.Test hiding (openDoc') -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.VFS (applyChange) -import System.Environment.Blank (setEnv) -import System.FilePath -import System.IO.Extra -import System.Directory -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Data.Maybe - -import TestUtils - --- --------------------------------------------------------------------- - -main :: IO () -main = defaultMain $ testGroup "HLS" - [ testSession "open close" $ do - doc <- openDoc' "Testing.hs" "haskell" "" - void (message :: Session WorkDoneProgressCreateRequest) - void (message :: Session WorkDoneProgressBeginNotification) - closeDoc doc - void (message :: Session WorkDoneProgressEndNotification) - ] - ----------------------------------------------------------------------- --- Utils - - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -{- -testSessionWait :: String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction -pickActionWithTitle title actions = head - [ action - | CACodeAction action@CodeAction{ _title = actionTitle } <- actions - , title == actionTitle ] --} - -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = withTempDir $ \dir -> do - let ghcideExe = hieCommand - - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ dir ++ "/Data" - - let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir] - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } - runSessionWithConfig conf cmd lspTestCaps dir s - where - conf = defaultConfig - -- If you uncomment this you can see all logging - -- which can be quite useful for debugging. - -- { logStdErr = True, logColor = False } - -- If you really want to, you can also see all messages - -- { logMessages = True, logColor = False } - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - openDoc' path "haskell" source - -findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions - , actionTitle == expectedTitle ] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions - ] - ++ "is not a superset of " - ++ show expectedTitles - liftIO $ case matches of - Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) - -findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction -findCodeAction doc range t = head <$> findCodeActions doc range [t] - --- | Wrapper around 'LSPTest.openDoc'' that sends file creation events -openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier -openDoc' fp name contents = do - res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents - sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated]) - return res diff --git a/test/testdata/stack.yaml b/test/testdata/stack.yaml deleted file mode 100644 index 3644ccf5de..0000000000 --- a/test/testdata/stack.yaml +++ /dev/null @@ -1,7 +0,0 @@ -# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils. IT WILL BE OVERWRITTEN ON EVERY TEST RUN -resolver: lts-14.22 -packages: -- '.' -extra-deps: [] -flags: {} -extra-package-dbs: []