Add support for brittany (needs aeson-2) and floskell with ghc-9.0.1 (#…

…2551)

* Enable tests for brittany and 9.0.2

* Enable tests for floskell plugin

* cabal-ghc901.project: naively enable brittany

* haskell-language-server.cabal: bump brittany flag <(9.0.1->9.2.1)

* Trying to add support for brittany

* Use last hackage floskell version

* Activate floskell in func-test suite

* Restrict brittany in hackage for ghc<9.0.1

* Adapt to Aeson.Key

* Update lsp source repo package

* Refer pr for butcher

* Add missing prefix

* Adapt to aeson-2 (incomplete)

* Use compat module

* Support for aeson-2 and extra-1.7.10

* Remove lsp

* Allow newer aeson for stylish-haskell

* Add needed import for non windows

* Remove insertJson and toJsonKey

* Update cabal-ghc901.project

* Missing import

* Avoid CPP by using lens-aeson

* Update hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs

* Use ghcide compat module

* Use type alias in cpp

* Fix stack build for ghc-8.6.5

* Use lens-aeson key

* Use lens-aeson in func-test

* Fixup shake-bench

* Update docs

* Switch to lens ix

* Try this

Co-authored-by: Anton-Latukha <anton.latukha@gmail.com>
Co-authored-by: Michael Peyton Jones <me@michaelpj.com>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

.github/workflows/test.yml

@@ -144,7 +144,7 @@ jobs:
 
         run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper" || cabal test wrapper-test --test-options="$TEST_OPTS  --rerun-log-file .tasty-rerun-log-wrapper" || cabal test wrapper-test --test-options="$TEST_OPTS  --rerun-log-file .tasty-rerun-log-wrapper"
 
-      - if: matrix.test && matrix.ghc != '9.0.1'
+      - if: matrix.test
         name: Test hls-brittany-plugin
         run: cabal test hls-brittany-plugin --test-options="$TEST_OPTS" || cabal test hls-brittany-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-brittany-plugin --test-options="$TEST_OPTS"
 

cabal-ghc901.project

@@ -41,22 +41,25 @@ index-state: 2021-12-29T12:30:08Z
 
 constraints:
   -- These plugins don't work on GHC9 yet
-  haskell-language-server +ignore-plugins-ghc-bounds -brittany -stylishhaskell -tactic,
+  -- Add a plugin needs remove the -flag but also update ghc bounds in hls.cabal
+  haskell-language-server +ignore-plugins-ghc-bounds -stylishhaskell -tactic,
   ghc-lib-parser ^>= 9.0
 
 -- although we are not building all plugins cabal solver phase is run for all packages
 -- this way we track explicitly all transitive dependencies which need support for ghc-9
 allow-newer:
-    brittany:base,
-    brittany:ghc,
-    brittany:ghc-boot-th,
-    -- for brittany
-    butcher:base,
+
+    -- brittany: update ghc bounds in hls.cabal when those are removed
+    -- https://github.com/lspitzner/multistate/pull/8
     multistate:base,
+    -- https://github.com/lspitzner/data-tree-print/pull/3
     data-tree-print:base,
+    -- https://github.com/lspitzner/butcher/pull/8
+    butcher:base,
 
     stylish-haskell:Cabal,
     stylish-haskell:ghc-lib-parser,
+    stylish-haskell:aeson,
 
     floskell:base,
     floskell:ghc-prim,

ghcide/ghcide.cabal

@@ -49,8 +49,7 @@ library
         dependent-sum,
         dlist,
         exceptions,
-        -- we can't use >= 1.7.10 while we have to use hlint == 3.2.*
-        extra >= 1.7.4 && < 1.7.10,
+        extra >= 1.7.4,
         fuzzy,
         filepath,
         fingertree,

ghcide/src/Control/Concurrent/Strict.hs

@@ -4,31 +4,32 @@ module Control.Concurrent.Strict
     ,module Control.Concurrent.Extra
     ) where
 
-import           Control.Concurrent.Extra hiding (modifyVar, modifyVar_)
+import           Control.Concurrent.Extra hiding (modifyVar, modifyVar',
+                                           modifyVar_)
 import qualified Control.Concurrent.Extra as Extra
 import           Control.Exception        (evaluate)
 import           Control.Monad            (void)
 import           Data.Tuple.Extra         (dupe)
 
 -- | Strict modification that returns the new value
-modifyVar' :: Var a -> (a -> a) -> IO a
+modifyVar' :: Extra.Var a -> (a -> a) -> IO a
 modifyVar' var upd = modifyVarIO' var (pure . upd)
 
 -- | Strict modification that returns the new value
-modifyVarIO' :: Var a -> (a -> IO a) -> IO a
+modifyVarIO' :: Extra.Var a -> (a -> IO a) -> IO a
 modifyVarIO' var upd = do
     res <- Extra.modifyVar var $ \v -> do
         v' <- upd v
         pure $ dupe v'
     evaluate res
 
-modifyVar :: Var a -> (a -> IO (a, b)) -> IO b
+modifyVar :: Extra.Var a -> (a -> IO (a, b)) -> IO b
 modifyVar var upd = do
     (new, res) <- Extra.modifyVar var $ \old -> do
         (new,res) <- upd old
         return (new, (new, res))
     void $ evaluate new
     return res
 
-modifyVar_ :: Var a -> (a -> IO a) -> IO ()
+modifyVar_ :: Extra.Var a -> (a -> IO a) -> IO ()
 modifyVar_ var upd = void $ modifyVarIO' var upd

ghcide/src/Development/IDE/GHC/Orphans.hs

@@ -36,7 +36,6 @@ import           Control.DeepSeq
 import           Data.Aeson
 import           Data.Hashable
 import           Data.String                (IsString (fromString))
-import           Data.Text                  (Text)
 
 -- Orphan instances for types from the GHC API.
 instance Show CoreModule where show = prettyPrint
@@ -122,7 +121,7 @@ instance NFData RealSrcSpan where
     rnf = rwhnf
 
 srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,
-    srcSpanEndLineTag, srcSpanEndColTag :: Text
+    srcSpanEndLineTag, srcSpanEndColTag :: String
 srcSpanFileTag = "srcSpanFile"
 srcSpanStartLineTag = "srcSpanStartLine"
 srcSpanStartColTag = "srcSpanStartCol"
@@ -132,24 +131,24 @@ srcSpanEndColTag = "srcSpanEndCol"
 instance ToJSON RealSrcSpan where
   toJSON spn =
       object
-        [ srcSpanFileTag .= unpackFS (srcSpanFile spn)
-        , srcSpanStartLineTag .= srcSpanStartLine spn
-        , srcSpanStartColTag .= srcSpanStartCol spn
-        , srcSpanEndLineTag .= srcSpanEndLine spn
-        , srcSpanEndColTag .= srcSpanEndCol spn
+        [ fromString srcSpanFileTag .= unpackFS (srcSpanFile spn)
+        , fromString srcSpanStartLineTag .= srcSpanStartLine spn
+        , fromString srcSpanStartColTag .= srcSpanStartCol spn
+        , fromString srcSpanEndLineTag .= srcSpanEndLine spn
+        , fromString srcSpanEndColTag .= srcSpanEndCol spn
         ]
 
 instance FromJSON RealSrcSpan where
   parseJSON = withObject "object" $ \obj -> do
-      file <- fromString <$> (obj .: srcSpanFileTag)
+      file <- fromString <$> (obj .: fromString srcSpanFileTag)
       mkRealSrcSpan
         <$> (mkRealSrcLoc file
-                <$> obj .: srcSpanStartLineTag
-                <*> obj .: srcSpanStartColTag
+                <$> obj .: fromString srcSpanStartLineTag
+                <*> obj .: fromString srcSpanStartColTag
             )
         <*> (mkRealSrcLoc file
-                <$> obj .: srcSpanEndLineTag
-                <*> obj .: srcSpanEndColTag
+                <$> obj .: fromString srcSpanEndLineTag
+                <*> obj .: fromString srcSpanEndColTag
             )
 
 instance NFData Type where

haskell-language-server.cabal

@@ -283,7 +283,7 @@ common qualifyImportedNames
 -- formatters
 
 common floskell
-  if flag(floskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds))
+  if flag(floskell) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds))
     build-depends: hls-floskell-plugin ^>=1.0.0.0
     cpp-options: -Dfloskell
 
@@ -433,6 +433,7 @@ test-suite func-test
     , data-default
     , hspec-expectations
     , lens
+    , lens-aeson
     , ghcide
     , hls-test-utils ^>= 1.1.0.0
     , lsp-types
@@ -472,7 +473,7 @@ test-suite func-test
   if flag(eval)
     cpp-options: -Deval
 -- formatters
-  if flag(floskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds))
+  if flag(floskell) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds))
     cpp-options: -Dfloskell
   if flag(fourmolu) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds))
     cpp-options: -Dfourmolu

hls-plugin-api/hls-plugin-api.cabal

@@ -49,6 +49,7 @@ library
     , hls-graph             >=1.4 && < 1.6
     , hslogger
     , lens
+    , lens-aeson
     , lsp                   ^>=1.4.0.0
     , opentelemetry
     , optparse-applicative

hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs

@@ -5,13 +5,16 @@
 
 module Ide.Plugin.ConfigUtils where
 
+import           Control.Lens          (at, ix, (&), (?~))
 import qualified Data.Aeson            as A
+import           Data.Aeson.Lens       (_Object)
 import qualified Data.Aeson.Types      as A
 import           Data.Default          (def)
 import qualified Data.Dependent.Map    as DMap
 import qualified Data.Dependent.Sum    as DSum
-import qualified Data.HashMap.Lazy     as HMap
 import           Data.List             (nub)
+import           Data.String           (IsString (fromString))
+import qualified Data.Text             as T
 import           Ide.Plugin.Config
 import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
 import           Ide.Types
@@ -25,17 +28,12 @@ import           Language.LSP.Types
 -- | Generates a default 'Config', but remains only effective items
 pluginsToDefaultConfig :: IdePlugins a -> A.Value
 pluginsToDefaultConfig IdePlugins {..} =
-  A.Object $
-    HMap.adjust
-      ( \(unsafeValueToObject -> o) ->
-          A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged
-      )
-      "haskell"
-      (unsafeValueToObject (A.toJSON defaultConfig))
+  -- Use 'ix' to look at all the "haskell" keys in the outer value (since we're not
+  -- setting it if missing), then we use '_Object' and 'at' to get at the "plugin" key
+  -- and actually set it.
+  A.toJSON defaultConfig & ix "haskell" . _Object . at "plugin" ?~ elems
   where
     defaultConfig@Config {} = def
-    unsafeValueToObject (A.Object o) = o
-    unsafeValueToObject _            = error "impossible"
     elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap
     -- Splice genericDefaultConfig and dedicatedDefaultConfig
     -- Example:
@@ -52,7 +50,7 @@ pluginsToDefaultConfig IdePlugins {..} =
     -- }
     singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
       let x = genericDefaultConfig <> dedicatedDefaultConfig
