Fix #268 by introducing a MaybeN type

lsp-test/src/Language/LSP/Test.hs

@@ -200,14 +200,14 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
   let initializeParams = InitializeParams Nothing
                                           -- Narrowing to Int32 here, but it's unlikely that a PID will
                                           -- be outside the range
-                                          (Just $ fromIntegral pid)
+                                          (JustN $ fromIntegral pid)
                                           (Just lspTestClientInfo)
-                                          (Just $ T.pack absRootDir)
-                                          (Just $ filePathToUri absRootDir)
+                                          (JustN $ T.pack absRootDir)
+                                          (JustN $ filePathToUri absRootDir)
                                           (lspConfig config')
                                           caps
                                           (Just TraceOff)
-                                          (List <$> initialWorkspaceFolders config)
+                                          (maybeN (List <$> initialWorkspaceFolders config))
   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
     -- Wrap the session around initialize and shutdown calls
     initReqId <- sendRequest SInitialize initializeParams

lsp-test/src/Language/LSP/Test/Files.hs

@@ -40,7 +40,7 @@ swapFiles relCurBaseDir msgs = do
 rootDir :: [Event] -> FilePath
 rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
   fromMaybe (error "Couldn't find root dir") $ do
-    rootUri <- req ^. params .rootUri
+    rootUri <- unMaybeN (req ^. params . rootUri)
     uriToFilePath rootUri
 rootDir _ = error "Couldn't find initialize request in session"
 
@@ -99,7 +99,7 @@ mapUris f event =
     transformInit x =
       let newRootUri = fmap f (x ^. rootUri)
           newRootPath = do
-            fp <- T.unpack <$> x ^. rootPath
+            fp <- T.unpack <$> unMaybeN (x ^. rootPath)
             let uri = filePathToUri fp
             T.pack <$> uriToFilePath (f uri)
-        in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x
+        in (rootUri .~ newRootUri) $ (rootPath .~ maybeN newRootPath) x

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

@@ -11,20 +11,23 @@ module Language.LSP.Types.Common (
     type (|?) (..)
   , toEither
   , List (..)
+  , MaybeN (..)
+  , unMaybeN
+  , maybeN
   , Empty (..)
   , Int32
   , UInt ) where
 
 import Control.Applicative
 import Control.DeepSeq
 import Data.Aeson
+import Data.Bifunctor (bimap)
 import Data.Hashable
 import Data.Int (Int32)
 import Data.Mod.Word
-import Text.Read (Read(readPrec))
 import GHC.Generics hiding (UInt)
 import GHC.TypeNats hiding (Mod)
-import Data.Bifunctor (bimap)
+import Text.Read (Read(readPrec))
 
 -- | The "uinteger" type in the LSP spec.
 --
@@ -101,3 +104,24 @@ instance FromJSON Empty where
   parseJSON Null = pure Empty
   parseJSON (Object o) | o == mempty = pure Empty
   parseJSON _ = fail "expected 'null' or '{}'"
+
+-- A Maybe type which encodes to JSON "null" in the case of Nothing.
+-- Used to conform to the LSP spec in cases where a field is specified to be
+-- of type "a | null" instead of "a?". (In the latter case we just use ordinary
+-- Maybe in combination with aeson's 'omitNothingFields' option.)
+data MaybeN a = JustN a | NothingN
+  deriving (Show, Read, Eq, Ord, Functor)
+instance ToJSON a => ToJSON (MaybeN a) where
+  toJSON NothingN = Null
+  toJSON (JustN x) = toJSON x
+instance FromJSON a => FromJSON (MaybeN a) where
+  parseJSON Null = pure NothingN
+  parseJSON x = JustN <$> parseJSON x
+
+unMaybeN :: MaybeN a -> Maybe a
+unMaybeN (JustN a) = Just a
+unMaybeN NothingN = Nothing
+
+maybeN :: Maybe a -> MaybeN a
+maybeN (Just a) = JustN a
+maybeN Nothing = NothingN

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

@@ -41,14 +41,14 @@ data ClientInfo =
 deriveJSON lspOptions ''ClientInfo
 
 makeExtendingDatatype "InitializeParams" [''WorkDoneProgressParams]
-  [ ("_processId",             [t| Maybe Int32|])
+  [ ("_processId",             [t| MaybeN Int32|])
   , ("_clientInfo",            [t| Maybe ClientInfo |])
-  , ("_rootPath",              [t| Maybe Text |])
-  , ("_rootUri",               [t| Maybe Uri  |])
+  , ("_rootPath",              [t| MaybeN Text |])
+  , ("_rootUri",               [t| MaybeN Uri |])
   , ("_initializationOptions", [t| Maybe Value |])
   , ("_capabilities",          [t| ClientCapabilities |])
   , ("_trace",                 [t| Maybe Trace |])
-  , ("_workspaceFolders",      [t| Maybe (List WorkspaceFolder) |])
+  , ("_workspaceFolders",      [t| MaybeN (List WorkspaceFolder) |])
   ]
 
 deriveJSON lspOptions ''InitializeParams
@@ -93,4 +93,3 @@ instance FromJSON InitializedParams where
 
 instance ToJSON InitializedParams where
   toJSON InitializedParams = Object mempty
-

lsp/src/Language/LSP/Server/Processing.hs

@@ -120,12 +120,12 @@ initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do
   flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. LSP.id)) $ handleErr <=< runExceptT $ mdo
 
     let params = req ^. LSP.params
-        rootDir = getFirst $ foldMap First [ params ^. LSP.rootUri  >>= uriToFilePath
-                                           , params ^. LSP.rootPath <&> T.unpack ]
+        rootDir = getFirst $ foldMap First [ unMaybeN (params ^. LSP.rootUri) >>= uriToFilePath
+                                           , unMaybeN (params ^. LSP.rootPath) <&> T.unpack ]
 
     let initialWfs = case params ^. LSP.workspaceFolders of
-          Just (List xs) -> xs
-          Nothing -> []
+          JustN (List xs) -> xs
+          NothingN -> []
 
         initialConfig = case onConfigurationChange defaultConfig <$> (req ^. LSP.params . LSP.initializationOptions) of
           Just (Right newConfig) -> newConfig