Merge pull request #360 from michaelpj/mpj/aeson-2

Aeson 2 compatibility

Author: michaelpj

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

@@ -9,7 +9,6 @@ module Language.LSP.Types.Common where
 import Control.Applicative
 import Control.DeepSeq
 import Data.Aeson
-import qualified Data.HashMap.Strict as HashMap
 import GHC.Generics
 
 -- | A terser, isomorphic data type for 'Either', that does not get tagged when
@@ -55,5 +54,5 @@ instance ToJSON Empty where
   toJSON Empty = Null
 instance FromJSON Empty where
   parseJSON Null = pure Empty
-  parseJSON (Object o) | HashMap.null o = pure Empty
+  parseJSON (Object o) | o == mempty = pure Empty
   parseJSON _ = fail "expected 'null' or '{}'"

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

@@ -55,12 +55,12 @@ import           Language.LSP.Types.WatchedFiles
 import           Language.LSP.Types.WorkspaceEdit
 import           Language.LSP.Types.WorkspaceFolders
 import           Language.LSP.Types.WorkspaceSymbol
-import qualified Data.HashMap.Strict as HM
 
 import Data.Kind
 import Data.Aeson
 import Data.Aeson.TH
 import Data.Text (Text)
+import Data.String
 import GHC.Generics
 
 -- ---------------------------------------------------------------------
@@ -274,8 +274,8 @@ deriving instance Show (MessageParams m) => Show (RequestMessage m)
 -- | Replace a missing field in an object with a null field, to simplify parsing
 -- This is a hack to allow other types than Maybe to work like Maybe in allowing the field to be missing.
 -- See also this issue: https://github.com/haskell/aeson/issues/646
-addNullField :: Text -> Value -> Value
-addNullField s (Object o) = Object $ HM.insertWith (\_new old -> old) s Null o
+addNullField :: String -> Value -> Value
+addNullField s (Object o) = Object $ o <> fromString s .= Null
 addNullField _ v = v
 
 instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where

lsp-types/src/Language/LSP/Types/Parsing.hs

@@ -14,13 +14,13 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Language.LSP.Types.Parsing where
 
 import           Language.LSP.Types.LspId
 import           Language.LSP.Types.Method
 import           Language.LSP.Types.Message
-import qualified Data.HashMap.Strict as HM
 
 import Data.Aeson
 import Data.Aeson.Types
@@ -90,25 +90,26 @@ Notification | jsonrpc |    | method | params?
 {-# INLINE parseServerMessage #-}
 parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a)
 parseServerMessage lookupId v@(Object o) = do
-  case HM.lookup "method" o of
-    Just cmd -> do
-      -- Request or Notification
-      SomeServerMethod m <- parseJSON cmd
+  methMaybe <- o .:! "method"
+  idMaybe <- o .:! "id"
+  case methMaybe of
+    -- Request or Notification
+    Just (SomeServerMethod m) ->
       case splitServerMethod m of
         IsServerNot -> FromServerMess m <$> parseJSON v
         IsServerReq -> FromServerMess m <$> parseJSON v
-        IsServerEither
-          | HM.member "id" o -- Request
-          , SCustomMethod cm <- m ->
+        IsServerEither | SCustomMethod cm <- m -> do
+          case idMaybe of
+            -- Request
+            Just _ ->
               let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request))
-                  in FromServerMess m' <$> parseJSON v
-          | SCustomMethod cm <- m ->
+              in FromServerMess m' <$> parseJSON v
+            Nothing ->
               let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification))
-                  in FromServerMess m' <$> parseJSON v
+              in FromServerMess m' <$> parseJSON v
     Nothing -> do
-      case HM.lookup "id" o of
-        Just i' -> do
-          i <- parseJSON i'
+      case idMaybe of
+        Just i -> do
           case lookupId i of
             Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v
             Nothing -> fail $ unwords ["Failed in looking up response type of", show v]
@@ -118,25 +119,26 @@ parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, go
 {-# INLINE parseClientMessage #-}
 parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a)
 parseClientMessage lookupId v@(Object o) = do
-  case HM.lookup "method" o of
-    Just cmd -> do
-      -- Request or Notification
-      SomeClientMethod m <- parseJSON cmd
+  methMaybe <- o .:! "method"
+  idMaybe <- o .:! "id"
+  case methMaybe of
+    -- Request or Notification
+    Just (SomeClientMethod m) ->
       case splitClientMethod m of
         IsClientNot -> FromClientMess m <$> parseJSON v
         IsClientReq -> FromClientMess m <$> parseJSON v
-        IsClientEither
-          | HM.member "id" o -- Request
-          , SCustomMethod cm <- m ->
+        IsClientEither | SCustomMethod cm <- m -> do
+          case idMaybe of
+            -- Request
+            Just _ ->
               let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request))
-                  in FromClientMess m' <$> parseJSON v
-          | SCustomMethod cm <- m ->
+              in FromClientMess m' <$> parseJSON v
+            Nothing ->
               let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification))
-                  in FromClientMess m' <$> parseJSON v
+              in FromClientMess m' <$> parseJSON v
     Nothing -> do
-      case HM.lookup "id" o of
-        Just i' -> do
-          i <- parseJSON i'
+      case idMaybe of
+        Just i -> do
           case lookupId i of
             Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v
             Nothing -> fail $ unwords ["Failed in looking up response type of", show v]

lsp/example/Reactor.hs

@@ -30,7 +30,6 @@ import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.STM
 import qualified Data.Aeson                            as J
-import qualified Data.HashMap.Strict                   as H
 import qualified Data.Text                             as T
 import           GHC.Generics (Generic)
 import           Language.LSP.Server
@@ -263,8 +262,8 @@ handle = mconcat
               cmd = "lsp-hello-command"
               -- need 'file' and 'start_pos'
               args = J.List
-                      [ J.Object $ H.fromList [("file",     J.Object $ H.fromList [("textDocument",J.toJSON doc)])]
-                      , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position",    J.toJSON start)])]
+                      [ J.object [("file",     J.object [("textDocument",J.toJSON doc)])]
+                      , J.object [("start_pos",J.object [("position",    J.toJSON start)])]
                       ]
               cmdparams = Just args
           makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = []