Merge branch 'master' into ghc-9.2

Author: michaelpj

.github/workflows/test.yml

@@ -146,7 +146,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' && matrix.ghc != '9.2.1'
+      - if: matrix.test && matrix.ghc != '9.2.1'
         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

@@ -39,7 +39,6 @@ import           Data.Aeson
 import           Data.Bifunctor             (Bifunctor (..))
 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
@@ -138,7 +137,7 @@ instance NFData RealSrcSpan where
     rnf = rwhnf
 
 srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,
-    srcSpanEndLineTag, srcSpanEndColTag :: Text
+    srcSpanEndLineTag, srcSpanEndColTag :: String
 srcSpanFileTag = "srcSpanFile"
 srcSpanStartLineTag = "srcSpanStartLine"
 srcSpanStartColTag = "srcSpanStartCol"
@@ -148,24 +147,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

ghcide/test/exe/Main.hs

@@ -4538,6 +4538,15 @@ localCompletionTests = [
         ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)
         ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)
         ],
+    completionTest
+        "type family"
+        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"
+        ,"type family Bar a"
+        ,"a :: Ba"
+        ]
+        (Position 2 7)
+        [("Bar", CiStruct, "Bar", True, False, Nothing)
+        ],
     completionTest
         "class method"
         [

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