Skip to content

Commit 3ceed4d

Browse files
isovectorjneiraberberman
authored
Allow for customizable Haskell views of Property types (#1608)
* Allow for customizable Haskell views of Property types * Use the enum support directly in TypeLenses * Use lists instead of vector to avoid a new dependency Co-authored-by: Javier Neira <atreyu.bbb@gmail.com> Co-authored-by: Potato Hatsue <1793913507@qq.com>
1 parent 7255b40 commit 3ceed4d

File tree

2 files changed

+55
-49
lines changed

2 files changed

+55
-49
lines changed

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

Lines changed: 20 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -14,8 +14,10 @@ module Development.IDE.Plugin.TypeLenses (
1414

1515
import Avail (availsToNameSet)
1616
import Control.DeepSeq (rwhnf)
17+
import Control.Monad (mzero)
1718
import Control.Monad.Extra (whenMaybe)
1819
import Control.Monad.IO.Class (MonadIO (liftIO))
20+
import qualified Data.Aeson.Types as A
1921
import Data.Aeson.Types (Value (..), toJSON)
2022
import qualified Data.HashMap.Strict as Map
2123
import Data.List (find)
@@ -91,21 +93,21 @@ descriptor plId =
9193
, pluginCustomConfig = mkCustomConfig properties
9294
}
9395

94-
properties :: Properties '[ 'PropertyKey "mode" 'TEnum]
96+
properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
9597
properties = emptyProperties
9698
& defineEnumProperty #mode "Control how type lenses are shown"
97-
[ ("always", "Always displays type lenses of global bindings")
98-
, ("exported", "Only display type lenses of exported global bindings")
99-
, ("diagnostics", "Follows error messages produced by GHC about missing signatures")
100-
] "always"
99+
[ (Always, "Always displays type lenses of global bindings")
100+
, (Exported, "Only display type lenses of exported global bindings")
101+
, (Diagnostics, "Follows error messages produced by GHC about missing signatures")
102+
] Always
101103

102104
codeLensProvider ::
103105
IdeState ->
104106
PluginId ->
105107
CodeLensParams ->
106108
LSP.LspM Config (Either ResponseError (List CodeLens))
107109
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
108-
mode <- readMode <$> usePropertyLsp #mode pId properties
110+
mode <- usePropertyLsp #mode pId properties
109111
fmap (Right . List) $ case uriToFilePath' uri of
110112
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
111113
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
@@ -209,6 +211,18 @@ data Mode
209211
Diagnostics
210212
deriving (Eq, Ord, Show, Read, Enum)
211213

214+
instance A.ToJSON Mode where
215+
toJSON Always = "always"
216+
toJSON Exported = "exported"
217+
toJSON Diagnostics = "diagnostics"
218+
219+
instance A.FromJSON Mode where
220+
parseJSON = A.withText "Mode" $ \case
221+
"always" -> pure Always
222+
"exported" -> pure Exported
223+
"diagnostics" -> pure Diagnostics
224+
_ -> mzero
225+
212226
--------------------------------------------------------------------------------
213227

214228
showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String
@@ -245,14 +259,6 @@ rules = do
245259
result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr)
246260
pure ([], result)
247261

248-
readMode :: T.Text -> Mode
249-
readMode = \case
250-
"always" -> Always
251-
"exported" -> Exported
252-
"diagnostics" -> Diagnostics
253-
-- actually it never happens because of 'usePropertyLsp'
254-
_ -> error "failed to parse type lenses mode"
255-
256262
gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
257263
gblBindingType (Just hsc) (Just gblEnv) = do
258264
let exports = availsToNameSet $ tcg_exports gblEnv

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

Lines changed: 35 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -46,8 +46,9 @@ import qualified Data.Aeson as A
4646
import qualified Data.Aeson.Types as A
4747
import Data.Either (fromRight)
4848
import Data.Function ((&))
49-
import Data.Kind (Constraint)
49+
import Data.Kind (Constraint, Type)
5050
import qualified Data.Map.Strict as Map
51+
import Data.Proxy (Proxy (..))
5152
import qualified Data.Text as T
5253
import GHC.OverloadedLabels (IsLabel (..))
5354
import GHC.TypeLits
@@ -59,18 +60,18 @@ data PropertyType
5960
| TInteger
6061
| TString
6162
| TBoolean
62-
| TObject
63-
| TArray
64-
| TEnum
63+
| TObject Type
64+
| TArray Type
65+
| TEnum Type
6566

6667
type family ToHsType (t :: PropertyType) where
6768
ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values
6869
ToHsType 'TInteger = Int -- so here we use Double for Number, Int for Integer
6970
ToHsType 'TString = T.Text
7071
ToHsType 'TBoolean = Bool
71-
ToHsType 'TObject = A.Object
72-
ToHsType 'TArray = A.Array
73-
ToHsType 'TEnum = T.Text -- supports only text enum now
72+
ToHsType ('TObject a) = a
73+
ToHsType ('TArray a) = [a]
74+
ToHsType ('TEnum a) = a
7475

7576
-- ---------------------------------------------------------------------
7677

@@ -100,9 +101,9 @@ data SPropertyKey (k :: PropertyKey) where
100101
SInteger :: SPropertyKey ('PropertyKey s 'TInteger)
101102
SString :: SPropertyKey ('PropertyKey s 'TString)
102103
SBoolean :: SPropertyKey ('PropertyKey s 'TBoolean)
103-
SObject :: SPropertyKey ('PropertyKey s 'TObject)
104-
SArray :: SPropertyKey ('PropertyKey s 'TArray)
105-
SEnum :: SPropertyKey ('PropertyKey s 'TEnum)
104+
SObject :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TObject a))
105+
SArray :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TArray a))
106+
SEnum :: (A.ToJSON a, A.FromJSON a, Eq a, Show a) => Proxy a -> SPropertyKey ('PropertyKey s ('TEnum a))
106107

