From 4217d839786df3860de105679ca70bec01b09d83 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 22 Mar 2021 19:33:31 -0700 Subject: [PATCH 1/3] Allow for customizable Haskell views of Property types --- .../src/Development/IDE/Plugin/TypeLenses.hs | 2 +- hls-plugin-api/src/Ide/Plugin/Properties.hs | 71 ++++++++++--------- 2 files changed, 37 insertions(+), 36 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 3088d6d221..f306e0a984 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -91,7 +91,7 @@ descriptor plId = , pluginCustomConfig = mkCustomConfig properties } -properties :: Properties '[ 'PropertyKey "mode" 'TEnum] +properties :: Properties '[ 'PropertyKey "mode" ('TEnum T.Text)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" [ ("always", "Always displays type lenses of global bindings") diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index ba2edb5f49..a1cf5750e6 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -46,9 +46,11 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.Either (fromRight) import Data.Function ((&)) -import Data.Kind (Constraint) +import Data.Kind (Constraint, Type) import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) import qualified Data.Text as T +import Data.Vector (Vector) import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits import Unsafe.Coerce (unsafeCoerce) @@ -59,18 +61,18 @@ data PropertyType | TInteger | TString | TBoolean - | TObject - | TArray - | TEnum + | TObject Type + | TArray Type + | TEnum Type type family ToHsType (t :: PropertyType) where ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values ToHsType 'TInteger = Int -- so here we use Double for Number, Int for Integer ToHsType 'TString = T.Text ToHsType 'TBoolean = Bool - ToHsType 'TObject = A.Object - ToHsType 'TArray = A.Array - ToHsType 'TEnum = T.Text -- supports only text enum now + ToHsType ('TObject a) = a + ToHsType ('TArray a) = Vector a + ToHsType ('TEnum a) = a -- --------------------------------------------------------------------- @@ -100,9 +102,9 @@ data SPropertyKey (k :: PropertyKey) where SInteger :: SPropertyKey ('PropertyKey s 'TInteger) SString :: SPropertyKey ('PropertyKey s 'TString) SBoolean :: SPropertyKey ('PropertyKey s 'TBoolean) - SObject :: SPropertyKey ('PropertyKey s 'TObject) - SArray :: SPropertyKey ('PropertyKey s 'TArray) - SEnum :: SPropertyKey ('PropertyKey s 'TEnum) + SObject :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TObject a)) + SArray :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TArray a)) + SEnum :: (A.ToJSON a, A.FromJSON a, Eq a, Show a) => Proxy a -> SPropertyKey ('PropertyKey s ('TEnum a)) -- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData' data SomePropertyKeyWithMetaData @@ -126,7 +128,7 @@ instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where -- --------------------------------------------------------------------- type family IsTEnum (t :: PropertyType) :: Bool where - IsTEnum 'TEnum = 'True + IsTEnum ('TEnum _) = 'True IsTEnum _ = 'False type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where @@ -234,9 +236,9 @@ parseProperty kn k x = case k of (SInteger, _) -> parseEither (SString, _) -> parseEither (SBoolean, _) -> parseEither - (SObject, _) -> parseEither - (SArray, _) -> parseEither - (SEnum, EnumMetaData {..}) -> + (SObject _, _) -> parseEither + (SArray _, _) -> parseEither + (SEnum _, EnumMetaData {..}) -> A.parseEither ( \o -> do txt <- o A..: keyName @@ -245,7 +247,7 @@ parseProperty kn k x = case k of else fail $ "invalid enum member: " - <> T.unpack txt + <> show txt <> ". Expected one of " <> show enumValues ) @@ -311,44 +313,43 @@ defineBooleanProperty kn description defaultValue = -- | Defines an object property defineObjectProperty :: - forall s r. - (KnownSymbol s, NotElem s r) => + (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) => KeyNameProxy s -> -- | description T.Text -> -- | default value - A.Object -> + a -> Properties r -> - Properties ('PropertyKey s 'TObject : r) + Properties ('PropertyKey s ('TObject a) : r) defineObjectProperty kn description defaultValue = - insert kn SObject MetaData {..} + insert kn (SObject Proxy) MetaData {..} -- | Defines an array property defineArrayProperty :: - (KnownSymbol s, NotElem s r) => + (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) => KeyNameProxy s -> -- | description T.Text -> -- | default value - A.Array -> + Vector a -> Properties r -> - Properties ('PropertyKey s 'TArray : r) + Properties ('PropertyKey s ('TArray a) : r) defineArrayProperty kn description defaultValue = - insert kn SArray MetaData {..} + insert kn (SArray Proxy) MetaData {..} -- | Defines an enum property defineEnumProperty :: - (KnownSymbol s, NotElem s r) => + (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a, Eq a, Show a) => KeyNameProxy s -> -- | description T.Text -> -- | valid enum members with each of description - [(T.Text, T.Text)] -> - T.Text -> + [(a, T.Text)] -> + a -> Properties r -> - Properties ('PropertyKey s 'TEnum : r) + Properties ('PropertyKey s ('TEnum a) : r) defineEnumProperty kn description enums defaultValue = - insert kn SEnum $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) + insert kn (SEnum Proxy) $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) -- --------------------------------------------------------------------- @@ -366,11 +367,11 @@ toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p] s A..= defaultValue (SomePropertyKeyWithMetaData SBoolean MetaData {..}) -> s A..= defaultValue - (SomePropertyKeyWithMetaData SObject MetaData {..}) -> + (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) -> s A..= defaultValue - (SomePropertyKeyWithMetaData SArray MetaData {..}) -> + (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) -> s A..= defaultValue - (SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) -> + (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) -> s A..= defaultValue -- | Converts a properties definition into kv pairs as vscode schema @@ -408,21 +409,21 @@ toVSCodeExtensionSchema prefix (Properties p) = "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SomePropertyKeyWithMetaData SObject MetaData {..}) -> + (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) -> A.object [ "type" A..= A.String "object", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SomePropertyKeyWithMetaData SArray MetaData {..}) -> + (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) -> A.object [ "type" A..= A.String "array", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) -> + (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) -> A.object [ "type" A..= A.String "string", "description" A..= description, From 02f4ae44ec5aab0a532ce97fe556e05aae795a23 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 22 Mar 2021 19:44:28 -0700 Subject: [PATCH 2/3] Use the enum support directly in TypeLenses --- .../src/Development/IDE/Plugin/TypeLenses.hs | 34 +++++++++++-------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index f306e0a984..196c161212 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -14,8 +14,10 @@ module Development.IDE.Plugin.TypeLenses ( import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) +import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson.Types as A import Data.Aeson.Types (Value (..), toJSON) import qualified Data.HashMap.Strict as Map import Data.List (find) @@ -91,13 +93,13 @@ descriptor plId = , pluginCustomConfig = mkCustomConfig properties } -properties :: Properties '[ 'PropertyKey "mode" ('TEnum T.Text)] +properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" - [ ("always", "Always displays type lenses of global bindings") - , ("exported", "Only display type lenses of exported global bindings") - , ("diagnostics", "Follows error messages produced by GHC about missing signatures") - ] "always" + [ (Always, "Always displays type lenses of global bindings") + , (Exported, "Only display type lenses of exported global bindings") + , (Diagnostics, "Follows error messages produced by GHC about missing signatures") + ] Always codeLensProvider :: IdeState -> @@ -105,7 +107,7 @@ codeLensProvider :: CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do - mode <- readMode <$> usePropertyLsp #mode pId properties + mode <- usePropertyLsp #mode pId properties fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) @@ -209,6 +211,18 @@ data Mode Diagnostics deriving (Eq, Ord, Show, Read, Enum) +instance A.ToJSON Mode where + toJSON Always = "always" + toJSON Exported = "exported" + toJSON Diagnostics = "diagnostics" + +instance A.FromJSON Mode where + parseJSON = A.withText "Mode" $ \case + "always" -> pure Always + "exported" -> pure Exported + "diagnostics" -> pure Diagnostics + _ -> mzero + -------------------------------------------------------------------------------- showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String @@ -245,14 +259,6 @@ rules = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) -readMode :: T.Text -> Mode -readMode = \case - "always" -> Always - "exported" -> Exported - "diagnostics" -> Diagnostics - -- actually it never happens because of 'usePropertyLsp' - _ -> error "failed to parse type lenses mode" - gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do let exports = availsToNameSet $ tcg_exports gblEnv From fc8b78db498a555bebc974d315c9e123bcf7ef24 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 22 Mar 2021 19:45:32 -0700 Subject: [PATCH 3/3] Use lists instead of vector to avoid a new dependency --- hls-plugin-api/src/Ide/Plugin/Properties.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index a1cf5750e6..266ea7348c 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -50,7 +50,6 @@ import Data.Kind (Constraint, Type) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import qualified Data.Text as T -import Data.Vector (Vector) import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits import Unsafe.Coerce (unsafeCoerce) @@ -71,7 +70,7 @@ type family ToHsType (t :: PropertyType) where ToHsType 'TString = T.Text ToHsType 'TBoolean = Bool ToHsType ('TObject a) = a - ToHsType ('TArray a) = Vector a + ToHsType ('TArray a) = [a] ToHsType ('TEnum a) = a -- --------------------------------------------------------------------- @@ -331,7 +330,7 @@ defineArrayProperty :: -- | description T.Text -> -- | default value - Vector a -> + [a] -> Properties r -> Properties ('PropertyKey s ('TArray a) : r) defineArrayProperty kn description defaultValue =