Merge pull request #487 from haskell/mpj/fix-textdocumentcontentchangeevent

Fix decoding of |?

Author: michaelpj

lsp-types/lsp-types.cabal

@@ -85,6 +85,8 @@ library
     , some
     , template-haskell
     , text
+    -- needed for aeson < 1
+    , unordered-containers
 
   if flag(force-ospath)
     build-depends: filepath ^>=1.4.100.0

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

@@ -5,14 +5,15 @@ import qualified Data.Aeson                         as A
 import           Data.Hashable
 import           Data.IxMap
 import           Data.Text                          (Text)
+import           GHC.Generics
 
 import           Language.LSP.Protocol.Types.Common
 import           Language.LSP.Protocol.Internal.Method
 import           Language.LSP.Protocol.Message.Meta
 
 -- | Id used for a request, Can be either a String or an Int
 data LspId (m :: Method f Request) = IdInt !Int32 | IdString !Text
-  deriving stock (Show,Read,Eq,Ord)
+  deriving stock (Show,Read,Eq,Ord,Generic)
 
 instance A.ToJSON (LspId m) where
   toJSON (IdInt i)    = A.toJSON i

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

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

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                  #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
@@ -21,12 +22,17 @@ module Language.LSP.Protocol.Types.Common (
   , (.=?)
 ) where
 
-import           Control.Applicative
 import           Control.DeepSeq
 import           Control.Lens
 import           Data.Aeson          hiding (Null)
 import qualified Data.Aeson          as J
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap   as KM
+#else
+import qualified Data.HashMap.Strict   as KM
+#endif
 import           Data.Hashable
+import           Data.Set            as Set
 import           Data.String         (fromString)
 import           Data.Int            (Int32)
 import           Data.Mod.Word
@@ -93,11 +99,35 @@ instance (ToJSON a, ToJSON b) => ToJSON (a |? b) where
   toJSON (InL x) = toJSON x
   toJSON (InR x) = toJSON x
 
-instance (FromJSON a, FromJSON b) => FromJSON (a |? b) where
-  -- Important: Try to parse the **rightmost** type first, as in the specification
-  -- the more complex types tend to appear on the right of the |, e.g.
-  -- @colorProvider?: boolean | DocumentColorOptions | DocumentColorRegistrationOptions;@
-  parseJSON v = InR <$> parseJSON v <|> InL <$> parseJSON v
+instance (FromJSON a, ToJSON a, FromJSON b, ToJSON b) => FromJSON (a |? b) where
+  -- Truly atrocious and abominable hack. The issue is tha we may have siutations
+  -- where some input JSON can parse correctly as both sides of the union, because
+  -- we have no tag. What do we do in this situation? It's very unclear, and the
+  -- spec is no help. The heuristic we adopt here is that it is better to take
+  -- the version with "more fields". How do we work that out? By converting back
+  -- to JSON and looking at the object fields.
+  --
+  -- Possibly we could do better by relying on Generic instances for a and b
+  -- in order to work out which has more fields on the Haskell side.
+  parseJSON v = do
+    let ra :: Result a = fromJSON v
+        rb :: Result b = fromJSON v
+    case (ra, rb) of
+      (Success a, Error _) -> pure $ InL a
+      (Error _, Success b) -> pure $ InR b
+      (Error e, Error _) -> fail e
+      (Success a, Success b) -> case (toJSON a, toJSON b) of
+        -- Both sides encode to the same thing, just pick one arbitrarily
+        (l, r) | l == r -> pure $ InL a
+        (Object oa, Object ob) -> 
+          let ka = Set.fromList $ KM.keys oa
+              kb = Set.fromList $ KM.keys ob
+          in if kb `Set.isSubsetOf` ka
+          then pure $ InL a
+          else if ka `Set.isSubsetOf` kb
+          then pure $ InR b
+          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
+        (l, r) -> fail $ "Could not decide which type of value to produce, left encodes to: " ++ show l ++ "; right encodes to: " ++ show r
 
 -- We could use 'Proxy' for this, as aeson also serializes it to/from null,
 -- but this is more explicit.

lsp-types/test/JsonSpec.hs

@@ -51,6 +51,7 @@ jsonSpec = do
   -- DataTypesJSON
     prop "MarkedString"   (propertyJsonRoundtrip :: MarkedString -> Property)
     prop "MarkupContent"  (propertyJsonRoundtrip :: MarkupContent -> Property)
