diff --git a/.gitignore b/.gitignore index 831a43a763..391cea0db2 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,11 @@ stack*.yaml.lock 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/haskell-language-server.cabal b/haskell-language-server.cabal index 4ca1680ff3..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,24 +148,55 @@ 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 -test-suite test +test-suite func-test type: exitcode-stdio-1.0 - main-is: Spec.hs + default-language: Haskell2010 + 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 + , aeson + , data-default + , hls-test-utils + , lsp-test >= 0.10.0.0 + , text + , hspec 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 + test/functional ghc-options: -Wall -Wredundant-constraints @@ -187,7 +204,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/functional/FormatSpec.hs b/test/functional/FormatSpec.hs new file mode 100644 index 0000000000..fe7b69db30 --- /dev/null +++ b/test/functional/FormatSpec.hs @@ -0,0 +1,221 @@ +{-# 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` 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" $ 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 = + 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 + +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 = + "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/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 new file mode 100644 index 0000000000..15f6a78cd3 --- /dev/null +++ b/test/utils/TestUtils.hs @@ -0,0 +1,413 @@ +{-# 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 +hieCommand = "haskell-language-server --lsp" + +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 + }