Merge branch 'master' into jhrcek/cleanup-cabal-conditionals

Author: michaelpj

cabal.project

@@ -36,7 +36,7 @@ packages:
          ./plugins/hls-overloaded-record-dot-plugin
          ./plugins/hls-semantic-tokens-plugin
 
-index-state: 2024-01-05T19:06:05Z
+index-state: 2024-01-13T19:06:05Z
 
 tests: True
 test-show-details: direct

ghcide/ghcide.cabal

@@ -78,7 +78,7 @@ library
     , hashable
     , hie-bios                     ==0.13.1
     , hie-compat                   ^>=0.3.0.0
-    , hiedb                        >=0.4.4    && <0.4.5
+    , hiedb                        ^>= 0.5.0.1
     , hls-graph                    == 2.5.0.0
     , hls-plugin-api               == 2.5.0.0
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5

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

@@ -11,8 +11,6 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
--- See Note [Constraints]
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Ide.Plugin.Properties
   ( PropertyType (..),
@@ -44,13 +42,11 @@ import qualified Data.Aeson.Types     as A
 import           Data.Either          (fromRight)
 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
-import           Unsafe.Coerce        (unsafeCoerce)
 
 -- | Types properties may have
 data PropertyType
@@ -114,7 +110,10 @@ data SomePropertyKeyWithMetaData
 -- A property is an immediate child of the json object in each plugin's "config" section.
 -- It was designed to be compatible with vscode's settings UI.
 -- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'.
-newtype Properties (r :: [PropertyKey]) = Properties (Map.Map String SomePropertyKeyWithMetaData)
+data Properties (r :: [PropertyKey]) where
+    ConsProperties :: (k ~ 'PropertyKey s t, KnownSymbol s, NotElem s ks)
+        => KeyNameProxy s -> (SPropertyKey k) -> (MetaData t) -> Properties ks -> Properties (k : ks)
+    EmptyProperties :: Properties '[]
 
 -- | A proxy type in order to allow overloaded labels as properties' names at the call site
 data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy
@@ -132,6 +131,10 @@ type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType whe
   FindByKeyName s ('PropertyKey s t ': _) = t
   FindByKeyName s (_ ': xs) = FindByKeyName s xs
 
+type family IsPropertySymbol (s :: Symbol) (r :: PropertyKey) :: Bool where
+    IsPropertySymbol s ('PropertyKey s _) = 'True
+    IsPropertySymbol s _ = 'False
+
 type family Elem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where
   Elem s ('PropertyKey s _ ': _) = ()
   Elem s (_ ': xs) = Elem s xs
@@ -143,7 +146,17 @@ type family NotElem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where
   NotElem s '[] = ()
 
 -- | In row @r@, there is a 'PropertyKey' @k@, which has name @s@ and carries haskell type @t@
-type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s)
+type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s, FindPropertyMeta s r t)
+class FindPropertyMeta (s :: Symbol) (r :: [PropertyKey]) t where
+    findSomePropertyKeyWithMetaData :: KeyNameProxy s -> Properties r -> (SPropertyKey ('PropertyKey s t), MetaData t)
+instance (FindPropertyMetaIf (IsPropertySymbol symbol k) symbol k ks t) => FindPropertyMeta symbol (k : ks) t where
+  findSomePropertyKeyWithMetaData = findSomePropertyKeyWithMetaDataIf
+class (bool ~ IsPropertySymbol symbol k) => FindPropertyMetaIf bool symbol k ks t where
+  findSomePropertyKeyWithMetaDataIf :: KeyNameProxy symbol -> Properties (k : ks) -> (SPropertyKey ('PropertyKey symbol t), MetaData t)
+instance (k ~ 'PropertyKey s t) => FindPropertyMetaIf 'True s k ks t where
+  findSomePropertyKeyWithMetaDataIf _ (ConsProperties _ k m _) = (k, m)
+instance ('False ~ IsPropertySymbol s k, FindPropertyMeta s ks t) => FindPropertyMetaIf 'False s k ks t where
+  findSomePropertyKeyWithMetaDataIf s (ConsProperties _ _ _ ks) = findSomePropertyKeyWithMetaData s ks
 
 -- ---------------------------------------------------------------------
 
@@ -164,7 +177,7 @@ type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~
 -- @
 
 emptyProperties :: Properties '[]
-emptyProperties = Properties Map.empty
+emptyProperties = EmptyProperties
 
 insert ::
   (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) =>
@@ -173,30 +186,14 @@ insert ::
   MetaData t ->
   Properties r ->
   Properties (k ': r)
-insert kn key metadata (Properties old) =
-  Properties
-    ( Map.insert
-        (symbolVal kn)
-        (SomePropertyKeyWithMetaData key metadata)
-        old
-    )
+insert = ConsProperties
 
 find ::
   (HasProperty s k t r) =>
   KeyNameProxy s ->
   Properties r ->
   (SPropertyKey k, MetaData t)
-find kn (Properties p) = case p Map.! symbolVal kn of
-  (SomePropertyKeyWithMetaData sing metadata) ->
-    -- Note [Constraints]
-    -- It's safe to use unsafeCoerce here:
-    --   Since each property name is unique that the redefinition will be prevented by predication on the type level list,
-    --   the value we get from the name-indexed map must be exactly the singleton and metadata corresponding to the type.
-    -- We drop this information at type level: some of the above type families return '() :: Constraint',
-    -- so GHC will consider them as redundant.
-    -- But we encode it using semantically identical 'Map' at term level,
-    -- which avoids inducting on the list by defining a new type class.
-    unsafeCoerce (sing, metadata)
+find = findSomePropertyKeyWithMetaData
 
 -- ---------------------------------------------------------------------
 
@@ -350,7 +347,10 @@ defineEnumProperty kn description enums defaultValue =
 
 -- | Converts a properties definition into kv pairs with default values from 'MetaData'
 toDefaultJSON :: Properties r -> [A.Pair]
-toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]
+toDefaultJSON pr = case pr of
+    EmptyProperties -> []
+    ConsProperties keyNameProxy k m xs ->
+        toEntry (symbolVal keyNameProxy) (SomePropertyKeyWithMetaData k m) : toDefaultJSON xs
   where
     toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair
     toEntry s = \case
@@ -371,8 +371,10 @@ 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) =
-  [fromString (T.unpack prefix <> k) A..= toEntry v | (k, v) <- Map.toList p]
+toVSCodeExtensionSchema prefix ps = case ps of
+    EmptyProperties -> []
+    ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs ->
+       fromString (T.unpack prefix <> symbolVal keyNameProxy) A..= toEntry (SomePropertyKeyWithMetaData k m) : toVSCodeExtensionSchema prefix xs
   where
     toEntry :: SomePropertyKeyWithMetaData -> A.Value
     toEntry = \case

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs

@@ -11,8 +11,7 @@ module Ide.Plugin.CallHierarchy.Query (
 import qualified Data.Text                      as T
 import           Database.SQLite.Simple
 import           Development.IDE.GHC.Compat
-import           HieDb                          (HieDb (getConn), Symbol (..),
-                                                 toNsChar)
+import           HieDb                          (HieDb (getConn), Symbol (..))
 import           Ide.Plugin.CallHierarchy.Types
 
 incomingCalls :: HieDb -> Symbol -> IO [Vertex]
@@ -73,9 +72,9 @@ getSymbolPosition (getConn -> conn) Vertex{..} = do
             ]
         ) (occ, sl, sc, sl, el, ec, el)
 
-parseSymbol :: Symbol -> (String, String, String)
+parseSymbol :: Symbol -> (OccName, ModuleName, Unit)
 parseSymbol Symbol{..} =
-    let o = toNsChar (occNameSpace symName) : occNameString symName
-        m = moduleNameString $ moduleName symModule
-        u = unitString $ moduleUnit symModule
+    let o = symName
+        m = moduleName symModule
+        u = moduleUnit symModule
     in  (o, m, u)

plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs

@@ -83,10 +83,8 @@ hieAstSpanNames vf ast =
         inclusion a b = not $ exclusion a b
         exclusion :: Identifier -> IdentifierDetails a -> Bool
         exclusion idt IdentifierDetails {identInfo = infos} = case idt of
-          Left _ -> True
-          Right name ->
-            isDerivedOccName (nameOccName name)
-              || any isEvidenceContext (S.toList infos)
+          Left _  -> True
+          Right _ -> any isEvidenceContext (S.toList infos)
 
 -------------------------------------------------
 

plugins/hls-semantic-tokens-plugin/test/Main.hs

@@ -187,6 +187,7 @@ semanticTokensDataTypeTests =
     "get semantic Tokens"
     [ goldenWithSemanticTokens "simple datatype" "TDataType",
       goldenWithSemanticTokens "record" "TRecord",
+      goldenWithSemanticTokens "record" "TRecordDuplicateRecordFields",
       goldenWithSemanticTokens "datatype import" "TDatatypeImported",
       goldenWithSemanticTokens "datatype family" "TDataFamily",
       goldenWithSemanticTokens "GADT" "TGADT"

plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected

@@ -0,0 +1,4 @@
+5:6-9 TTypeCon "Foo"
+5:12-15 TDataCon "Foo"
+5:18-21 TRecField "boo"
+5:26-32 TTypeSyn "String"

plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields      #-}
+
+module TRecordDuplicateRecordFields where
+
+data Foo = Foo { boo :: !String } 

stack-lts21.yaml

@@ -45,7 +45,7 @@ allow-newer: true
 
 extra-deps:
 - floskell-0.11.1
-- hiedb-0.4.4.0
+- hiedb-0.5.0.1
 - hie-bios-0.13.1
 - implicit-hie-0.1.4.0
 - monad-dijkstra-0.1.1.3

stack.yaml

@@ -45,7 +45,7 @@ allow-newer: true
 extra-deps:
 - floskell-0.11.1
 - retrie-1.2.2
-- hiedb-0.4.4.0
+- hiedb-0.5.0.1
 - implicit-hie-0.1.4.0
 - hie-bios-0.13.1
 - lsp-2.3.0.0