From 66805059317bcb3712e056aac40055d12f2b88aa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 27 Jul 2020 20:39:34 +0100 Subject: [PATCH 01/23] Fix rendering of extension flags for Ormolu --- haskell-language-server.cabal | 1 + src/Ide/Plugin/Ormolu.hs | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index dbbfef3129..a350c7d5f5 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -71,6 +71,7 @@ library , filepath , floskell == 0.10.* , ghc + , ghc-boot-th , ghcide >= 0.1 , gitrev , hashable diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index aa337fbc8e..188a8bf00d 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -19,6 +19,7 @@ import Development.IDE.Types.Location import qualified DynFlags as D import qualified EnumSet as S import GHC +import GHC.LanguageExtensions.Type import Ide.Types import Ide.PluginUtils import Ide.Plugin.Formatter @@ -46,7 +47,7 @@ provider _lf ideState typ contents fp _ = do let p = D.sPgm_F $ D.settings df in if null p then [] else ["-pgmF=" <> p] pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df - ex = map (("-X" <>) . show) $ S.toList $ D.extensionFlags df + ex = map showExtension $ S.toList $ D.extensionFlags df in return $ map DynOption $ pp <> pm <> ex @@ -75,3 +76,7 @@ provider _lf ideState typ contents fp _ = do ret (Left err) = Left (responseError (T.pack $ "ormoluCmd: " ++ show err) ) ret (Right new) = Right (makeDiffTextEdit contents new) + +showExtension :: Extension -> String +showExtension Cpp = "-XCPP" +showExtension other = "-X" ++ show other From 1e743a0d91228e59c07b6cdab35cacc6c7106551 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 27 Jul 2020 20:52:53 +0100 Subject: [PATCH 02/23] Ormolu already handles file pragmas ms_hspp_opts contains the LANGUAGE and OPTIONS pragmas what we want here is the cabal/stack options instead --- src/Ide/Plugin/Ormolu.hs | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 188a8bf00d..3421bf2f19 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} module Ide.Plugin.Ormolu ( @@ -12,20 +11,24 @@ module Ide.Plugin.Ormolu where import Control.Exception -import qualified Data.Text as T +import qualified Data.Text as T import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession)) +import Development.IDE.Core.Shake (use) +import Development.IDE.GHC.Util (hscEnv) import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import qualified DynFlags as D -import qualified EnumSet as S +import qualified DynFlags as D +import qualified EnumSet as S import GHC import GHC.LanguageExtensions.Type -import Ide.Types -import Ide.PluginUtils +import GhcPlugins (HscEnv (hsc_dflags)) import Ide.Plugin.Formatter +import Ide.PluginUtils +import Ide.Types import Language.Haskell.LSP.Types import Ormolu -import Text.Regex.TDFA.Text() +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -39,10 +42,9 @@ descriptor plId = (defaultPluginDescriptor plId) provider :: FormattingProvider IO provider _lf ideState typ contents fp _ = do let - fromDyn :: ParsedModule -> IO [DynOption] - fromDyn pmod = + fromDyn :: DynFlags -> IO [DynOption] + fromDyn df = let - df = ms_hspp_opts $ pm_mod_summary pmod pp = let p = D.sPgm_F $ D.settings df in if null p then [] else ["-pgmF=" <> p] @@ -51,10 +53,11 @@ provider _lf ideState typ contents fp _ = do in return $ map DynOption $ pp <> pm <> ex - m_parsed <- runAction "Ormolu" ideState $ getParsedModule fp - fileOpts <- case m_parsed of + ghc <- runAction "Ormolu" ideState $ use GhcSession fp + let df = hsc_dflags . hscEnv <$> ghc + fileOpts <- case df of Nothing -> return [] - Just pm -> fromDyn pm + Just df -> fromDyn df let fullRegion = RegionIndices Nothing Nothing @@ -78,5 +81,5 @@ provider _lf ideState typ contents fp _ = do ret (Right new) = Right (makeDiffTextEdit contents new) showExtension :: Extension -> String -showExtension Cpp = "-XCPP" +showExtension Cpp = "-XCPP" showExtension other = "-X" ++ show other From 158a279cb878cc09fd7e943474d70eeb7ad63756 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 27 Jul 2020 20:55:10 +0100 Subject: [PATCH 03/23] Progress reporting Because why not? --- src/Ide/Plugin/Ormolu.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 3421bf2f19..8a88d834ff 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -26,8 +26,11 @@ import GhcPlugins (HscEnv (hsc_dflags)) import Ide.Plugin.Formatter import Ide.PluginUtils import Ide.Types +import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), + ProgressCancellable (Cancellable)) import Language.Haskell.LSP.Types import Ormolu +import System.FilePath (takeFileName) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -40,7 +43,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- provider :: FormattingProvider IO -provider _lf ideState typ contents fp _ = do +provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do let fromDyn :: DynFlags -> IO [DynOption] fromDyn df = @@ -75,6 +78,7 @@ provider _lf ideState typ contents fp _ = do in ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) where + title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) ret (Left err) = Left (responseError (T.pack $ "ormoluCmd: " ++ show err) ) From cee42324f833dc4c6ac0a4508b3d8ffcc3a2b4b5 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Sun, 14 Jun 2020 13:30:08 +0100 Subject: [PATCH 04/23] Add fourmolu plugin --- exe/Main.hs | 2 + haskell-language-server.cabal | 2 + src/Ide/Plugin/Fourmolu.hs | 78 +++++++++++++++++++++++++++++++++++ src/Ide/Plugin/Ormolu.hs | 3 +- 4 files changed, 84 insertions(+), 1 deletion(-) create mode 100644 src/Ide/Plugin/Fourmolu.hs diff --git a/exe/Main.hs b/exe/Main.hs index 081f261cac..5cb9bf223f 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -68,6 +68,7 @@ import Ide.Plugin.Example2 as Example2 import Ide.Plugin.GhcIde as GhcIde import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Ormolu as Ormolu +import Ide.Plugin.Fourmolu as Fourmolu import Ide.Plugin.StylishHaskell as StylishHaskell #if AGPL import Ide.Plugin.Brittany as Brittany @@ -103,6 +104,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins , Floskell.descriptor "floskell" -- , genericDescriptor "generic" -- , ghcmodDescriptor "ghcmod" + , Fourmolu.descriptor "fourmolu" , Ormolu.descriptor "ormolu" , StylishHaskell.descriptor "stylish-haskell" #if AGPL diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 74f850bcc7..22512d3c3d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -44,6 +44,7 @@ library Ide.Plugin.Eval Ide.Plugin.Example Ide.Plugin.Example2 + Ide.Plugin.Fourmolu Ide.Plugin.GhcIde Ide.Plugin.Ormolu Ide.Plugin.Pragmas @@ -70,6 +71,7 @@ library , extra , filepath , floskell == 0.10.* + , fourmolu ^>= 0.0.6.0 , ghc , ghcide >= 0.1 , gitrev diff --git a/src/Ide/Plugin/Fourmolu.hs b/src/Ide/Plugin/Fourmolu.hs new file mode 100644 index 0000000000..2f20011cae --- /dev/null +++ b/src/Ide/Plugin/Fourmolu.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Fourmolu + ( + descriptor + , provider + ) +where + +import Control.Exception +import qualified Data.Text as T +import Development.IDE.Core.Rules +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import qualified DynFlags as D +import qualified EnumSet as S +import GHC +import Ide.Types +import Ide.PluginUtils +import Ide.Plugin.Formatter +import Language.Haskell.LSP.Types +import "fourmolu" Ormolu +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- --------------------------------------------------------------------- + +provider :: FormattingProvider IO +provider _lf ideState typ contents fp _ = do + let + fromDyn :: ParsedModule -> IO [DynOption] + fromDyn pmod = + let + df = ms_hspp_opts $ pm_mod_summary pmod + pp = + let p = D.sPgm_F $ D.settings df + in if null p then [] else ["-pgmF=" <> p] + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df + ex = map (("-X" <>) . show) $ S.toList $ D.extensionFlags df + in + return $ map DynOption $ pp <> pm <> ex + + m_parsed <- runAction "Fourmolu" ideState $ getParsedModule fp + fileOpts <- case m_parsed of + Nothing -> return [] + Just pm -> fromDyn pm + + let + fullRegion = RegionIndices Nothing Nothing + rangeRegion s e = RegionIndices (Just s) (Just e) + mkConf o region = defaultConfig { cfgDynOptions = o, cfgRegion = region } + fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) + fmt cont conf = + try @OrmoluException (ormolu conf (fromNormalizedFilePath fp) $ T.unpack cont) + + case typ of + FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) + FormatRange r -> + let + Range (Position sl _) (Position el _) = normalize r + in + ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) + where + ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) + ret (Left err) = Left + (responseError (T.pack $ "fourmoluCmd: " ++ show err) ) + ret (Right new) = Right (makeDiffTextEdit contents new) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index aa337fbc8e..840d07994d 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,7 +24,7 @@ import Ide.Types import Ide.PluginUtils import Ide.Plugin.Formatter import Language.Haskell.LSP.Types -import Ormolu +import "ormolu" Ormolu import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- From 4c76137fffde614d25e7371db5da387231257177 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Sun, 14 Jun 2020 15:06:25 +0100 Subject: [PATCH 05/23] Add test for fourmolu --- test/functional/Format.hs | 12 ++++++++++++ test/testdata/Format.fourmolu.hs | 12 ++++++++++++ 2 files changed, 24 insertions(+) create mode 100644 test/testdata/Format.fourmolu.hs diff --git a/test/functional/Format.hs b/test/functional/Format.hs index f1f8e7c291..2285c4d19a 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -36,6 +36,7 @@ tests = testGroup "format document" [ , brittanyTests #endif , ormoluTests + , fourmoluTests ] rangeTests :: TestTree @@ -156,6 +157,17 @@ ormoluTests = testGroup "ormolu" [ GHC86 -> "formatted" _ -> "unchanged" +fourmoluTests :: TestTree +fourmoluTests = testGroup "fourmolu" [ + goldenVsStringDiff "formats correctly" goldenGitDiff ("test/testdata/Format.fourmolu.hs") $ runSession hieCommand fullCaps "test/testdata" $ do + let formatLspConfig provider = + object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 4 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + formatLspConfig :: Value -> Value formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] diff --git a/test/testdata/Format.fourmolu.hs b/test/testdata/Format.fourmolu.hs new file mode 100644 index 0000000000..3e5981a4e9 --- /dev/null +++ b/test/testdata/Format.fourmolu.hs @@ -0,0 +1,12 @@ +module Format where + +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz {a :: Int, b :: String} + From 825789cebeecf7de449e6c6e28eb72154482c68a Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 18 Jun 2020 17:44:23 +0100 Subject: [PATCH 06/23] Add fourmolu to stack extra-deps --- ghcide | 2 +- stack-8.10.1.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.2.yaml | 1 + stack-8.8.3.yaml | 1 + stack.yaml | 1 + 7 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ghcide b/ghcide index 7e895cfa53..cc09b6d4cf 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 7e895cfa53260b41996df707baec496a8f2c75dc +Subproject commit cc09b6d4cf03efa645c682347c62850c2291be25 diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index bc51cd64b9..4e92b2b0a1 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -13,6 +13,7 @@ extra-deps: - cabal-plan-0.7.0.0 - clock-0.7.2 - floskell-0.10.3 +- fourmolu-0.0.6.0 - ghc-exactprint-0.6.3 - lens-4.19.1 - lsp-test-0.11.0.3 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 082611ddb4..8cc45803af 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -20,6 +20,7 @@ extra-deps: # - ghcide-0.1.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.0.6.0 - fuzzy-0.1.0.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.2 # for HaRe diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 771d6f3882..652198e18c 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -17,6 +17,7 @@ extra-deps: - clock-0.7.2 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.0.6.0 - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 99e5c20f3b..27065578e9 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -16,6 +16,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.0.6.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-lib-parser-8.10.1.20200523 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index b972a17e4e..da31358d95 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -15,6 +15,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.0.6.0 # - ghcide-0.1.0 - haskell-src-exts-1.21.1 - hie-bios-0.6.1 diff --git a/stack.yaml b/stack.yaml index 71c2bd1d51..b0c79e9f2f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,7 @@ extra-deps: - clock-0.7.2 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.0.6.0 - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 From 72df5ff90352233e13dbaa8fb8437acaab48b817 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 2 Jul 2020 11:47:46 +0100 Subject: [PATCH 07/23] Update Fourmolu to 0.1 --- cabal.project | 5 +++++ haskell-language-server.cabal | 2 +- stack-8.10.1.yaml | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.2.yaml | 2 +- stack-8.8.3.yaml | 2 +- stack.yaml | 2 +- 8 files changed, 12 insertions(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index c063a3fc3e..d66efdddfe 100644 --- a/cabal.project +++ b/cabal.project @@ -15,3 +15,8 @@ package ghcide write-ghc-environment-files: never index-state: 2020-07-27T12:40:45Z + +allow-newer: + floskell:aeson + HsYAML-aeson:aeson + stylish-haskell:aeson diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 22512d3c3d..d5af4ac3f5 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -71,7 +71,7 @@ library , extra , filepath , floskell == 0.10.* - , fourmolu ^>= 0.0.6.0 + , fourmolu ^>= 0.1.0.0 , ghc , ghcide >= 0.1 , gitrev diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 4e92b2b0a1..40cca07500 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -13,7 +13,7 @@ extra-deps: - cabal-plan-0.7.0.0 - clock-0.7.2 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 - ghc-exactprint-0.6.3 - lens-4.19.1 - lsp-test-0.11.0.3 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 8cc45803af..2c5f4a0e2c 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -20,7 +20,7 @@ extra-deps: # - ghcide-0.1.0 - extra-1.7.3 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 - fuzzy-0.1.0.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.2 # for HaRe diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 652198e18c..31af05e0c3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -17,7 +17,7 @@ extra-deps: - clock-0.7.2 - extra-1.7.3 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 27065578e9..0e39a2234f 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -16,7 +16,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-lib-parser-8.10.1.20200523 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index da31358d95..3541d5face 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -15,7 +15,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 # - ghcide-0.1.0 - haskell-src-exts-1.21.1 - hie-bios-0.6.1 diff --git a/stack.yaml b/stack.yaml index b0c79e9f2f..1b4710c3e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ extra-deps: - clock-0.7.2 - extra-1.7.3 - floskell-0.10.3 -- fourmolu-0.0.6.0 +- fourmolu-0.1.0.0 - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 From 1ccbf34ac6bacb9bf6e1202ef88f903d151a0b42 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 2 Jul 2020 11:50:52 +0100 Subject: [PATCH 08/23] Load Fourmolu config files --- src/Ide/Plugin/Fourmolu.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Ide/Plugin/Fourmolu.hs b/src/Ide/Plugin/Fourmolu.hs index 2f20011cae..613ea3c730 100644 --- a/src/Ide/Plugin/Fourmolu.hs +++ b/src/Ide/Plugin/Fourmolu.hs @@ -59,18 +59,26 @@ provider _lf ideState typ contents fp _ = do let fullRegion = RegionIndices Nothing Nothing rangeRegion s e = RegionIndices (Just s) (Just e) - mkConf o region = defaultConfig { cfgDynOptions = o, cfgRegion = region } + mkConf o region = do + printerOpts <- loadConfigFile True (Just fp') defaultPrinterOpts + return $ defaultConfig + { cfgDynOptions = o + , cfgRegion = region + , cfgDebug = True + , cfgPrinterOpts = printerOpts + } fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) fmt cont conf = - try @OrmoluException (ormolu conf (fromNormalizedFilePath fp) $ T.unpack cont) + try @OrmoluException (ormolu conf fp' $ T.unpack cont) + fp' = fromNormalizedFilePath fp case typ of - FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) + FormatText -> ret <$> (fmt contents =<< mkConf fileOpts fullRegion) FormatRange r -> let Range (Position sl _) (Position el _) = normalize r in - ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) + ret <$> (fmt contents =<< mkConf fileOpts (rangeRegion sl el)) where ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) ret (Left err) = Left From 114aa8ae62137ff4bb80a413e902050d8ec3efda Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 2 Jul 2020 11:53:58 +0100 Subject: [PATCH 09/23] Fix for CPP Name doesn't much Show instance. --- src/Ide/Plugin/Fourmolu.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Ide/Plugin/Fourmolu.hs b/src/Ide/Plugin/Fourmolu.hs index 613ea3c730..6237e4833d 100644 --- a/src/Ide/Plugin/Fourmolu.hs +++ b/src/Ide/Plugin/Fourmolu.hs @@ -47,7 +47,10 @@ provider _lf ideState typ contents fp _ = do let p = D.sPgm_F $ D.settings df in if null p then [] else ["-pgmF=" <> p] pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df - ex = map (("-X" <>) . show) $ S.toList $ D.extensionFlags df + ex = map (("-X" <>) . show') $ S.toList $ D.extensionFlags df + show' x = case show x of + "Cpp" -> "CPP" + s -> s in return $ map DynOption $ pp <> pm <> ex From 605d19a7b9d61ec7ade5e3ed733d7f2cf295e52b Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 29 Jul 2020 13:59:30 +0100 Subject: [PATCH 10/23] Fix haddock parse error in install.hs Seeing as, since #209, the README suggests globally enabling `-haddock`, it's rather unfortunate for that not to work with HLS' own installation script... --- install.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/install.hs b/install.hs index c836759786..b89c7d053a 100755 --- a/install.hs +++ b/install.hs @@ -10,8 +10,8 @@ build-depends: , hls-install -} -- call as: --- * `cabal v2-run install.hs --project-file install/shake.project ` --- * `stack install.hs ` +-- * `cabal v2-run install.hs --project-file install/shake.project ` +-- * `stack install.hs ` -- TODO: set `shake.project` in cabal-config above, when supported -- (see https://github.com/haskell/cabal/issues/6353) From 3a6874d72602b1b6c703d3df89f688a02e3b957f Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 17:09:07 +0530 Subject: [PATCH 11/23] Add more tests for checking formatting --- test/functional/Format.hs | 4 ++-- test/testdata/Format.brittany.formatted.hs | 4 ++++ test/testdata/Format.brittany_post_floskell.formatted.hs | 4 ++++ test/testdata/Format.floskell.formatted.hs | 4 ++++ test/testdata/Format.formatted_document.hs | 6 +++++- test/testdata/Format.formatted_document_with_tabsize.hs | 6 +++++- test/testdata/Format.formatted_range.hs | 5 ++++- test/testdata/Format.formatted_range_with_tabsize.hs | 7 +++++-- test/testdata/Format.hs | 4 ++++ test/testdata/Format.ormolu.formatted.hs | 6 +++++- 10 files changed, 42 insertions(+), 8 deletions(-) diff --git a/test/functional/Format.hs b/test/functional/Format.hs index f1f8e7c291..6dca7f07e5 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -42,11 +42,11 @@ rangeTests :: TestTree rangeTests = testGroup "format range" [ goldenVsStringDiff "works" goldenGitDiff "test/testdata/Format.formatted_range.hs" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True) (Range (Position 5 0) (Position 7 10)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/Format.formatted_range_with_tabsize.hs" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 5 True) (Range (Position 4 0) (Position 7 19)) + formatRange doc (FormattingOptions 5 True) (Range (Position 8 0) (Position 11 19)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] diff --git a/test/testdata/Format.brittany.formatted.hs b/test/testdata/Format.brittany.formatted.hs index d0bde680f2..d3da590142 100644 --- a/test/testdata/Format.brittany.formatted.hs +++ b/test/testdata/Format.brittany.formatted.hs @@ -1,4 +1,8 @@ module Format where +import Data.List + +import Prelude +import Data.Int foo :: Int -> Int foo 3 = 2 foo x = x diff --git a/test/testdata/Format.brittany_post_floskell.formatted.hs b/test/testdata/Format.brittany_post_floskell.formatted.hs index 208e754e24..02de9c673d 100644 --- a/test/testdata/Format.brittany_post_floskell.formatted.hs +++ b/test/testdata/Format.brittany_post_floskell.formatted.hs @@ -1,5 +1,9 @@ module Format where +import Data.List +import Prelude +import Data.Int + foo :: Int -> Int foo 3 = 2 foo x = x diff --git a/test/testdata/Format.floskell.formatted.hs b/test/testdata/Format.floskell.formatted.hs index 208e754e24..02de9c673d 100644 --- a/test/testdata/Format.floskell.formatted.hs +++ b/test/testdata/Format.floskell.formatted.hs @@ -1,5 +1,9 @@ module Format where +import Data.List +import Prelude +import Data.Int + foo :: Int -> Int foo 3 = 2 foo x = x diff --git a/test/testdata/Format.formatted_document.hs b/test/testdata/Format.formatted_document.hs index ec1ce57379..ac43b2d285 100644 --- a/test/testdata/Format.formatted_document.hs +++ b/test/testdata/Format.formatted_document.hs @@ -1,12 +1,16 @@ module Format where +import Data.Int +import Data.List +import Prelude + foo :: Int -> Int foo 3 = 2 foo x = x + bar :: String -> IO String bar s = do x <- return "hello" return "asdf" data Baz = Baz {a :: Int, b :: String} - diff --git a/test/testdata/Format.formatted_document_with_tabsize.hs b/test/testdata/Format.formatted_document_with_tabsize.hs index ec1ce57379..ac43b2d285 100644 --- a/test/testdata/Format.formatted_document_with_tabsize.hs +++ b/test/testdata/Format.formatted_document_with_tabsize.hs @@ -1,12 +1,16 @@ module Format where +import Data.Int +import Data.List +import Prelude + foo :: Int -> Int foo 3 = 2 foo x = x + bar :: String -> IO String bar s = do x <- return "hello" return "asdf" data Baz = Baz {a :: Int, b :: String} - diff --git a/test/testdata/Format.formatted_range.hs b/test/testdata/Format.formatted_range.hs index 393584a9e4..920a07916e 100644 --- a/test/testdata/Format.formatted_range.hs +++ b/test/testdata/Format.formatted_range.hs @@ -1,5 +1,8 @@ -module Format where +module Format where +import Data.List +import Prelude +import Data.Int foo :: Int -> Int foo 3 = 2 foo x = x diff --git a/test/testdata/Format.formatted_range_with_tabsize.hs b/test/testdata/Format.formatted_range_with_tabsize.hs index 0a98f42e8f..33a942e43d 100644 --- a/test/testdata/Format.formatted_range_with_tabsize.hs +++ b/test/testdata/Format.formatted_range_with_tabsize.hs @@ -1,12 +1,15 @@ module Format where +import Data.List + +import Prelude +import Data.Int foo :: Int -> Int foo 3 = 2 -foo x = x +foo x = x bar :: String -> IO String bar s = do x <- return "hello" return "asdf" - data Baz = Baz { a :: Int, b :: String } diff --git a/test/testdata/Format.hs b/test/testdata/Format.hs index d4682acaa2..b8bb374e2e 100644 --- a/test/testdata/Format.hs +++ b/test/testdata/Format.hs @@ -1,4 +1,8 @@ module Format where +import Data.List + +import Prelude +import Data.Int foo :: Int -> Int foo 3 = 2 foo x = x diff --git a/test/testdata/Format.ormolu.formatted.hs b/test/testdata/Format.ormolu.formatted.hs index ec1ce57379..ac43b2d285 100644 --- a/test/testdata/Format.ormolu.formatted.hs +++ b/test/testdata/Format.ormolu.formatted.hs @@ -1,12 +1,16 @@ module Format where +import Data.Int +import Data.List +import Prelude + foo :: Int -> Int foo 3 = 2 foo x = x + bar :: String -> IO String bar s = do x <- return "hello" return "asdf" data Baz = Baz {a :: Int, b :: String} - From 96d42f37238baa463c838c6e9bee6c1b6c8ff52a Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 18:58:01 +0530 Subject: [PATCH 12/23] Add more tests for ormolu --- test/functional/Format.hs | 11 ++++++++--- test/testdata/Format2.hs | 5 +++++ test/testdata/Format2.ormolu.formatted.hs | 5 +++++ test/testdata/Format2.ormolu.unchanged.hs | 5 +++++ 4 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 test/testdata/Format2.hs create mode 100644 test/testdata/Format2.ormolu.formatted.hs create mode 100644 test/testdata/Format2.ormolu.unchanged.hs diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 6dca7f07e5..0b63320447 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -143,13 +143,18 @@ brittanyTests = testGroup "brittany" [ ] ormoluTests :: TestTree -ormoluTests = testGroup "ormolu" [ - goldenVsStringDiff "formats correctly" goldenGitDiff ("test/testdata/Format.ormolu." ++ ormoluGoldenSuffix ++ ".hs") $ runSession hieCommand fullCaps "test/testdata" $ do +ormoluTests = testGroup "ormolu" + [ goldenVsStringDiff "formats correctly" goldenGitDiff ("test/testdata/Format.ormolu." ++ ormoluGoldenSuffix ++ ".hs") $ runSession hieCommand fullCaps "test/testdata" $ do sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 2 True) BS.fromStrict . T.encodeUtf8 <$> documentContents doc - ] + , goldenVsStringDiff "sorts imports correctly" goldenGitDiff ("test/testdata/Format2.ormolu." ++ ormoluGoldenSuffix ++ ".hs") $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format2.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] where ormoluGoldenSuffix = case ghcVersion of GHC88 -> "formatted" diff --git a/test/testdata/Format2.hs b/test/testdata/Format2.hs new file mode 100644 index 0000000000..bb011b5638 --- /dev/null +++ b/test/testdata/Format2.hs @@ -0,0 +1,5 @@ +import Data.Char +import Data.Either +import Data.Int +import Data.Data +import Data.Bool diff --git a/test/testdata/Format2.ormolu.formatted.hs b/test/testdata/Format2.ormolu.formatted.hs new file mode 100644 index 0000000000..b3d867e700 --- /dev/null +++ b/test/testdata/Format2.ormolu.formatted.hs @@ -0,0 +1,5 @@ +import Data.Bool +import Data.Char +import Data.Data +import Data.Either +import Data.Int diff --git a/test/testdata/Format2.ormolu.unchanged.hs b/test/testdata/Format2.ormolu.unchanged.hs new file mode 100644 index 0000000000..bb011b5638 --- /dev/null +++ b/test/testdata/Format2.ormolu.unchanged.hs @@ -0,0 +1,5 @@ +import Data.Char +import Data.Either +import Data.Int +import Data.Data +import Data.Bool From d4371fd443a388ad4f77c7208904e6e2ce7953d7 Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 17:15:26 +0530 Subject: [PATCH 13/23] Fix bug in diffOperationToTextEdit The original lineno extracted from the Addition DiffOperation needs to be increased by 1. --- src/Ide/PluginUtils.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs index 41a295b639..d43f776f5d 100644 --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -67,12 +67,12 @@ diffTextEdit fText f2Text withDeletions = J.List r (J.Position el 0) diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt - -- fm has a range wrt to the changed file, which starts in the current file at l - -- So the range has to be shifted to start at l + -- fm has a range wrt to the changed file, which starts in the current file at l + 1 + -- So the range has to be shifted to start at l + 1 where range = J.Range (J.Position (l' - 1) 0) (J.Position (l' - 1) 0) - l' = max l sl -- Needed to add at the end of the file + l' = max (l + 1) sl -- Needed to add at the end of the file sl = fst $ lrNumbers fm nt = T.pack $ unlines $ lrContents fm @@ -109,4 +109,4 @@ clientSupportsDocumentChanges caps = WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps mDc in - fromMaybe False supports \ No newline at end of file + fromMaybe False supports From 75f0d6bef2b8cb347a61100692075648f261a876 Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 18:35:48 +0530 Subject: [PATCH 14/23] Fix another bug in diffOperationToTextEdit We were taking max of l and sl but the position of an insertion in the newer document is irrelevant since the edits will be applied from bottom to top. --- src/Ide/PluginUtils.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs index d43f776f5d..442cc770f7 100644 --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -70,10 +70,8 @@ diffTextEdit fText f2Text withDeletions = J.List r -- fm has a range wrt to the changed file, which starts in the current file at l + 1 -- So the range has to be shifted to start at l + 1 where - range = J.Range (J.Position (l' - 1) 0) - (J.Position (l' - 1) 0) - l' = max (l + 1) sl -- Needed to add at the end of the file - sl = fst $ lrNumbers fm + range = J.Range (J.Position l 0) + (J.Position l 0) nt = T.pack $ unlines $ lrContents fm From 679e0ecc03325b8ff65348f2cfb02ae6c1fdc2b6 Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 17:19:33 +0530 Subject: [PATCH 15/23] Don't normalize in ormolu --- src/Ide/Plugin/Ormolu.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index aa337fbc8e..8fb571af40 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -65,11 +65,8 @@ provider _lf ideState typ contents fp _ = do case typ of FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) - FormatRange r -> - let - Range (Position sl _) (Position el _) = normalize r - in - ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) + FormatRange (Range (Position sl _) (Position el _)) -> + ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) where ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) ret (Left err) = Left From f51d4e8317229a9233c98274b503dd9d3422b6b7 Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 17:19:58 +0530 Subject: [PATCH 16/23] Ormolu RegionIndices should be 1-based --- src/Ide/Plugin/Ormolu.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 8fb571af40..8457ffd3a3 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -57,7 +57,7 @@ provider _lf ideState typ contents fp _ = do let fullRegion = RegionIndices Nothing Nothing - rangeRegion s e = RegionIndices (Just s) (Just e) + rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1) mkConf o region = defaultConfig { cfgDynOptions = o, cfgRegion = region } fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) fmt cont conf = From 7a8f51d7aa8769fa52770b5ac9009e959b612e72 Mon Sep 17 00:00:00 2001 From: shaurya gupta Date: Thu, 30 Jul 2020 20:25:25 +0530 Subject: [PATCH 17/23] Remove *.ormolu.unchanged formatting tests --- test/functional/Format.hs | 26 +++++++++-------------- test/testdata/Format.ormolu.unchanged.hs | 11 ---------- test/testdata/Format2.ormolu.unchanged.hs | 5 ----- 3 files changed, 10 insertions(+), 32 deletions(-) delete mode 100644 test/testdata/Format.ormolu.unchanged.hs delete mode 100644 test/testdata/Format2.ormolu.unchanged.hs diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 0b63320447..56e15689a7 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -144,23 +144,17 @@ brittanyTests = testGroup "brittany" [ ormoluTests :: TestTree ormoluTests = testGroup "ormolu" - [ goldenVsStringDiff "formats correctly" goldenGitDiff ("test/testdata/Format.ormolu." ++ ormoluGoldenSuffix ++ ".hs") $ runSession hieCommand fullCaps "test/testdata" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) - doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , goldenVsStringDiff "sorts imports correctly" goldenGitDiff ("test/testdata/Format2.ormolu." ++ ormoluGoldenSuffix ++ ".hs") $ runSession hieCommand fullCaps "test/testdata" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) - doc <- openDoc "Format2.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc + [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.ormolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.ormolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format2.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] - where - ormoluGoldenSuffix = case ghcVersion of - GHC88 -> "formatted" - GHC86 -> "formatted" - _ -> "unchanged" - formatLspConfig :: Value -> Value formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] diff --git a/test/testdata/Format.ormolu.unchanged.hs b/test/testdata/Format.ormolu.unchanged.hs deleted file mode 100644 index d4682acaa2..0000000000 --- a/test/testdata/Format.ormolu.unchanged.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Format where -foo :: Int -> Int -foo 3 = 2 -foo x = x -bar :: String -> IO String -bar s = do - x <- return "hello" - return "asdf" - -data Baz = Baz { a :: Int, b :: String } - diff --git a/test/testdata/Format2.ormolu.unchanged.hs b/test/testdata/Format2.ormolu.unchanged.hs deleted file mode 100644 index bb011b5638..0000000000 --- a/test/testdata/Format2.ormolu.unchanged.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Char -import Data.Either -import Data.Int -import Data.Data -import Data.Bool From 5dbf1531dd1a007481bb0670a4794d307a0531a1 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 31 Jul 2020 12:04:45 +0100 Subject: [PATCH 18/23] Remove redundant CircleCI steps Hoogle nor happy nor cabal-helper shouldn't be needed anymore --- .circleci/config.yml | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 0351375869..f8eb5c5ada 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -34,14 +34,6 @@ defaults: &defaults name: Stack setup command: stack -j 2 --stack-yaml=${STACK_FILE} setup - - run: - name: Install happy - command: stack --stack-yaml=${STACK_FILE} install happy - - - run: - name: Install Hoogle - command: stack -j 1 --stack-yaml=${STACK_FILE} install hoogle - - run: name: Build (we need the exe for tests) command: stack -j 1 --stack-yaml=${STACK_FILE} install @@ -57,20 +49,10 @@ defaults: &defaults path: ~/.local/bin destination: bin - - run: - name: Generate Hoogle database - command: if [ ! -d ~/.hoogle ]; then stack --stack-yaml=${STACK_FILE} exec hoogle generate; fi - - - run: - name: Clear cabal-helper cache - command: rm -fr ~/.cache/cabal-helper - - save_cache: key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }} paths: &cache_paths - ~/.stack - - ~/.cache - - ~/.hoogle - ~/build/.stack-work - ~/build/ghcide/.stack-work From 6b51c7c54b7d901dc0a3a55238a4b178951ea5c3 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 31 Jul 2020 14:48:56 +0100 Subject: [PATCH 19/23] Remove hspec-expectations Use @? and @?= instead, since they give much easier to read error messages. The `shouldX` functions all just end up dumping the Show instance of a HSpecFailure or what have you which is really hard to read. It also doesn't look like hspec-expectations is that actively maintained anymore --- haskell-language-server.cabal | 1 - test/functional/Command.hs | 7 +- test/functional/Completion.hs | 149 ++++++++++++----------- test/functional/Deferred.hs | 25 ++-- test/functional/Definition.hs | 11 +- test/functional/Diagnostic.hs | 31 +++-- test/functional/Format.hs | 6 + test/functional/FunctionalBadProject.hs | 17 ++- test/functional/FunctionalCodeAction.hs | 152 +++++++++++++----------- test/functional/FunctionalLiquid.hs | 71 +++++------ test/functional/Highlight.hs | 3 +- test/functional/Progress.hs | 25 ++-- test/functional/Reference.hs | 6 +- test/functional/Rename.hs | 5 +- test/functional/Symbol.hs | 14 +-- test/functional/TypeDefinition.hs | 46 ++++--- 16 files changed, 284 insertions(+), 285 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 74f850bcc7..6e168fa3da 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -243,7 +243,6 @@ test-suite func-test , haskell-language-server , haskell-lsp , haskell-lsp-types - , hspec-expectations , lens , lsp-test >= 0.11.0.3 , tasty diff --git a/test/functional/Command.hs b/test/functional/Command.hs index aaf91175ff..7106e83b6e 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -12,7 +12,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.ExpectedFailure (ignoreTestBecause) -import Test.Hspec.Expectations --TODO : Response Message no longer has 4 inputs @@ -24,8 +23,8 @@ tests = testGroup "commands" [ let List cmds = res ^. LSP.capabilities . executeCommandProvider . _Just . commands f x = (T.length (T.takeWhile isNumber x) >= 1) && (T.count ":" x >= 2) liftIO $ do - cmds `shouldSatisfy` all f - cmds `shouldNotSatisfy` null + all f cmds @? "All prefixed" + not (null cmds) @? "Commands aren't empty" , ignoreTestBecause "Broken: Plugin package doesn't exist" $ testCase "get de-prefixed" $ runSession hieCommand fullCaps "test/testdata/" $ do @@ -34,5 +33,5 @@ tests = testGroup "commands" [ (ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse let ResponseError _ msg _ = err -- We expect an error message about the dud arguments, but should pickup "add" and "package" - liftIO $ msg `shouldSatisfy` T.isInfixOf "while parsing args for add in plugin package" + liftIO $ (msg `T.isInfixOf` "while parsing args for add in plugin package") @? "Has error message" ] diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 4e3f46284d..cf7d1027c2 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -13,7 +13,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations --TODO: Fix tests, some structural changed hav been made @@ -29,17 +28,17 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 9) -- let item = head $ filter ((== "putStrLn") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "putStrLn" --- item ^. kind `shouldBe` Just CiFunction --- item ^. detail `shouldBe` Just "Prelude" +-- item ^. label @?= "putStrLn" +-- item ^. kind @?= Just CiFunction +-- item ^. detail @?= Just "Prelude" -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ do --- resolved ^. label `shouldBe` "putStrLn" --- resolved ^. kind `shouldBe` Just CiFunction --- resolved ^. detail `shouldBe` Just "String -> IO ()\nPrelude" --- resolved ^. insertTextFormat `shouldBe` Just Snippet --- resolved ^. insertText `shouldBe` Just "putStrLn ${1:String}" +-- resolved ^. label @?= "putStrLn" +-- resolved ^. kind @?= Just CiFunction +-- resolved ^. detail @?= Just "String -> IO ()\nPrelude" +-- resolved ^. insertTextFormat @?= Just Snippet +-- resolved ^. insertText @?= Just "putStrLn ${1:String}" -- , testCase "completes imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -51,9 +50,9 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 1 22) -- let item = head $ filter ((== "Maybe") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "Maybe" --- item ^. detail `shouldBe` Just "Data.Maybe" --- item ^. kind `shouldBe` Just CiModule +-- item ^. label @?= "Maybe" +-- item ^. detail @?= Just "Data.Maybe" +-- item ^. kind @?= Just CiModule -- , testCase "completes qualified imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -65,9 +64,9 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 1 19) -- let item = head $ filter ((== "Data.List") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "Data.List" --- item ^. detail `shouldBe` Just "Data.List" --- item ^. kind `shouldBe` Just CiModule +-- item ^. label @?= "Data.List" +-- item ^. detail @?= Just "Data.List" +-- item ^. kind @?= Just CiModule -- , testCase "completes language extensions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -79,8 +78,8 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 0 24) -- let item = head $ filter ((== "OverloadedStrings") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "OverloadedStrings" --- item ^. kind `shouldBe` Just CiKeyword +-- item ^. label @?= "OverloadedStrings" +-- item ^. kind @?= Just CiKeyword -- , testCase "completes pragmas" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -92,10 +91,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 0 4) -- let item = head $ filter ((== "LANGUAGE") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "LANGUAGE" --- item ^. kind `shouldBe` Just CiKeyword --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "LANGUAGE ${1:extension} #-}" +-- item ^. label @?= "LANGUAGE" +-- item ^. kind @?= Just CiKeyword +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "LANGUAGE ${1:extension} #-}" -- , testCase "completes pragmas no close" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -107,10 +106,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 0 4) -- let item = head $ filter ((== "LANGUAGE") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "LANGUAGE" --- item ^. kind `shouldBe` Just CiKeyword --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "LANGUAGE ${1:extension}" +-- item ^. label @?= "LANGUAGE" +-- item ^. kind @?= Just CiKeyword +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "LANGUAGE ${1:extension}" -- , testCase "completes options pragma" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -122,10 +121,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 0 4) -- let item = head $ filter ((== "OPTIONS_GHC") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "OPTIONS_GHC" --- item ^. kind `shouldBe` Just CiKeyword --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "OPTIONS_GHC -${1:option} #-}" +-- item ^. label @?= "OPTIONS_GHC" +-- item ^. kind @?= Just CiKeyword +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "OPTIONS_GHC -${1:option} #-}" -- -- ----------------------------------- @@ -140,10 +139,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 0 24) -- let item = head $ filter ((== "Wno-redundant-constraints") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "Wno-redundant-constraints" --- item ^. kind `shouldBe` Just CiKeyword --- item ^. insertTextFormat `shouldBe` Nothing --- item ^. insertText `shouldBe` Nothing +-- item ^. label @?= "Wno-redundant-constraints" +-- item ^. kind @?= Just CiKeyword +-- item ^. insertTextFormat @?= Nothing +-- item ^. insertText @?= Nothing -- -- ----------------------------------- @@ -164,10 +163,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 4) -- let item = head $ filter (\c -> c^.label == "accessor") compls -- liftIO $ do --- item ^. label `shouldBe` "accessor" --- item ^. kind `shouldBe` Just CiFunction --- item ^. detail `shouldBe` Just "Two -> Int\nDupRecFields" --- item ^. insertText `shouldBe` Just "accessor ${1:Two}" +-- item ^. label @?= "accessor" +-- item ^. kind @?= Just CiFunction +-- item ^. detail @?= Just "Two -> Int\nDupRecFields" +-- item ^. insertText @?= Just "accessor ${1:Two}" -- , testCase "have implicit foralls on basic polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -179,7 +178,7 @@ tests = testGroup "completions" [ -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ --- resolved ^. detail `shouldBe` Just "a -> a\nPrelude" +-- resolved ^. detail @?= Just "a -> a\nPrelude" -- , testCase "have implicit foralls with multiple type variables" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -191,7 +190,7 @@ tests = testGroup "completions" [ -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ --- resolved ^. detail `shouldBe` Just "(a -> b -> c) -> b -> a -> c\nPrelude" +-- resolved ^. detail @?= Just "(a -> b -> c) -> b -> a -> c\nPrelude" contextTests -- , snippetTests @@ -209,8 +208,8 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 14) -- let item = head $ filter ((== "Nothing") . (^. label)) compls -- liftIO $ do --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "Nothing" +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "Nothing" -- , testCase "work for polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -224,10 +223,10 @@ tests = testGroup "completions" [ -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ do --- resolved ^. label `shouldBe` "foldl" --- resolved ^. kind `shouldBe` Just CiFunction --- resolved ^. insertTextFormat `shouldBe` Just Snippet --- resolved ^. insertText `shouldBe` Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" +-- resolved ^. label @?= "foldl" +-- resolved ^. kind @?= Just CiFunction +-- resolved ^. insertTextFormat @?= Just Snippet +-- resolved ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" -- , testCase "work for complex types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -241,10 +240,10 @@ tests = testGroup "completions" [ -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ do --- resolved ^. label `shouldBe` "mapM" --- resolved ^. kind `shouldBe` Just CiFunction --- resolved ^. insertTextFormat `shouldBe` Just Snippet --- resolved ^. insertText `shouldBe` Just "mapM ${1:a -> m b} ${2:t a}" +-- resolved ^. label @?= "mapM" +-- resolved ^. kind @?= Just CiFunction +-- resolved ^. insertTextFormat @?= Just Snippet +-- resolved ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}" -- , testCase "work for infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -256,10 +255,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 18) -- let item = head $ filter ((== "filter") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "filter" --- item ^. kind `shouldBe` Just CiFunction --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "filter`" +-- item ^. label @?= "filter" +-- item ^. kind @?= Just CiFunction +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "filter`" -- , testCase "work for infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -271,10 +270,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 18) -- let item = head $ filter ((== "filter") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "filter" --- item ^. kind `shouldBe` Just CiFunction --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "filter" +-- item ^. label @?= "filter" +-- item ^. kind @?= Just CiFunction +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "filter" -- , testCase "work for qualified infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -286,10 +285,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 29) -- let item = head $ filter ((== "intersperse") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "intersperse" --- item ^. kind `shouldBe` Just CiFunction --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "intersperse`" +-- item ^. label @?= "intersperse" +-- item ^. kind @?= Just CiFunction +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "intersperse`" -- , testCase "work for qualified infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do -- doc <- openDoc "Completion.hs" "haskell" @@ -301,10 +300,10 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 29) -- let item = head $ filter ((== "intersperse") . (^. label)) compls -- liftIO $ do --- item ^. label `shouldBe` "intersperse" --- item ^. kind `shouldBe` Just CiFunction --- item ^. insertTextFormat `shouldBe` Just Snippet --- item ^. insertText `shouldBe` Just "intersperse" +-- item ^. label @?= "intersperse" +-- item ^. kind @?= Just CiFunction +-- item ^. insertTextFormat @?= Just Snippet +-- item ^. insertText @?= Just "intersperse" -- -- TODO : Fix compile issue in the test "Variable not in scope: object" -- , testCase "respects lsp configuration" $ runSession hieCommand fullCaps "test/testdata/completion" $ do @@ -332,18 +331,18 @@ tests = testGroup "completions" [ -- compls <- getCompletions doc (Position 5 11) -- let item = head $ filter ((== "foldl") . (^. label)) compls -- liftIO $ do - -- item ^. label `shouldBe` "foldl" - -- item ^. kind `shouldBe` Just CiFunction - -- item ^. insertTextFormat `shouldBe` Just PlainText - -- item ^. insertText `shouldBe` Nothing + -- item ^. label @?= "foldl" + -- item ^. kind @?= Just CiFunction + -- item ^. insertTextFormat @?= Just PlainText + -- item ^. insertText @?= Nothing -- resolvedRes <- request CompletionItemResolve item -- let Just (resolved :: CompletionItem) = resolvedRes ^. result -- liftIO $ do - -- resolved ^. label `shouldBe` "foldl" - -- resolved ^. kind `shouldBe` Just CiFunction - -- resolved ^. insertTextFormat `shouldBe` Just PlainText - -- resolved ^. insertText `shouldBe` Nothing + -- resolved ^. label @?= "foldl" + -- resolved ^. kind @?= Just CiFunction + -- resolved ^. insertTextFormat @?= Just PlainText + -- resolved ^. insertText @?= Nothing -- noSnippetsCaps = -- ( textDocument @@ -391,6 +390,6 @@ contextTests = testGroup "contexts" [ ] where compls `shouldContainCompl` x = - filter ((== x) . (^. label)) compls `shouldNotSatisfy` null + null (filter ((== x) . (^. label)) compls) @? "Should contain completion" compls `shouldNotContainCompl` x = - filter ((== x) . (^. label)) compls `shouldSatisfy` null + null (filter ((== x) . (^. label)) compls) @? "Should not contain completion" diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index 1eaef8eb64..b22241cb3e 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -16,7 +16,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree @@ -30,16 +29,16 @@ tests = testGroup "deferred responses" [ -- skipMany anyNotification -- hoverRsp <- message :: Session HoverResponse - -- liftIO $ hoverRsp ^? result . _Just . _Just . contents `shouldBe` Nothing - -- liftIO $ hoverRsp ^. LSP.id `shouldBe` responseId id1 + -- liftIO $ hoverRsp ^? result . _Just . _Just . contents @?= Nothing + -- liftIO $ hoverRsp ^. LSP.id @?= responseId id1 -- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) -- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse - -- liftIO $ symbolsRsp ^. LSP.id `shouldBe` responseId id2 + -- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2 -- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) -- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse - -- liftIO $ hoverRsp2 ^. LSP.id `shouldBe` responseId id3 + -- liftIO $ hoverRsp2 ^. LSP.id @?= responseId id3 -- let contents2 = hoverRsp2 ^? result . _Just . _Just . contents -- liftIO $ contents2 `shouldNotSatisfy` null @@ -48,7 +47,7 @@ tests = testGroup "deferred responses" [ -- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing -- highlightRsp <- request TextDocumentDocumentHighlight highlightParams -- let (Just (List locations)) = highlightRsp ^. result - -- liftIO $ locations `shouldBe` [ DocumentHighlight + -- liftIO $ locations @?= [ DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} @@ -95,7 +94,7 @@ tests = testGroup "deferred responses" [ testCase "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTestFail.hs" "haskell" defs <- getDefinitions doc (Position 1 11) - liftIO $ defs `shouldBe` [] + liftIO $ defs @?= [] -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link @@ -103,7 +102,7 @@ tests = testGroup "deferred responses" [ -- runSession hieCommand fullCaps "test/testdata" $ do -- doc <- openDoc "FuncTestFail.hs" "haskell" -- (Left (sym:_)) <- getDocumentSymbols doc - -- liftIO $ sym ^. name `shouldBe` "main" + -- liftIO $ sym ^. name @?= "main" -- TODO does not compile -- , testCase "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do @@ -113,7 +112,7 @@ tests = testGroup "deferred responses" [ -- let testUri = filePathToUri $ cwd "test/testdata/FuncTest.hs" -- diags <- skipManyTill loggingNotification publishDiagnosticsNotification - -- liftIO $ diags ^? params `shouldBe` (Just $ PublishDiagnosticsParams + -- liftIO $ diags ^? params @?= (Just $ PublishDiagnosticsParams -- { _uri = testUri -- , _diagnostics = List -- [ Diagnostic @@ -130,12 +129,12 @@ tests = testGroup "deferred responses" [ -- args = List [Object args'] -- -- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing) - -- liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty) + -- liftIO $ executeRsp ^. result @?= Just (Object H.empty) -- editReq <- message :: Session ApplyWorkspaceEditRequest -- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"] -- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] - -- liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit + -- liftIO $ editReq ^. params . edit @?= WorkspaceEdit -- Nothing -- (Just expectedTextDocEdits) -- , multiServerTests @@ -165,7 +164,7 @@ multiMainTests = testGroup "multiple main modules" [ diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification let (List diags) = diagsRspGhc ^. params . diagnostics - liftIO $ length diags `shouldBe` 2 + liftIO $ length diags @?= 2 _doc2 <- openDoc "HaReRename.hs" "haskell" _diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification @@ -173,5 +172,5 @@ multiMainTests = testGroup "multiple main modules" [ diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification let (List diags2) = diagsRsp2 ^. params . diagnostics - liftIO $ show diags2 `shouldBe` "[]" + liftIO $ show diags2 @?= "[]" ] diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index 1bfdb1da1b..c20d3def45 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -10,7 +10,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "definitions" [ @@ -20,7 +19,7 @@ tests = testGroup "definitions" [ doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) - liftIO $ defs `shouldBe` [Location (doc ^. uri) expRange] + liftIO $ defs @?= [Location (doc ^. uri) expRange] -- ----------------------------------- @@ -30,7 +29,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs `shouldBe` [Location (filePathToUri fp) zeroRange] + defs @?= [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's exported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do @@ -38,7 +37,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 0 15) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs `shouldBe` [Location (filePathToUri fp) zeroRange] + defs @?= [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded" $ runSession hieCommand fullCaps "test/testdata/definition" $ do @@ -47,7 +46,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs `shouldBe` [Location (filePathToUri fp) zeroRange] + defs @?= [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded, and then closed" $ @@ -60,7 +59,7 @@ tests = testGroup "definitions" [ liftIO $ putStrLn "D" liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs `shouldBe` [Location (filePathToUri fp) zeroRange] + defs @?= [Location (filePathToUri fp) zeroRange] liftIO $ putStrLn "E" -- AZ noDiagnostics diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index fc67bf324d..25ac0528a0 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -17,7 +17,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations -- --------------------------------------------------------------------- @@ -41,26 +40,26 @@ triggerTests = testGroup "diagnostics triggers" [ diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do - length diags `shouldBe` 2 - reduceDiag ^. LSP.range `shouldBe` Range (Position 1 0) (Position 1 12) - reduceDiag ^. LSP.severity `shouldBe` Just DsInfo - reduceDiag ^. LSP.code `shouldBe` Just (StringValue "Eta reduce") - reduceDiag ^. LSP.source `shouldBe` Just "hlint" + length diags @?= 2 + reduceDiag ^. LSP.range @?= Range (Position 1 0) (Position 1 12) + reduceDiag ^. LSP.severity @?= Just DsInfo + reduceDiag ^. LSP.code @?= Just (StringValue "Eta reduce") + reduceDiag ^. LSP.source @?= Just "hlint" diags2a <- waitForDiagnostics - liftIO $ length diags2a `shouldBe` 2 + liftIO $ length diags2a @?= 2 sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) diags3@(d:_) <- waitForDiagnosticsSource "eg2" liftIO $ do - length diags3 `shouldBe` 1 - d ^. LSP.range `shouldBe` Range (Position 0 0) (Position 1 0) - d ^. LSP.severity `shouldBe` Nothing - d ^. LSP.code `shouldBe` Nothing - d ^. LSP.message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" + length diags3 @?= 1 + d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) + d ^. LSP.severity @?= Nothing + d ^. LSP.code @?= Nothing + d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" ] errorTests :: TestTree @@ -69,7 +68,7 @@ errorTests = testGroup "typed hole errors" [ runSession hieCommand fullCaps "test/testdata" $ do _ <- openDoc "TypedHoles.hs" "haskell" [diag] <- waitForDiagnosticsSource "bios" - liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning + liftIO $ diag ^. LSP.severity @?= Just DsWarning ] warningTests :: TestTree @@ -78,7 +77,7 @@ warningTests = testGroup "Warnings are warnings" [ runSession hieCommand fullCaps "test/testdata/wErrorTest" $ do _ <- openDoc "src/WError.hs" "haskell" [diag] <- waitForDiagnosticsSource "bios" - liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning + liftIO $ diag ^. LSP.severity @?= Just DsWarning ] saveTests :: TestTree @@ -91,7 +90,7 @@ saveTests = testGroup "only diagnostics on save" [ diags <- waitForDiagnostics liftIO $ do - length diags `shouldBe` 0 + length diags @?= 0 let te = TextEdit (Range (Position 0 0) (Position 0 13)) "" _ <- applyEdit doc te @@ -100,5 +99,5 @@ saveTests = testGroup "only diagnostics on save" [ sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) diags2 <- waitForDiagnostics liftIO $ - length diags2 `shouldBe` 1 + length diags2 @?= 1 ] diff --git a/test/functional/Format.hs b/test/functional/Format.hs index f1f8e7c291..66964182be 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -113,6 +113,8 @@ stylishHaskellTests = testGroup "stylish-haskell" [ BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] +#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) || !defined(AGPL) +#else brittanyTests :: TestTree brittanyTests = testGroup "brittany" [ goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/BrittanyLF.formatted_document.hs" $ runSession hieCommand fullCaps "test/testdata" $ do @@ -141,6 +143,7 @@ brittanyTests = testGroup "brittany" [ formatRange doc (FormattingOptions 4 True) range BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] +#endif ormoluTests :: TestTree ormoluTests = testGroup "ormolu" [ @@ -160,9 +163,12 @@ ormoluTests = testGroup "ormolu" [ formatLspConfig :: Value -> Value formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] +#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) || !defined(AGPL) +#else -- | The same as 'formatLspConfig' but using the legacy section name formatLspConfigOld :: Value -> Value formatLspConfigOld provider = object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] +#endif formatConfig :: Value -> SessionConfig formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index e51ee00cf0..231c04ea65 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -11,7 +11,6 @@ module FunctionalBadProject (tests) where -- import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit -import Test.Hspec.Expectations -- --------------------------------------------------------------------- -- TODO: Currently this can not succeed, since such an error is thrown in "runActionWithContext" which @@ -20,7 +19,7 @@ import Test.Hspec.Expectations -- tests :: TestTree tests = testGroup "behaviour on malformed projects" [ - testCase "no test executed" $ True `shouldBe` True + testCase "no test executed" $ True @?= True ] -- testCase "deals with cabal file with unsatisfiable dependency" $ @@ -29,14 +28,14 @@ tests = testGroup "behaviour on malformed projects" [ -- _doc <- openDoc "Foo.hs" "haskell" -- diags@(d:_) <- waitForDiagnosticsSource "bios" - -- -- liftIO $ show diags `shouldBe` "" + -- -- liftIO $ show diags @?= "" -- -- liftIO $ putStrLn $ show diags -- -- liftIO $ putStrLn "a" -- liftIO $ do - -- length diags `shouldBe` 1 - -- d ^. range `shouldBe` Range (Position 0 0) (Position 1 0) - -- d ^. severity `shouldBe` (Just DsError) - -- d ^. code `shouldBe` Nothing - -- d ^. source `shouldBe` Just "bios" - -- d ^. message `shouldBe` + -- length diags @?= 1 + -- d ^. range @?= Range (Position 0 0) (Position 1 0) + -- d ^. severity @?= (Just DsError) + -- d ^. code @?= Nothing + -- d ^. source @?= Just "bios" + -- d ^. message @?= -- (T.pack "readCreateProcess: stack \"build\" \"--only-configure\" \".\" (exit 1): failed\n") diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 1acf37216f..2a01a9f4ca 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -10,6 +10,7 @@ import Control.Monad.IO.Class import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM +import Data.List import Data.Maybe #if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) @@ -24,7 +25,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -49,21 +49,21 @@ hlintTests = testGroup "hlint suggestions" [ diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do - length diags `shouldBe` 2 - reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12) - reduceDiag ^. L.severity `shouldBe` Just DsInfo - reduceDiag ^. L.code `shouldBe` Just (StringValue "Eta reduce") - reduceDiag ^. L.source `shouldBe` Just "hlint" + length diags @?= 2 + reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) + reduceDiag ^. L.severity @?= Just DsInfo + reduceDiag ^. L.code @?= Just (StringValue "Eta reduce") + reduceDiag ^. L.source @?= Just "hlint" (CACodeAction ca:_) <- getAllCodeActions doc -- Evaluate became redundant id in later hlint versions - liftIO $ ["Apply hint:Redundant id", "Apply hint:Evaluate"] `shouldContain` [ca ^. L.title] + liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" executeCodeAction ca contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + liftIO $ contents @?= "main = undefined\nfoo x = x\n" noDiagnostics @@ -75,12 +75,12 @@ hlintTests = testGroup "hlint suggestions" [ (CACommand cmd:_) <- getAllCodeActions doc -- Evaluate became redundant id in later hlint versions - liftIO $ ["Apply hint:Redundant id", "Apply hint:Evaluate"] `shouldContain` [cmd ^. L.title ] + liftIO $ (cmd ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" executeCommand cmd contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc - liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + liftIO $ contents @?= "main = undefined\nfoo x = x\n" noDiagnostics @@ -92,21 +92,21 @@ hlintTests = testGroup "hlint suggestions" [ diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do - length diags `shouldBe` 2 - reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12) - reduceDiag ^. L.severity `shouldBe` Just DsInfo - reduceDiag ^. L.code `shouldBe` Just (StringValue "Eta reduce") - reduceDiag ^. L.source `shouldBe` Just "hlint" + length diags @?= 2 + reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) + reduceDiag ^. L.severity @?= Just DsInfo + reduceDiag ^. L.code @?= Just (StringValue "Eta reduce") + reduceDiag ^. L.source @?= Just "hlint" (CACodeAction ca:_) <- getAllCodeActions doc -- Evaluate became redundant id in later hlint versions - liftIO $ ["Apply hint:Redundant id", "Apply hint:Evaluate"] `shouldContain` [ca ^. L.title] + liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" executeCodeAction ca contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + liftIO $ contents @?= "main = undefined\nfoo x = x\n" sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) noDiagnostics @@ -123,7 +123,7 @@ renameTests = testGroup "rename suggestions" [ executeCommand cmd x:_ <- T.lines <$> documentContents doc - liftIO $ x `shouldBe` "main = putStrLn \"hello\"" + liftIO $ x @?= "main = putStrLn \"hello\"" , ignoreTestBecause "Broken" $ testCase "doesn't give both documentChanges and changes" $ runSession hieCommand noLiteralCaps "test/testdata" $ do @@ -135,13 +135,13 @@ renameTests = testGroup "rename suggestions" [ let Just (List [Object args]) = cmd ^. L.arguments Object editParams = args HM.! "fallbackWorkspaceEdit" liftIO $ do - editParams `shouldSatisfy` HM.member "changes" - editParams `shouldNotSatisfy` HM.member "documentChanges" + "changes" `HM.member` editParams @? "Contains changes" + not ("documentChanges" `HM.member` editParams) @? "Doesn't contain documentChanges" executeCommand cmd _:x:_ <- T.lines <$> documentContents doc - liftIO $ x `shouldBe` "foo = putStrLn \"world\"" + liftIO $ x @?= "foo = putStrLn \"world\"" ] importTests :: TestTree @@ -154,27 +154,27 @@ importTests = testGroup "import suggestions" [ -- ignore the first empty hlint diagnostic publish [_,diag:_] <- count 2 waitForDiagnostics - liftIO $ diag ^. L.message `shouldBe` "Variable not in scope: when :: Bool -> IO () -> IO ()" + liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" actionsOrCommands <- getAllCodeActions doc let actns = map fromAction actionsOrCommands liftIO $ do - head actns ^. L.title `shouldBe` "Import module Control.Monad" - head (tail actns) ^. L.title `shouldBe` "Import module Control.Monad (when)" + head actns ^. L.title @?= "Import module Control.Monad" + head (tail actns) ^. L.title @?= "Import module Control.Monad (when)" forM_ actns $ \a -> do - a ^. L.kind `shouldBe` Just CodeActionQuickFix - a ^. L.command `shouldSatisfy` isJust - a ^. L.edit `shouldBe` Nothing + a ^. L.kind @?= Just CodeActionQuickFix + isJust (a ^. L.command) @? "Contains command" + a ^. L.edit @?= Nothing let hasOneDiag (Just (List [_])) = True hasOneDiag _ = False - a ^. L.diagnostics `shouldSatisfy` hasOneDiag - length actns `shouldBe` 10 + hasOneDiag (a ^. L.diagnostics) @? "Has one diagnostic" + length actns @?= 10 executeCodeAction (head actns) contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" + liftIO $ contents @?= "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" ] packageTests :: TestTree @@ -192,22 +192,21 @@ packageTests = testGroup "add package suggestions" [ , "Could not load module ‘Data.Text’" -- GHC >= 8.6 , "Could not find module ‘Data.Text’" ] - in liftIO $ diag ^. L.message `shouldSatisfy` \m -> any (`T.isPrefixOf` m) prefixes + in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" acts <- getAllCodeActions doc let (CACodeAction action:_) = acts liftIO $ do - action ^. L.title `shouldBe` "Add text as a dependency" - action ^. L.kind `shouldBe` Just CodeActionQuickFix - action ^. L.command . _Just . L.command `shouldSatisfy` T.isSuffixOf "package:add" + action ^. L.title @?= "Add text as a dependency" + action ^. L.kind @?= Just CodeActionQuickFix + "package:add" `T.isSuffixOf` (action ^. L.command . _Just . L.command) @? "Command contains package:add" executeCodeAction action contents <- getDocumentEdit . TextDocumentIdentifier =<< getDocUri "add-package-test.cabal" liftIO $ - T.lines contents `shouldSatisfy` \x -> - any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) x + any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) (T.lines contents) @? "Contains text package" , ignoreTestBecause "Broken" $ testCase "adds to hpack package.yaml files" $ runSession hieCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do @@ -221,23 +220,23 @@ packageTests = testGroup "add package suggestions" [ , "Could not load module ‘Codec.Compression.GZip’" -- GHC >= 8.6 , "Could not find module ‘Codec.Compression.GZip’" ] - in liftIO $ diag ^. L.message `shouldSatisfy` \m -> any (`T.isPrefixOf` m) prefixes + in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Diagnostic contains message" mActions <- getAllCodeActions doc let allActions = map fromAction mActions action = head allActions liftIO $ do - action ^. L.title `shouldBe` "Add zlib as a dependency" - forM_ allActions $ \a -> a ^. L.kind `shouldBe` Just CodeActionQuickFix - forM_ allActions $ \a -> a ^. L.command . _Just . L.command `shouldSatisfy` T.isSuffixOf "package:add" + action ^. L.title @?= "Add zlib as a dependency" + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> "package:add" `T.isSuffixOf` (a ^. L.command . _Just . L.command) @? "Command contains package:add" executeCodeAction action contents <- getDocumentEdit . TextDocumentIdentifier =<< getDocUri "package.yaml" liftIO $ do - T.lines contents !! 3 `shouldSatisfy` T.isSuffixOf "zlib" - T.lines contents !! 21 `shouldNotSatisfy` T.isSuffixOf "zlib" + "zlib" `T.isSuffixOf` (T.lines contents !! 3) @? "Contains zlib" + "zlib" `T.isSuffixOf` (T.lines contents !! 21) @? "Does not contain zlib in unrelated component" ] redundantImportTests :: TestTree @@ -252,18 +251,18 @@ redundantImportTests = testGroup "redundant import code actions" [ let prefixes = [ "The import of `Data.List' is redundant" -- Windows , "The import of ‘Data.List’ is redundant" ] - in liftIO $ diag ^. L.message `shouldSatisfy` \m -> any (`T.isPrefixOf` m) prefixes + in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains message" mActions <- getAllCodeActions doc let allActions@[removeAction, changeAction] = map fromAction mActions liftIO $ do - removeAction ^. L.title `shouldBe` "Remove redundant import" - changeAction ^. L.title `shouldBe` "Import instances" - forM_ allActions $ \a -> a ^. L.kind `shouldBe` Just CodeActionQuickFix - forM_ allActions $ \a -> a ^. L.command `shouldBe` Nothing - forM_ allActions $ \a -> a ^. L.edit `shouldSatisfy` isJust + removeAction ^. L.title @?= "Remove redundant import" + changeAction ^. L.title @?= "Import instances" + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> a ^. L.command @?= Nothing + forM_ allActions $ \a -> isJust (a ^. L.edit) @? "Has edit" executeCodeAction removeAction @@ -271,7 +270,7 @@ redundantImportTests = testGroup "redundant import code actions" [ -- provides workspace edit property which skips round trip to -- the server contents <- documentContents doc - liftIO $ contents `shouldBe` "module CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\"" + liftIO $ contents @?= "module CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\"" , ignoreTestBecause "Broken" $ testCase "doesn't touch other imports" $ runSession hieCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" @@ -279,7 +278,7 @@ redundantImportTests = testGroup "redundant import code actions" [ [CACommand cmd, _] <- getAllCodeActions doc executeCommand cmd contents <- documentContents doc - liftIO $ (T.lines contents) `shouldBe` + liftIO $ (T.lines contents) @?= [ "module MultipleImports where" , "import Data.Maybe" , "foo :: Int" @@ -298,34 +297,34 @@ typedHoleTests = testGroup "typed hole code actions" [ suggestion <- case ghcVersion of GHC88 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (Int) with x ([Int])" , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" - ] + ] @? "Contains substitutions" return "x" GHC86 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (Int) with x ([Int])" , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" - ] + ] @? "Contains substitutions" return "x" GHC84 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (Int) with maxBound (forall a. Bounded a => a)" , "Substitute hole (Int) with minBound (forall a. Bounded a => a)" , "Substitute hole (Int) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" - ] + ] @? "Contains substitutions" return "maxBound" executeCodeAction $ head cas contents <- documentContents doc - liftIO $ contents `shouldBe` T.concat + liftIO $ contents @?= T.concat [ "module TypedHoles where\n" , "foo :: [Int] -> Int\n" , "foo x = " <> suggestion @@ -340,33 +339,33 @@ typedHoleTests = testGroup "typed hole code actions" [ suggestion <- case ghcVersion of GHC88 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (A) with stuff (A -> A)" , "Substitute hole (A) with x ([A])" , "Substitute hole (A) with foo2 ([A] -> A)" - ] + ] @? "Contains substitutions" return "stuff" GHC86 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (A) with stuff (A -> A)" , "Substitute hole (A) with x ([A])" , "Substitute hole (A) with foo2 ([A] -> A)" - ] + ] @? "Contains substituions" return "stuff" GHC84 -> do - liftIO $ map (^. L.title) cas `shouldMatchList` + liftIO $ map (^. L.title) cas `matchList` [ "Substitute hole (A) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" , "Substitute hole (A) with stuff (A -> A)" , "Substitute hole (A) with x ([A])" , "Substitute hole (A) with foo2 ([A] -> A)" - ] + ] @? "Contains substitutions" return "undefined" executeCodeAction $ head cas contents <- documentContents doc - liftIO $ (T.lines contents) `shouldBe` + liftIO $ (T.lines contents) @?= [ "module TypedHoles2 (foo2) where" , "newtype A = A Int" , "foo2 :: [A] -> A" @@ -375,6 +374,15 @@ typedHoleTests = testGroup "typed hole code actions" [ , " stuff (A a) = A (a + 1)" ] ] + where + -- | 'True' if @xs@ contains all of @ys@, possibly in a different order. + matchList :: (Eq a) => [a] -> [a] -> Bool + xs `matchList` ys + | null extra && null missing = True + | otherwise = False + where + extra = xs \\ ys + missing = ys \\ xs signatureTests :: TestTree signatureTests = testGroup "missing top level signature code actions" [ @@ -385,7 +393,7 @@ signatureTests = testGroup "missing top level signature code actions" [ _ <- waitForDiagnosticsSource "bios" cas <- map fromAction <$> getAllCodeActions doc - liftIO $ map (^. L.title) cas `shouldContain` [ "Add signature: main :: IO ()"] + liftIO $ "Add signature: main :: IO ()" `elem` (map (^. L.title) cas) @? "Contains code action" executeCodeAction $ head cas @@ -399,7 +407,7 @@ signatureTests = testGroup "missing top level signature code actions" [ , " return ()" ] - liftIO $ (T.lines contents) `shouldBe` expected + liftIO $ (T.lines contents) @?= expected ] missingPragmaTests :: TestTree @@ -411,8 +419,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ _ <- waitForDiagnosticsSource "bios" cas <- map fromAction <$> getAllCodeActions doc - liftIO $ map (^. L.title) cas `shouldContain` [ "Add \"TypeSynonymInstances\""] - liftIO $ map (^. L.title) cas `shouldContain` [ "Add \"FlexibleInstances\""] + liftIO $ "Add \"TypeSynonymInstances\"" `elem` map (^. L.title) cas @? "Contains TypeSynonymInstances code action" + liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances code action" executeCodeAction $ head cas @@ -436,7 +444,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ , " deriving (Generic,Functor,Traversable)" ] - liftIO $ (T.lines contents) `shouldBe` expected + liftIO $ (T.lines contents) @?= expected ] unusedTermTests :: TestTree @@ -462,7 +470,7 @@ unusedTermTests = testGroup "unused term code actions" [ -- , "_imUnused _ = 3" -- ] -- - -- liftIO $ edit `shouldBe` T.unlines expected + -- liftIO $ edit @?= T.unlines expected -- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction -- `CodeActionContext` @@ -478,8 +486,8 @@ unusedTermTests = testGroup "unused term code actions" [ liftIO $ do -- TODO: When HaRe is back this should be uncommented -- kinds `shouldNotSatisfy` null - kinds `shouldNotSatisfy` any (Just CodeActionRefactorInline /=) - kinds `shouldSatisfy` all (Just CodeActionRefactorInline ==) + not (any (Just CodeActionRefactorInline /=) kinds) @? "None not CodeActionRefactorInline" + all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ] fromAction :: CAResult -> CodeAction diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs index 7cd8bb6557..d14223252a 100644 --- a/test/functional/FunctionalLiquid.hs +++ b/test/functional/FunctionalLiquid.hs @@ -15,7 +15,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations -- --------------------------------------------------------------------- @@ -28,26 +27,26 @@ tests = testGroup "liquid haskell diagnostics" [ diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do - length diags `shouldBe` 2 - reduceDiag ^. range `shouldBe` Range (Position 5 18) (Position 5 22) - reduceDiag ^. severity `shouldBe` Just DsHint - reduceDiag ^. code `shouldBe` Just (StringValue "Use negate") - reduceDiag ^. source `shouldBe` Just "hlint" + length diags @?= 2 + reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) + reduceDiag ^. severity @?= Just DsHint + reduceDiag ^. code @?= Just (StringValue "Use negate") + reduceDiag ^. source @?= Just "hlint" diags2hlint <- waitForDiagnostics - liftIO $ length diags2hlint `shouldBe` 2 + liftIO $ length diags2hlint @?= 2 sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) diags3@(d:_) <- waitForDiagnosticsSource "eg2" liftIO $ do - length diags3 `shouldBe` 1 - d ^. LSP.range `shouldBe` Range (Position 0 0) (Position 1 0) - d ^. LSP.severity `shouldBe` Nothing - d ^. LSP.code `shouldBe` Nothing - d ^. LSP.message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" + length diags3 @?= 1 + d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) + d ^. LSP.severity @?= Nothing + d ^. LSP.code @?= Nothing + d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" -- --------------------------------- @@ -58,14 +57,14 @@ tests = testGroup "liquid haskell diagnostics" [ diags@(reduceDiag:_) <- waitForDiagnostics - -- liftIO $ show diags `shouldBe` "" + -- liftIO $ show diags @?= "" liftIO $ do - length diags `shouldBe` 2 - reduceDiag ^. range `shouldBe` Range (Position 5 18) (Position 5 22) - reduceDiag ^. severity `shouldBe` Just DsHint - reduceDiag ^. code `shouldBe` Just (StringValue "Use negate") - reduceDiag ^. source `shouldBe` Just "hlint" + length diags @?= 2 + reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) + reduceDiag ^. severity @?= Just DsHint + reduceDiag ^. code @?= Just (StringValue "Use negate") + reduceDiag ^. source @?= Just "hlint" -- Enable liquid haskell plugin and disable hlint let config = def { liquidOn = True, hlintOn = False } @@ -77,25 +76,27 @@ tests = testGroup "liquid haskell diagnostics" [ -- TODO: whether hlint is really disbabled? -- TODO: @fendor, document or remove -- diags2hlint <- waitForDiagnostics - -- -- liftIO $ show diags2hlint `shouldBe` "" + -- -- liftIO $ show diags2hlint @?= "" -- -- We turned hlint diagnostics off - -- liftIO $ length diags2hlint `shouldBe` 0 + -- liftIO $ length diags2hlint @?= 0 -- diags2liquid <- waitForDiagnostics - -- liftIO $ length diags2liquid `shouldBe` 0 - -- liftIO $ show diags2liquid `shouldBe` "" + -- liftIO $ length diags2liquid @?= 0 + -- liftIO $ show diags2liquid @?= "" diags3@(d:_) <- waitForDiagnosticsSource "liquid" - -- liftIO $ show diags3 `shouldBe` "" + -- liftIO $ show diags3 @?= "" liftIO $ do - length diags3 `shouldBe` 1 - d ^. range `shouldBe` Range (Position 8 0) (Position 8 11) - d ^. severity `shouldBe` Just DsError - d ^. code `shouldBe` Nothing - d ^. source `shouldBe` Just "liquid" - d ^. message `shouldSatisfy` T.isPrefixOf ("Error: Liquid Type Mismatch\n" <> - " Inferred type\n" <> - " VV : {v : GHC.Types.Int | v == 7}\n" <> - " \n" <> - " not a subtype of Required type\n" <> - " VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ") - ] \ No newline at end of file + length diags3 @?= 1 + d ^. range @?= Range (Position 8 0) (Position 8 11) + d ^. severity @?= Just DsError + d ^. code @?= Nothing + d ^. source @?= Just "liquid" + (d ^. message) `T.isPrefixOf` + ("Error: Liquid Type Mismatch\n" <> + " Inferred type\n" <> + " VV : {v : GHC.Types.Int | v == 7}\n" <> + " \n" <> + " not a subtype of Required type\n" <> + " VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ") + @? "Contains error message" + ] diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs index 07031785c9..47d5b2c9cb 100644 --- a/test/functional/Highlight.hs +++ b/test/functional/Highlight.hs @@ -9,7 +9,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "highlight" [ @@ -23,7 +22,7 @@ tests = testGroup "highlight" [ , DocumentHighlight (mkRange 4 22 4 25) (Just HkRead) , DocumentHighlight (mkRange 3 6 3 9) (Just HkRead) , DocumentHighlight (mkRange 1 0 1 3) (Just HkRead)] - mapM_ (\x -> highlights `shouldContain` [x]) hls + mapM_ (\x -> x `elem` highlights @? "Contains highlight") hls ] where mkRange sl sc el ec = Range (Position sl sc) (Position el ec) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 82daa4e429..b6226975a1 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -16,7 +16,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "window/workDoneProgress" [ @@ -29,25 +28,25 @@ tests = testGroup "window/workDoneProgress" [ createRequest <- message :: Session WorkDoneProgressCreateRequest liftIO $ do - createRequest ^. L.params `shouldBe` WorkDoneProgressCreateParams (ProgressNumericToken 0) + createRequest ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 0) startNotification <- message :: Session WorkDoneProgressBeginNotification liftIO $ do -- Expect a stack cradle, since the given `hie.yaml` is expected -- to contain a multi-stack cradle. - startNotification ^. L.params . L.value . L.title `shouldBe` "Initializing Stack project" - startNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0) + startNotification ^. L.params . L.value . L.title @?= "Initializing Stack project" + startNotification ^. L.params . L.token @?= (ProgressNumericToken 0) reportNotification <- message :: Session WorkDoneProgressReportNotification liftIO $ do - reportNotification ^. L.params . L.value . L.message `shouldBe` Just "Main" - reportNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0) + reportNotification ^. L.params . L.value . L.message @?= Just "Main" + reportNotification ^. L.params . L.token @?= (ProgressNumericToken 0) -- may produce diagnostics skipMany publishDiagnosticsNotification doneNotification <- message :: Session WorkDoneProgressEndNotification - liftIO $ doneNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0) + liftIO $ doneNotification ^. L.params . L.token @?= (ProgressNumericToken 0) -- Initial hlint notifications _ <- publishDiagnosticsNotification @@ -57,20 +56,20 @@ tests = testGroup "window/workDoneProgress" [ createRequest' <- skipManyTill loggingNotification (message :: Session WorkDoneProgressCreateRequest) liftIO $ do - createRequest' ^. L.params `shouldBe` WorkDoneProgressCreateParams (ProgressNumericToken 1) + createRequest' ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 1) startNotification' <- message :: Session WorkDoneProgressBeginNotification liftIO $ do - startNotification' ^. L.params . L.value . L.title `shouldBe` "loading" - startNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1) + startNotification' ^. L.params . L.value . L.title @?= "loading" + startNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) reportNotification' <- message :: Session WorkDoneProgressReportNotification liftIO $ do - reportNotification' ^. L.params . L.value . L.message `shouldBe` Just "Main" - reportNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1) + reportNotification' ^. L.params . L.value . L.message @?= Just "Main" + reportNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) doneNotification' <- message :: Session WorkDoneProgressEndNotification - liftIO $ doneNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1) + liftIO $ doneNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) -- Initial hlint notifications _ <- publishDiagnosticsNotification diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index 173e42515b..4fad312fc2 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -2,6 +2,7 @@ module Reference (tests) where import Control.Lens import Control.Monad.IO.Class +import Data.List import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens @@ -9,7 +10,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "references" [ @@ -17,14 +17,14 @@ tests = testGroup "references" [ doc <- openDoc "References.hs" "haskell" let pos = Position 2 7 -- foo = bar <-- refs <- getReferences doc pos True - liftIO $ refs `shouldContain` map (Location (doc ^. uri)) [ + liftIO $ map (Location (doc ^. uri)) [ mkRange 4 0 4 3 , mkRange 8 11 8 14 , mkRange 7 7 7 10 , mkRange 4 14 4 17 , mkRange 4 0 4 3 , mkRange 2 6 2 9 - ] + ] `isInfixOf` refs @? "Contains references" -- TODO: Respect withDeclaration parameter -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hieCommand fullCaps "test/testdata" $ do -- doc <- openDoc "References.hs" "haskell" diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs index 0cecd1c73d..dd70a19d86 100644 --- a/test/functional/Rename.hs +++ b/test/functional/Rename.hs @@ -7,11 +7,10 @@ module Rename (tests) where -- import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "rename" [ - testCase "works" $ True `shouldBe` True + testCase "works" $ True @?= True -- pendingWith "removed because of HaRe" -- runSession hieCommand fullCaps "test/testdata" $ do -- doc <- openDoc "Rename.hs" "haskell" @@ -25,4 +24,4 @@ tests = testGroup "rename" [ -- \baz :: Int -> Int\n\ -- \baz x = x + 1\n\ -- \bar = (+ 1) . baz\n" - ] \ No newline at end of file + ] diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index 066b87b71c..40f9524c44 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -2,6 +2,7 @@ module Symbol (tests) where import Control.Monad.IO.Class +import Data.List import Language.Haskell.LSP.Test as Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities @@ -9,7 +10,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "document symbols" [ @@ -27,7 +27,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ a = DocumentSymbol "A" (Just "") SkConstructor Nothing aR aSR (Just mempty) b = DocumentSymbol "B" (Just "") SkConstructor Nothing bR bSR (Just mempty) - liftIO $ symbs `shouldContain` [myData] + liftIO $ myData `elem` symbs @? "Contains symbol" ,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" @@ -38,7 +38,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ dog = DocumentSymbol "dog" (Just "") SkVariable Nothing dogR dogSR (Just mempty) cat = DocumentSymbol "cat" (Just "") SkVariable Nothing catR catSR (Just mempty) - liftIO $ symbs `shouldContain` [foo] + liftIO $ foo `elem` symbs @? "Contains symbol" , ignoreTestBecause "Broken" $ testCase "provides pattern synonyms" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" @@ -47,7 +47,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ let testPattern = DocumentSymbol "TestPattern" (Just "") SkFunction Nothing testPatternR testPatternSR (Just mempty) - liftIO $ symbs `shouldContain` [testPattern] + liftIO $ testPattern `elem` symbs @? "Contains symbol" ] -- TODO: Test module, imports @@ -62,7 +62,7 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ a = SymbolInformation "A" SkConstructor Nothing (Location testUri aR) (Just "MyData") b = SymbolInformation "B" SkConstructor Nothing (Location testUri bR) (Just "MyData") - liftIO $ symbs `shouldContain` [myData, a, b] + liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols" ,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hieCommand oldCaps "test/testdata" $ do doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" @@ -74,7 +74,7 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ cat = SymbolInformation "cat" SkVariable Nothing (Location testUri catR) (Just "bar") -- Order is important! - liftIO $ symbs `shouldContain` [foo, bar, dog, cat] + liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols" ] oldCaps :: ClientCapabilities @@ -111,4 +111,4 @@ bR = Range (Position 10 14) (Position 10 22) testPatternSR :: Range testPatternSR = Range (Position 13 8) (Position 13 19) testPatternR :: Range -testPatternR = Range (Position 13 0) (Position 13 27) \ No newline at end of file +testPatternR = Range (Position 13 0) (Position 13 27) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index a415c82618..28cee22bb3 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -8,7 +8,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Test.Hspec.Expectations tests :: TestTree tests = testGroup "type definitions" [ @@ -19,10 +18,9 @@ tests = testGroup "type definitions" [ defs <- getTypeDefinitions doc (toPos (11, 23)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (8, 1)) (toPos (8, 29))) - ] + defs @?= [ Location (filePathToUri fp) + (Range (toPos (8, 1)) (toPos (8, 29))) + ] , ignoreTestBecause "Broken" $ testCase "finds local definition of newtype variable" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do @@ -30,10 +28,9 @@ tests = testGroup "type definitions" [ defs <- getTypeDefinitions doc (toPos (16, 21)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (13, 1)) (toPos (13, 30))) - ] + defs @?= [ Location (filePathToUri fp) + (Range (toPos (13, 1)) (toPos (13, 30))) + ] , ignoreTestBecause "Broken" $ testCase "finds local definition of sum type variable" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do @@ -41,10 +38,9 @@ tests = testGroup "type definitions" [ defs <- getTypeDefinitions doc (toPos (21, 13)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) - ] + defs @?= [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] , ignoreTestBecause "Broken" $ testCase "finds local definition of sum type contructor" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do @@ -53,15 +49,15 @@ tests = testGroup "type definitions" [ liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) - ] + @?= [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] , ignoreTestBecause "Broken" $ testCase "can not find non-local definition of type def" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" defs <- getTypeDefinitions doc (toPos (30, 17)) - liftIO $ defs `shouldBe` [] + liftIO $ defs @?= [] , ignoreTestBecause "Broken" $ testCase "find local definition of type def" $ runSession hieCommand fullCaps "test/testdata/gototest" @@ -70,10 +66,9 @@ tests = testGroup "type definitions" [ defs <- getTypeDefinitions doc (toPos (35, 16)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) - ] + defs @?= [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] {-- TODO Implement , ignoreTestBecause "Broken" $ testCase "find type-definition of type def in component" @@ -87,7 +82,7 @@ tests = testGroup "type definitions" [ liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" defs - `shouldBe` [ Location (filePathToUri fp) + @?= [ Location (filePathToUri fp) (Range (toPos (8, 1)) (toPos (8, 29))) ] --} @@ -98,10 +93,9 @@ tests = testGroup "type definitions" [ defs <- getTypeDefinitions doc (toPos (40, 19)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - `shouldBe` [ Location (filePathToUri fp) - (Range (toPos (37, 1)) (toPos (37, 31))) - ] + defs @?= [ Location (filePathToUri fp) + (Range (toPos (37, 1)) (toPos (37, 31))) + ] ] --NOTE: copied from Haskell.Ide.Engine.ArtifactMap From 38672e030eaa68eddf195a027f56915edaa99597 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 31 Jul 2020 15:01:38 +0100 Subject: [PATCH 20/23] Slow down Tasty by limiting it to -j1 Fixes flakey CI builds. Turns out it was trying to run every single test in parallel at once, which is why when #247 added two extra tests it was just enough to push it over the limit and cause things to fail --- .circleci/config.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index f8eb5c5ada..453ef77811 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -42,7 +42,7 @@ defaults: &defaults - run: name: Build Testsuite without running it - command: stack -j 2 --stack-yaml=${STACK_FILE} build --test --no-run-tests + command: stack --stack-yaml=${STACK_FILE} build --test --no-run-tests no_output_timeout: 30m - store_artifacts: @@ -65,8 +65,11 @@ defaults: &defaults - run: name: Test haskell-language-server - # Tests MUST run with -j1, since multiple ghc-mod sessions are not allowed - command: stack -j 1 --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs + # Tasty by default will run all the tests in parallel. Which should + # work ok, but given that these CircleCI runners aren't the beefiest + # machine can cause some flakiness. So pass -j1 to Tasty (NOT Stack) to + # tell it to go slow and steady. + command: stack --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs --test-arguments="-j1" no_output_timeout: 120m - store_test_results: From 26f1e7feae866fd445f725317fadf8e1be96b184 Mon Sep 17 00:00:00 2001 From: Junyoung Clare Jang Date: Fri, 31 Jul 2020 17:20:36 -0400 Subject: [PATCH 21/23] Remove a redundant caching step --- .circleci/config.yml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 453ef77811..35d38741ef 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -78,10 +78,6 @@ defaults: &defaults - store_artifacts: path: test-logs - - save_cache: - key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }} - paths: *cache_paths - - save_cache: key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }} paths: *cache_paths From a308151650097507627696cada20e9f7da8e8027 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 31 Jul 2020 23:29:45 +0100 Subject: [PATCH 22/23] Fix compression extension on GitHub build artifacts --- .github/workflows/build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index c19daa3c50..3373f72757 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -90,7 +90,7 @@ jobs: - uses: actions/upload-artifact@v2 with: - name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.gz + name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.${{ steps.compress_server_binary.outputs.extension }} path: ${{ steps.compress_server_binary.outputs.path }} - name: Build Wrapper @@ -130,6 +130,6 @@ jobs: - uses: actions/upload-artifact@v2 if: matrix.ghc == '8.10.1' with: - name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.gz + name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.${{ steps.compress_wrapper_binary.outputs.extension }} path: ${{ steps.compress_wrapper_binary.outputs.path }} From d961197326c78a8737cef0c1ca7f7826b4826463 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Sat, 1 Aug 2020 01:06:55 +0100 Subject: [PATCH 23/23] Add fourmolu plugin --- cabal.project | 4 + exe/Main.hs | 6 +- haskell-language-server.cabal | 2 + src/Ide/Plugin/Fourmolu.hs | 95 +++++++++++++++++++++ src/Ide/Plugin/Ormolu.hs | 3 +- stack-8.10.1.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.2.yaml | 1 + stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + test/functional/Format.hs | 15 ++++ test/testdata/Format.fourmolu.formatted.hs | 16 ++++ test/testdata/Format2.fourmolu.formatted.hs | 5 ++ 14 files changed, 149 insertions(+), 3 deletions(-) create mode 100644 src/Ide/Plugin/Fourmolu.hs create mode 100644 test/testdata/Format.fourmolu.formatted.hs create mode 100644 test/testdata/Format2.fourmolu.formatted.hs diff --git a/cabal.project b/cabal.project index c063a3fc3e..c28b76d41a 100644 --- a/cabal.project +++ b/cabal.project @@ -15,3 +15,7 @@ package ghcide write-ghc-environment-files: never index-state: 2020-07-27T12:40:45Z + +allow-newer: + floskell:aeson + stylish-haskell:aeson diff --git a/exe/Main.hs b/exe/Main.hs index 081f261cac..8234bc1071 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -67,6 +67,7 @@ import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Ide.Plugin.GhcIde as GhcIde import Ide.Plugin.Floskell as Floskell +import Ide.Plugin.Fourmolu as Fourmolu import Ide.Plugin.Ormolu as Ormolu import Ide.Plugin.StylishHaskell as StylishHaskell #if AGPL @@ -101,8 +102,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins GhcIde.descriptor "ghcide" , Pragmas.descriptor "pragmas" , Floskell.descriptor "floskell" - -- , genericDescriptor "generic" - -- , ghcmodDescriptor "ghcmod" + , Fourmolu.descriptor "fourmolu" + -- , genericDescriptor "generic" + -- , ghcmodDescriptor "ghcmod" , Ormolu.descriptor "ormolu" , StylishHaskell.descriptor "stylish-haskell" #if AGPL diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 120f1dcce2..090863b9ac 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -44,6 +44,7 @@ library Ide.Plugin.Eval Ide.Plugin.Example Ide.Plugin.Example2 + Ide.Plugin.Fourmolu Ide.Plugin.GhcIde Ide.Plugin.Ormolu Ide.Plugin.Pragmas @@ -70,6 +71,7 @@ library , extra , filepath , floskell == 0.10.* + , fourmolu ^>= 0.1 , ghc , ghc-boot-th , ghcide >= 0.1 diff --git a/src/Ide/Plugin/Fourmolu.hs b/src/Ide/Plugin/Fourmolu.hs new file mode 100644 index 0000000000..07d4272b95 --- /dev/null +++ b/src/Ide/Plugin/Fourmolu.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Ide.Plugin.Fourmolu + ( + descriptor + , provider + ) +where + +import Control.Exception +import qualified Data.Text as T +import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession)) +import Development.IDE.Core.Shake (use) +import Development.IDE.GHC.Util (hscEnv) +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import qualified DynFlags as D +import qualified EnumSet as S +import GHC +import GHC.LanguageExtensions.Type +import GhcPlugins (HscEnv (hsc_dflags)) +import Ide.Plugin.Formatter +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), + ProgressCancellable (Cancellable)) +import Language.Haskell.LSP.Types +import "fourmolu" Ormolu +import System.FilePath (takeFileName) +import Text.Regex.TDFA.Text () + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- --------------------------------------------------------------------- + +provider :: FormattingProvider IO +provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do + let + fromDyn :: DynFlags -> IO [DynOption] + fromDyn df = + let + pp = + let p = D.sPgm_F $ D.settings df + in if null p then [] else ["-pgmF=" <> p] + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df + ex = map showExtension $ S.toList $ D.extensionFlags df + in + return $ map DynOption $ pp <> pm <> ex + + ghc <- runAction "Fourmolu" ideState $ use GhcSession fp + let df = hsc_dflags . hscEnv <$> ghc + fileOpts <- case df of + Nothing -> return [] + Just df -> fromDyn df + + let + fullRegion = RegionIndices Nothing Nothing + rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1) + mkConf o region = do + printerOpts <- loadConfigFile True (Just fp') defaultPrinterOpts + return $ defaultConfig + { cfgDynOptions = o + , cfgRegion = region + , cfgDebug = True + , cfgPrinterOpts = printerOpts + } + fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) + fmt cont conf = + try @OrmoluException (ormolu conf fp' $ T.unpack cont) + fp' = fromNormalizedFilePath fp + + case typ of + FormatText -> ret <$> (fmt contents =<< mkConf fileOpts fullRegion) + FormatRange (Range (Position sl _) (Position el _)) -> + ret <$> (fmt contents =<< mkConf fileOpts (rangeRegion sl el)) + where + title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) + ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) + ret (Left err) = Left + (responseError (T.pack $ "fourmoluCmd: " ++ show err) ) + ret (Right new) = Right (makeDiffTextEdit contents new) + +showExtension :: Extension -> String +showExtension Cpp = "-XCPP" +showExtension other = "-X" ++ show other diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index dcfad0b16a..e5d268232b 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -29,7 +30,7 @@ import Ide.Types import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), ProgressCancellable (Cancellable)) import Language.Haskell.LSP.Types -import Ormolu +import "ormolu" Ormolu import System.FilePath (takeFileName) import Text.Regex.TDFA.Text () diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index bc51cd64b9..40cca07500 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -13,6 +13,7 @@ extra-deps: - cabal-plan-0.7.0.0 - clock-0.7.2 - floskell-0.10.3 +- fourmolu-0.1.0.0 - ghc-exactprint-0.6.3 - lens-4.19.1 - lsp-test-0.11.0.3 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 082611ddb4..2c5f4a0e2c 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -20,6 +20,7 @@ extra-deps: # - ghcide-0.1.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.1.0.0 - fuzzy-0.1.0.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.2 # for HaRe diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 771d6f3882..31af05e0c3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -17,6 +17,7 @@ extra-deps: - clock-0.7.2 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.1.0.0 - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 99e5c20f3b..0e39a2234f 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -16,6 +16,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-lib-parser-8.10.1.20200523 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index b972a17e4e..3541d5face 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -15,6 +15,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.1.0.0 # - ghcide-0.1.0 - haskell-src-exts-1.21.1 - hie-bios-0.6.1 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 59d3327346..349add4c32 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -17,6 +17,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - extra-1.7.3 - floskell-0.10.3 +- fourmolu-0.1.0.0 # - ghcide-0.1.0 - haskell-src-exts-1.21.1 - hie-bios-0.6.1 diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 11fc65123d..0ebac31071 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -36,6 +36,7 @@ tests = testGroup "format document" [ , brittanyTests #endif , ormoluTests + , fourmoluTests ] rangeTests :: TestTree @@ -159,6 +160,20 @@ ormoluTests = testGroup "ormolu" BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] +fourmoluTests :: TestTree +fourmoluTests = testGroup "fourmolu" + [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.fourmolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 4 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.fourmolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format2.hs" "haskell" + formatDoc doc (FormattingOptions 4 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + formatLspConfig :: Value -> Value formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] diff --git a/test/testdata/Format.fourmolu.formatted.hs b/test/testdata/Format.fourmolu.formatted.hs new file mode 100644 index 0000000000..41dba5b34d --- /dev/null +++ b/test/testdata/Format.fourmolu.formatted.hs @@ -0,0 +1,16 @@ +module Format where + +import Data.Int +import Data.List +import Prelude + +foo :: Int -> Int +foo 3 = 2 +foo x = x + +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz {a :: Int, b :: String} diff --git a/test/testdata/Format2.fourmolu.formatted.hs b/test/testdata/Format2.fourmolu.formatted.hs new file mode 100644 index 0000000000..b3d867e700 --- /dev/null +++ b/test/testdata/Format2.fourmolu.formatted.hs @@ -0,0 +1,5 @@ +import Data.Bool +import Data.Char +import Data.Data +import Data.Either +import Data.Int