Skip to content

Commit a60adc1

Browse files
michaelpjmichaelpj
authored
Merge branch 'master' into mpj/9.6-ci
2 parents 876cf49 + 1ef88ac commit a60adc1

File tree

5 files changed

+70
-12
lines changed

5 files changed

+70
-12
lines changed

‎lsp-types/lsp-types.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,8 @@ library
8585
, some
8686
, template-haskell
8787
, text
88+
-- needed for aeson < 1
89+
, unordered-containers
8890

8991
if flag(force-ospath)
9092
build-depends: filepath ^>=1.4.100.0

‎lsp-types/src/Language/LSP/Protocol/Message/LspId.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,14 +5,15 @@ import qualified Data.Aeson as A
55
import Data.Hashable
66
import Data.IxMap
77
import Data.Text (Text)
8+
import GHC.Generics
89

910
import Language.LSP.Protocol.Types.Common
1011
import Language.LSP.Protocol.Internal.Method
1112
import Language.LSP.Protocol.Message.Meta
1213

1314
-- | Id used for a request, Can be either a String or an Int
1415
data LspId (m :: Method f Request) = IdInt !Int32 | IdString !Text
15-
deriving stock (Show,Read,Eq,Ord)
16+
deriving stock (Show,Read,Eq,Ord,Generic)
1617

1718
instance A.ToJSON (LspId m) where
1819
toJSON (IdInt i) = A.toJSON i

‎lsp-types/src/Language/LSP/Protocol/Message/Types.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -81,8 +81,8 @@ instance FromJSON ResponseError where
8181
<*> v .:? "data"
8282
in fmap go . errorCode
8383
where go :: ResponseError -> ResponseError
84-
go x@(ResponseError (InR (ErrorCodes_Custom n)) _ _) =
85-
x{_code = InL (fromOpenEnumBaseType n)}
84+
go x@(ResponseError (InL (LSPErrorCodes_Custom n)) _ _) =
85+
x{_code = InR (fromOpenEnumBaseType n)}
8686
go x = x
8787

8888
-- | Response message type as defined in the spec.
@@ -149,8 +149,8 @@ instance (FromJSON (ErrorData m)) => FromJSON (TResponseError m) where
149149
<*> v .:? "data"
150150
in fmap go . errorCode
151151
where go :: TResponseError m -> TResponseError m
152-
go x@(TResponseError (InR (ErrorCodes_Custom n)) _ _) =
153-
x{_code = InL (fromOpenEnumBaseType n)}
152+
go x@(TResponseError (InL (LSPErrorCodes_Custom n)) _ _) =
153+
x{_code = InR (fromOpenEnumBaseType n)}
154154
go x = x
155155
instance (ToJSON (ErrorData m)) => ToJSON (TResponseError m) where
156156
toJSON = genericToJSON lspOptions

‎lsp-types/src/Language/LSP/Protocol/Types/Common.hs