+    prop "TextDocumentContentChangeEvent"  (propertyJsonRoundtrip :: TextDocumentContentChangeEvent -> Property)
     prop "WatchedFiles"   (propertyJsonRoundtrip :: DidChangeWatchedFilesRegistrationOptions -> Property)
     prop "ResponseMessage Hover"
          (propertyJsonRoundtrip :: TResponseMessage 'Method_TextDocumentHover -> Property)
@@ -66,7 +67,7 @@ responseMessageSpec = do
     it "decodes result = null" $ do
       let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}"
         in  J.decode input `shouldBe` Just
-              ((TResponseMessage "2.0" (Just (IdInt 123)) (Right $ InR Null)) :: TResponseMessage 'Method_WorkspaceExecuteCommand)
+              ((TResponseMessage "2.0" (Just (IdInt 123)) (Right $ InL J.Null)) :: TResponseMessage 'Method_WorkspaceExecuteCommand)
     it "handles missing params field" $ do
       J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}"
         `shouldBe` Right (TRequestMessage "2.0" (IdInt 15) SMethod_Shutdown Nothing)
@@ -90,64 +91,79 @@ propertyJsonRoundtrip a = J.Success a === J.fromJSON (J.toJSON a)
 
 instance (Arbitrary a, Arbitrary b) => Arbitrary (a |? b) where
   arbitrary = oneof [InL <$> arbitrary, InR <$> arbitrary]
+  shrink = genericShrink
 
 instance Arbitrary Null where
   arbitrary = pure Null
 
 instance (R.AllUniqueLabels r, R.Forall r Arbitrary) => Arbitrary (R.Rec r) where
   arbitrary = R.fromLabelsA @Arbitrary $ \_l -> arbitrary
+  shrink record = R.traverse @Arbitrary @[] shrink record
 
 deriving newtype instance Arbitrary MarkedString
 
 instance Arbitrary MarkupContent where
   arbitrary = MarkupContent <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary MarkupKind where
   arbitrary = oneof [pure MarkupKind_PlainText,pure MarkupKind_Markdown]
+  shrink = genericShrink
 
 instance Arbitrary UInt where
   arbitrary = fromInteger <$> arbitrary
 
 instance Arbitrary Uri where
   arbitrary = Uri <$> arbitrary
+  shrink = genericShrink
 
 --deriving newtype instance Arbitrary URI
 
 instance Arbitrary WorkspaceFolder where
   arbitrary = WorkspaceFolder <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary RelativePattern where
   arbitrary = RelativePattern <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 deriving newtype instance Arbitrary Pattern
 deriving newtype instance Arbitrary GlobPattern
 
 instance Arbitrary Position where
   arbitrary = Position <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary Location where
   arbitrary = Location <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary Range where
   arbitrary = Range <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary Hover where
   arbitrary = Hover <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance {-# OVERLAPPING #-} Arbitrary (Maybe Void) where
   arbitrary = pure Nothing
 
 instance (ErrorData m ~ Maybe Void) => Arbitrary (TResponseError m) where
   arbitrary = TResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
+  shrink = genericShrink
 
 instance Arbitrary ResponseError where
   arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
+  shrink = genericShrink
 
 instance (Arbitrary (MessageResult m), ErrorData m ~ Maybe Void) => Arbitrary (TResponseMessage m) where
   arbitrary = TResponseMessage <$> arbitrary <*> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary (LspId m) where
   arbitrary = oneof [IdInt <$> arbitrary, IdString <$> arbitrary]
+  shrink = genericShrink
 
 instance Arbitrary ErrorCodes where
   arbitrary =
@@ -160,6 +176,7 @@ instance Arbitrary ErrorCodes where
       , ErrorCodes_ServerNotInitialized
       , ErrorCodes_UnknownErrorCode
       ]
+  shrink = genericShrink
 
 instance Arbitrary LSPErrorCodes where
   arbitrary =
@@ -169,16 +186,24 @@ instance Arbitrary LSPErrorCodes where
       , LSPErrorCodes_ContentModified
       , LSPErrorCodes_RequestCancelled
       ]
+  shrink = genericShrink
 -- ---------------------------------------------------------------------
 
 instance Arbitrary DidChangeWatchedFilesRegistrationOptions where
   arbitrary = DidChangeWatchedFilesRegistrationOptions <$> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary FileSystemWatcher where
   arbitrary = FileSystemWatcher <$> arbitrary <*> arbitrary
+  shrink = genericShrink
 
 -- TODO: watchKind is weird
 instance Arbitrary WatchKind where
   arbitrary = oneof [pure WatchKind_Change, pure WatchKind_Create, pure WatchKind_Delete]
+  shrink = genericShrink
 
 -- ---------------------------------------------------------------------
+--
+instance Arbitrary TextDocumentContentChangeEvent where
+  arbitrary = TextDocumentContentChangeEvent <$> arbitrary
+  shrink = genericShrink