-       in [pId A..= A.object x | not $ null x]
+       in [fromString (T.unpack pId) A..= A.object x | not $ null x]
       where
         (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
         customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p
@@ -107,22 +105,22 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug
         (PluginId pId) = pluginId
         genericSchema =
           let x =
-                [withIdPrefix "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics]
+                [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics]
                   <> nub (mconcat (handlersToGenericSchema <$> handlers))
            in case x of
                 -- If the plugin has only one capability, we produce globalOn instead of the specific one;
                 -- otherwise we don't produce globalOn at all
-                [_] -> [withIdPrefix "globalOn" A..= schemaEntry "plugin"]
+                [_] -> [toKey' "globalOn" A..= schemaEntry "plugin"]
                 _   -> x
         dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
         handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of
-          STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"]
-          STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"]
-          STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"]
-          STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"]
-          STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"]
-          STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"]
-          STextDocumentPrepareCallHierarchy -> [withIdPrefix "callHierarchyOn" A..= schemaEntry "call hierarchy"]
+          STextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"]
+          STextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"]
+          STextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"]
+          STextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"]
+          STextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"]
+          STextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"]
+          STextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"]
           _ -> []
         schemaEntry desc =
           A.object
@@ -132,3 +130,4 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug
               "description" A..= A.String ("Enables " <> pId <> " " <> desc)
             ]
         withIdPrefix x = "haskell.plugin." <> pId <> "." <> x
+        toKey' = fromString . T.unpack . withIdPrefix

hls-plugin-api/src/Ide/Plugin/Properties.hs

@@ -11,7 +11,6 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
-{-# LANGUAGE ViewPatterns          #-}
 -- See Note [Constraints]
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
@@ -47,6 +46,7 @@ import           Data.Function        ((&))
 import           Data.Kind            (Constraint, Type)
 import qualified Data.Map.Strict      as Map
 import           Data.Proxy           (Proxy (..))
+import           Data.String          (IsString (fromString))
 import qualified Data.Text            as T
 import           GHC.OverloadedLabels (IsLabel (..))
 import           GHC.TypeLits
@@ -162,6 +162,7 @@ type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~
 --      "Description of exampleNumber"
 --      233
 -- @
+
 emptyProperties :: Properties '[]
 emptyProperties = Properties Map.empty
 
@@ -235,7 +236,7 @@ parseProperty kn k x = case k of
   (SEnum _, EnumMetaData {..}) ->
     A.parseEither
       ( \o -> do
-          txt <- o A..: keyName
+          txt <- o A..: key
           if txt `elem` enumValues
             then pure txt
             else
@@ -247,9 +248,9 @@ parseProperty kn k x = case k of
       )
       x
   where
-    keyName = T.pack $ symbolVal kn
+    key = fromString $ symbolVal kn
     parseEither :: forall a. A.FromJSON a => Either String a
-    parseEither = A.parseEither (A..: keyName) x
+    parseEither = A.parseEither (A..: key) x
 
 -- ---------------------------------------------------------------------
 
@@ -352,26 +353,26 @@ toDefaultJSON :: Properties r -> [A.Pair]
 toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]
   where
     toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair
-    toEntry (T.pack -> s) = \case
+    toEntry s = \case
       (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData SString MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
       (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->
-        s A..= defaultValue
+        fromString s A..= defaultValue
 
 -- | Converts a properties definition into kv pairs as vscode schema
 toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair]
 toVSCodeExtensionSchema prefix (Properties p) =
-  [(prefix <> T.pack k) A..= toEntry v | (k, v) <- Map.toList p]
+  [fromString (T.unpack prefix <> k) A..= toEntry v | (k, v) <- Map.toList p]
   where
     toEntry :: SomePropertyKeyWithMetaData -> A.Value
     toEntry = \case

hls-plugin-api/src/Ide/Types.hs

@@ -24,11 +24,11 @@ module Ide.Types
 #ifdef mingw32_HOST_OS
 import qualified System.Win32.Process            as P (getCurrentProcessId)
 #else
+import           Control.Monad                   (void)
 import qualified System.Posix.Process            as P (getProcessID)
 import           System.Posix.Signals
 #endif
 import           Control.Lens                    ((^.))
-import           Control.Monad
 import           Data.Aeson                      hiding (defaultOptions)
 import qualified Data.DList                      as DList
 import qualified Data.Default

plugins/hls-brittany-plugin/hls-brittany-plugin.cabal

@@ -23,7 +23,6 @@ library
     , base            >=4.12     && <5
     , brittany        >=0.13.1.0
     , filepath
-    , ghc
     , ghc-boot-th
     , ghcide          >=1.2      && <1.6
     , hls-plugin-api  >=1.1      && <1.3