Lines changed: 36 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE DeriveAnyClass #-}
34
{-# LANGUAGE DeriveGeneric #-}
@@ -21,12 +22,17 @@ module Language.LSP.Protocol.Types.Common (
2122
, (.=?)
2223
) where
2324

24-
import Control.Applicative
2525
import Control.DeepSeq
2626
import Control.Lens
2727
import Data.Aeson hiding (Null)
2828
import qualified Data.Aeson as J
29+
#if MIN_VERSION_aeson(2,0,0)
30+
import qualified Data.Aeson.KeyMap as KM
31+
#else
32+
import qualified Data.HashMap.Strict as KM
33+
#endif
2934
import Data.Hashable
35+
import Data.Set as Set
3036
import Data.String (fromString)
3137
import Data.Int (Int32)
3238
import Data.Mod.Word
@@ -93,11 +99,35 @@ instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where
9399
toJSON (InL x) = toJSON x
94100
toJSON (InR x) = toJSON x
95101

96-
instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where
97-
-- Important: Try to parse the **rightmost** type first, as in the specification
98-
-- the more complex types tend to appear on the right of the |, e.g.
99-
-- @colorProvider?: boolean | DocumentColorOptions | DocumentColorRegistrationOptions;@
100-
parseJSON v = InR <$> parseJSON v <|> InL <$> parseJSON v
102+
instance (FromJSON a, ToJSON a, FromJSON b, ToJSON b) => FromJSON (a |? b) where
103+
-- Truly atrocious and abominable hack. The issue is tha we may have siutations
104+
-- where some input JSON can parse correctly as both sides of the union, because
105+
-- we have no tag. What do we do in this situation? It's very unclear, and the
106+
-- spec is no help. The heuristic we adopt here is that it is better to take
107+
-- the version with "more fields". How do we work that out? By converting back
108+
-- to JSON and looking at the object fields.
109+
--
110+
-- Possibly we could do better by relying on Generic instances for a and b
111+
-- in order to work out which has more fields on the Haskell side.
112+
parseJSON v = do
113+
let ra :: Result a = fromJSON v
114+
rb :: Result b = fromJSON v
115+
case (ra, rb) of
116+
(Success a, Error _) -> pure $ InL a
117+
(Error _, Success b) -> pure $ InR b
118+
(Error e, Error _) -> fail e
119+
(Success a, Success b) -> case (toJSON a, toJSON b) of
120+
-- Both sides encode to the same thing, just pick one arbitrarily
121+
(l, r) | l == r -> pure $ InL a
122+
(Object oa, Object ob) ->
123+
let ka = Set.fromList $ KM.keys oa
124+
kb = Set.fromList $ KM.keys ob
125+
in if kb `Set.isSubsetOf` ka
126+
then pure $ InL a
127+
else if ka `Set.isSubsetOf` kb
128+
then pure $ InR b
129+
else fail $ "Could not decide which type of value to produce, left encodes to an object with keys: " ++ show ka ++ "; right has keys " ++ show kb
130+
(l, r) -> fail $ "Could not decide which type of value to produce, left encodes to: " ++ show l ++ "; right encodes to: " ++ show r
101131

102132
-- We could use 'Proxy' for this, as aeson also serializes it to/from null,
103133
-- but this is more explicit.

‎lsp-types/test/JsonSpec.hs

Lines changed: 26 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ jsonSpec = do
5151
-- DataTypesJSON
5252
prop "MarkedString" (propertyJsonRoundtrip :: MarkedString -> Property)
5353
prop "MarkupContent" (propertyJsonRoundtrip :: MarkupContent -> Property)
54+
prop "TextDocumentContentChangeEvent" (propertyJsonRoundtrip :: TextDocumentContentChangeEvent -> Property)
5455
prop "WatchedFiles" (propertyJsonRoundtrip :: DidChangeWatchedFilesRegistrationOptions -> Property)
5556
prop "ResponseMessage Hover"
5657
(propertyJsonRoundtrip :: TResponseMessage 'Method_TextDocumentHover -> Property)
@@ -66,7 +67,7 @@ responseMessageSpec = do
6667
it "decodes result = null" $ do
6768
let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}"
6869
in J.decode input `shouldBe` Just
69-
((TResponseMessage "2.0" (Just (IdInt 123)) (Right $ InR Null)) :: TResponseMessage 'Method_WorkspaceExecuteCommand)
70+
((TResponseMessage "2.0" (Just (IdInt 123)) (Right $ InL J.Null)) :: TResponseMessage 'Method_WorkspaceExecuteCommand)
7071
it "handles missing params field" $ do
7172
J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}"
7273
`shouldBe` Right (TRequestMessage "2.0" (IdInt 15) SMethod_Shutdown Nothing)
@@ -90,64 +91,79 @@ propertyJsonRoundtrip a = J.Success a === J.fromJSON (J.toJSON a)
9091

9192
instance (Arbitrary a, Arbitrary b) => Arbitrary (a |? b) where
9293
arbitrary = oneof [InL <$> arbitrary, InR <$> arbitrary]
94+
shrink = genericShrink
9395

9496
instance Arbitrary Null where
9597
arbitrary = pure Null
9698

9799
instance (R.AllUniqueLabels r, R.Forall r Arbitrary) => Arbitrary (R.Rec r) where
98100
arbitrary = R.fromLabelsA @Arbitrary $ \_l -> arbitrary
101+
shrink record = R.traverse @Arbitrary @[] shrink record
99102

100103
deriving newtype instance Arbitrary MarkedString
101104

102105
instance Arbitrary MarkupContent where
103106
arbitrary = MarkupContent <$> arbitrary <*> arbitrary
107+
shrink = genericShrink
104108

105109
instance Arbitrary MarkupKind where
106110
arbitrary = oneof [pure MarkupKind_PlainText,pure MarkupKind_Markdown]
111+
shrink = genericShrink
107112

108113
instance Arbitrary UInt where
109114
arbitrary = fromInteger <$> arbitrary
110115

111116
instance Arbitrary Uri where
112117
arbitrary = Uri <$> arbitrary
118+
shrink = genericShrink
113119

114120
--deriving newtype instance Arbitrary URI
115121

116122
instance Arbitrary WorkspaceFolder where
117123
arbitrary = WorkspaceFolder <$> arbitrary <*> arbitrary
124+
shrink = genericShrink
118125

119126
instance Arbitrary RelativePattern where
120127
arbitrary = RelativePattern <$> arbitrary <*> arbitrary
128+
shrink = genericShrink
121129

122130
deriving newtype instance Arbitrary Pattern
123131
deriving newtype instance Arbitrary GlobPattern
124132

125133
instance Arbitrary Position where
126134
arbitrary = Position <$> arbitrary <*> arbitrary
135+
shrink = genericShrink
127136

128137
instance Arbitrary Location where
129138
arbitrary = Location <$> arbitrary <*> arbitrary
139+
shrink = genericShrink
130140

131141
instance Arbitrary Range where
132142
arbitrary = Range <$> arbitrary <*> arbitrary
143+
shrink = genericShrink
133144

134145
instance Arbitrary Hover where
135146
arbitrary = Hover <$> arbitrary <*> arbitrary
147+
shrink = genericShrink
136148

137149
instance {-# OVERLAPPING #-} Arbitrary (Maybe Void) where
138150
arbitrary = pure Nothing
139151

140152
instance (ErrorData m ~ Maybe Void) => Arbitrary (TResponseError m) where
141153
arbitrary = TResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
154+
shrink = genericShrink
142155

143156
instance Arbitrary ResponseError where
144157
arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
158+
shrink = genericShrink
145159

146160
instance (Arbitrary (MessageResult m), ErrorData m ~ Maybe Void) => Arbitrary (TResponseMessage m) where
147161
arbitrary = TResponseMessage <$> arbitrary <*> arbitrary <*> arbitrary
162+
shrink = genericShrink
148163

149164
instance Arbitrary (LspId m) where
150165
arbitrary = oneof [IdInt <$> arbitrary, IdString <$> arbitrary]
166+
shrink = genericShrink
151167

152168
instance Arbitrary ErrorCodes where
153169
arbitrary =
@@ -160,6 +176,7 @@ instance Arbitrary ErrorCodes where
160176
, ErrorCodes_ServerNotInitialized
161177
, ErrorCodes_UnknownErrorCode
162178
]
179+
shrink = genericShrink
163180

164181
instance Arbitrary LSPErrorCodes where
165182
arbitrary =
@@ -169,16 +186,24 @@ instance Arbitrary LSPErrorCodes where
169186
, LSPErrorCodes_ContentModified
170187
, LSPErrorCodes_RequestCancelled
171188
]
189+
shrink = genericShrink
172190
-- ---------------------------------------------------------------------
173191

174192
instance Arbitrary DidChangeWatchedFilesRegistrationOptions where
175193
arbitrary = DidChangeWatchedFilesRegistrationOptions <$> arbitrary
194+
shrink = genericShrink
176195

177196
instance Arbitrary FileSystemWatcher where
178197
arbitrary = FileSystemWatcher <$> arbitrary <*> arbitrary
198+
shrink = genericShrink
179199

180200
-- TODO: watchKind is weird
181201
instance Arbitrary WatchKind where
182202
arbitrary = oneof [pure WatchKind_Change, pure WatchKind_Create, pure WatchKind_Delete]
203+
shrink = genericShrink
183204

184205
-- ---------------------------------------------------------------------
206+
--
207+
instance Arbitrary TextDocumentContentChangeEvent where
208+
arbitrary = TextDocumentContentChangeEvent <$> arbitrary
209+
shrink = genericShrink

0 commit comments

Comments
 (0)