Skip to content

Properties API: Remove unsafe coerce in favor of type class based method in #3947

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Jan 13, 2024
Merged

Properties API: Remove unsafe coerce in favor of type class based method in #3947

Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
b494b39
remove unsafe coerce to use type class based method
soulomoon Jan 13, 2024
18a8367
revert Elem to have better error display
soulomoon Jan 13, 2024
fd05577
clean up
soulomoon Jan 13, 2024
d09898e
clean up
soulomoon Jan 13, 2024
72d625a
remove redundant-constraints suppresion
soulomoon Jan 13, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
58 changes: 30 additions & 28 deletions hls-plugin-api/src/Ide/Plugin/Properties.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- See Note [Constraints]
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Ide.Plugin.Properties
( PropertyType (..),
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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

-- ---------------------------------------------------------------------

Expand All @@ -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) =>
Expand All @@ -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

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down