Use compat module

Author: jneira

ghcide/src/Control/Concurrent/Strict.hs

@@ -1,34 +1,32 @@
 module Control.Concurrent.Strict
     (modifyVar', modifyVarIO'
     ,modifyVar, modifyVar_
-    ,module Control.Concurrent.Extra
     ) where
 
-import           Control.Concurrent.Extra hiding (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

@@ -31,6 +31,7 @@ import           Retrie.ExactPrint          (Annotated)
 
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Util
+import           Ide.Compat                 (toJsonKey)
 
 import           Control.DeepSeq
 import           Data.Aeson
@@ -132,11 +133,11 @@ 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
+        [ toJsonKey srcSpanFileTag .= unpackFS (srcSpanFile spn)
+        , toJsonKey srcSpanStartLineTag .= srcSpanStartLine spn
+        , toJsonKey srcSpanStartColTag .= srcSpanStartCol spn
+        , toJsonKey srcSpanEndLineTag .= srcSpanEndLine spn
+        , toJsonKey srcSpanEndColTag .= srcSpanEndCol spn
         ]
 
 instance FromJSON RealSrcSpan where

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

@@ -26,6 +26,7 @@ source-repository head
 
 library
   exposed-modules:
+    Ide.Compat
     Ide.Logger
     Ide.Plugin.Config
     Ide.Plugin.ConfigUtils

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

@@ -0,0 +1,27 @@
+{-# LANGUAGE CPP               #-}
+module Ide.Compat where
+
+#if MIN_VERSION_aeson(2,0,0)
+import           Data.Aeson.Key             as A (Key)
+import qualified Data.Aeson.Key             as A.Key
+import qualified Data.Aeson.KeyMap          as Map
+#else
+import qualified Data.HashMap.Lazy          as Map
+#endif
+import           Data.Text                  as T
+
+#if MIN_VERSION_aeson(2,0,0)
+toJsonKey :: T.Text -> A.Key
+toJsonKey = A.Key.fromText
+#else
+toJsonKey :: T.Text -> T.Text
+toJsonKey = id
+#endif
+
+#if MIN_VERSION_aeson(2,0,0)
+toJsonKey :: T.Text -> A.Key
+toJsonKey = A.Key.fromText
+#else
+toJsonKey :: T.Text -> T.Text
+toJsonKey = id
+#endif

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP               #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
@@ -11,29 +10,17 @@ 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
-#if MIN_VERSION_aeson(2,0,0)
-import qualified Data.Aeson.Key        as A.Key
-import qualified Data.Aeson.KeyMap     as Map
-#else
-import qualified Data.HashMap.Lazy     as Map
-#endif
 import           Data.Functor.Identity
+import qualified Data.HashMap.Lazy     as Map
 import           Data.List             (nub)
 import           Data.Maybe            (fromJust)
 import           Data.Text             (Text)
+import           Ide.Compat            (toKey)
 import           Ide.Plugin.Config
 import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
 import           Ide.Types
 import           Language.LSP.Types
 
-#if MIN_VERSION_aeson(2,0,0)
-toKey :: Text -> A.Key
-toKey = A.Key.fromText
-#else
-toKey :: Text -> Text
-toKey = id
-#endif
-
 -- Attention:
 -- 'diagnosticsOn' will never be added into the default config or the schema,
 -- since diagnostics emit in arbitrary shake rules -- we don't know
@@ -124,22 +111,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
@@ -148,4 +135,5 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug
               "default" A..= True,
               "description" A..= A.String ("Enables " <> pId <> " " <> desc)
             ]
-        withIdPrefix x = toKey $ "haskell.plugin." <> pId <> "." <> x
+        withIdPrefix x = "haskell.plugin." <> pId <> "." <> x
+        toKey' = toJsonKey . withIdPrefix

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
@@ -42,9 +41,6 @@ module Ide.Plugin.Properties
 where
 
 import qualified Data.Aeson           as A
-#if MIN_VERSION_aeson(2,0,0)
-import qualified Data.Aeson.Key       as A.Key
-#endif
 import qualified Data.Aeson.Types     as A
 import           Data.Either          (fromRight)
 import           Data.Function        ((&))
@@ -54,6 +50,7 @@ import           Data.Proxy           (Proxy (..))
 import qualified Data.Text            as T
 import           GHC.OverloadedLabels (IsLabel (..))
 import           GHC.TypeLits
+import           Ide.Types            (toJsonKey)
 import           Unsafe.Coerce        (unsafeCoerce)
 
 -- | Types properties may have
@@ -167,14 +164,6 @@ type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~
 --      233
 -- @
 
-#if MIN_VERSION_aeson(2,0,0)
-toKey :: String -> A.Key
-toKey = A.Key.fromString
-#else
-toKey :: String -> T.Text
-toKey = T.pack
-#endif
-
 emptyProperties :: Properties '[]
 emptyProperties = Properties Map.empty
 
@@ -248,7 +237,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
@@ -260,7 +249,7 @@ parseProperty kn k x = case k of
       )
       x
   where
-    keyName = toKey $ symbolVal kn
+    key = toJsonKey . pack $ symbolVal kn
     parseEither :: forall a. A.FromJSON a => Either String a
     parseEither = A.parseEither (A..: keyName) x
 
@@ -365,7 +354,7 @@ toDefaultJSON :: Properties r -> [A.Pair]
 toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]
   where
     toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair
-    toEntry (toKey -> s) = \case
+    toEntry (toJsonKey . pack -> s) = \case
       (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->
         s A..= defaultValue
       (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->
@@ -384,7 +373,7 @@ toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]
 -- | Converts a properties definition into kv pairs as vscode schema
 toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair]
 toVSCodeExtensionSchema prefix (Properties p) =
-  [(toKey $ T.unpack prefix <> k) A..= toEntry v | (k, v) <- Map.toList p]
+  [(toJsonKey prefix <> k) A..= toEntry v | (k, v) <- Map.toList p]
   where
     toEntry :: SomePropertyKeyWithMetaData -> A.Value
     toEntry = \case