107108
-- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData'
108109
data SomePropertyKeyWithMetaData
@@ -126,7 +127,7 @@ instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where
126127
-- ---------------------------------------------------------------------
127128

128129
type family IsTEnum (t :: PropertyType) :: Bool where
129-
IsTEnum 'TEnum = 'True
130+
IsTEnum ('TEnum _) = 'True
130131
IsTEnum _ = 'False
131132

132133
type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where
@@ -234,9 +235,9 @@ parseProperty kn k x = case k of
234235
(SInteger, _) -> parseEither
235236
(SString, _) -> parseEither
236237
(SBoolean, _) -> parseEither
237-
(SObject, _) -> parseEither
238-
(SArray, _) -> parseEither
239-
(SEnum, EnumMetaData {..}) ->
238+
(SObject _, _) -> parseEither
239+
(SArray _, _) -> parseEither
240+
(SEnum _, EnumMetaData {..}) ->
240241
A.parseEither
241242
( \o -> do
242243
txt <- o A..: keyName
@@ -245,7 +246,7 @@ parseProperty kn k x = case k of
245246
else
246247
fail $
247248
"invalid enum member: "
248-
<> T.unpack txt
249+
<> show txt
249250
<> ". Expected one of "
250251
<> show enumValues
251252
)
@@ -311,44 +312,43 @@ defineBooleanProperty kn description defaultValue =
311312

312313
-- | Defines an object property
313314
defineObjectProperty ::
314-
forall s r.
315-
(KnownSymbol s, NotElem s r) =>
315+
(KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) =>
316316
KeyNameProxy s ->
317317
-- | description
318318
T.Text ->
319319
-- | default value
320-
A.Object ->
320+
a ->
321321
Properties r ->
322-
Properties ('PropertyKey s 'TObject : r)
322+
Properties ('PropertyKey s ('TObject a) : r)
323323
defineObjectProperty kn description defaultValue =
324-
insert kn SObject MetaData {..}
324+
insert kn (SObject Proxy) MetaData {..}
325325

326326
-- | Defines an array property
327327
defineArrayProperty ::
328-
(KnownSymbol s, NotElem s r) =>
328+
(KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) =>
329329
KeyNameProxy s ->
330330
-- | description
331331
T.Text ->
332332
-- | default value
333-
A.Array ->
333+
[a] ->
334334
Properties r ->
335-
Properties ('PropertyKey s 'TArray : r)
335+
Properties ('PropertyKey s ('TArray a) : r)
336336
defineArrayProperty kn description defaultValue =
337-
insert kn SArray MetaData {..}
337+
insert kn (SArray Proxy) MetaData {..}
338338

339339
-- | Defines an enum property
340340
defineEnumProperty ::
341-
(KnownSymbol s, NotElem s r) =>
341+
(KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a, Eq a, Show a) =>
342342
KeyNameProxy s ->
343343
-- | description
344344
T.Text ->
345345
-- | valid enum members with each of description
346-
[(T.Text, T.Text)] ->
347-
T.Text ->
346+
[(a, T.Text)] ->
347+
a ->
348348
Properties r ->
349-
Properties ('PropertyKey s 'TEnum : r)
349+
Properties ('PropertyKey s ('TEnum a) : r)
350350
defineEnumProperty kn description enums defaultValue =
351-
insert kn SEnum $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums)
351+
insert kn (SEnum Proxy) $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums)
352352

353353
-- ---------------------------------------------------------------------
354354

@@ -366,11 +366,11 @@ toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]
366366
s A..= defaultValue
367367
(SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->
368368
s A..= defaultValue
369-
(SomePropertyKeyWithMetaData SObject MetaData {..}) ->
369+
(SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->
370370
s A..= defaultValue
371-
(SomePropertyKeyWithMetaData SArray MetaData {..}) ->
371+
(SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->
372372
s A..= defaultValue
373-
(SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) ->
373+
(SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->
374374
s A..= defaultValue
375375

376376
-- | Converts a properties definition into kv pairs as vscode schema
@@ -408,21 +408,21 @@ toVSCodeExtensionSchema prefix (Properties p) =
408408
"default" A..= defaultValue,
409409
"scope" A..= A.String "resource"
410410
]
411-
(SomePropertyKeyWithMetaData SObject MetaData {..}) ->
411+
(SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->
412412
A.object
413413
[ "type" A..= A.String "object",
414414
"markdownDescription" A..= description,
415415
"default" A..= defaultValue,
416416
"scope" A..= A.String "resource"
417417
]
418-
(SomePropertyKeyWithMetaData SArray MetaData {..}) ->
418+
(SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->
419419
A.object
420420
[ "type" A..= A.String "array",
421421
"markdownDescription" A..= description,
422422
"default" A..= defaultValue,
423423
"scope" A..= A.String "resource"
424424
]
425-
(SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) ->
425+
(SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->
426426
A.object
427427
[ "type" A..= A.String "string",
428428
"description" A..= description,

0 commit comments

Comments
 (0)