[LSP] add basic formatting (#844)

dhall-lsp-server/ChangeLog.md

@@ -1,3 +1,6 @@
 # Changelog for dhall-lsp-server
 
-## Unreleased changes
+## unreleased
+  - whole document formatting
+## 0.0.1.0
+  - diagnostic output

dhall-lsp-server/app/Main.hs

@@ -70,7 +70,7 @@ parserInfoOptions =
 
 runCommand :: Options -> IO ()
 runCommand Options{..} = case command of
-  CmdVersion -> putStrLn "0.0.1.0" -- TODO: read from build
+  CmdVersion -> putStrLn "0.0.1.1" -- TODO: read from build
   Default    ->
    run logFile (pure ()) >>= \case
     0 -> exitSuccess

dhall-lsp-server/dhall-lsp-server.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 name:           dhall-lsp-server
-version:        0.1.0.0
+version:        0.1.0.1
 description:    Please see the README on GitHub at <https://github.com/githubuser/dhall-lsp-server#readme>
 homepage:       https://github.com/dhall-lang/dhall-haskell/dhall-lsp-server#readme
 bug-reports:    https://github.com/dhall-lang/dhall-haskell/issues
@@ -22,9 +22,11 @@ library
   exposed-modules:
       Backend.Dhall.DhallErrors
       Backend.Dhall.Diagnostics
+      Backend.Dhall.Formatting
       LSP.Common
       LSP.Dispatcher
       LSP.Handlers.Diagnostics
+      LSP.Handlers.DocumentFormatting
       LSP.Server
       Prelude
   other-modules:

dhall-lsp-server/src/Backend/Dhall/Formatting.hs

@@ -0,0 +1,20 @@
+module Backend.Dhall.Formatting(formatDocument) where
+
+import Dhall.Pretty (CharacterSet(..), layoutOpts)
+import Dhall.Parser(exprAndHeaderFromText, ParseError(..))
+
+import qualified Data.Text
+import qualified Data.Text.Prettyprint.Doc                 as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty.Text
+import qualified Dhall.Pretty
+
+formatDocument :: Text -> Either ParseError Text
+formatDocument text = do
+    (header, expr) <- exprAndHeaderFromText "" text
+    let doc =   Pretty.pretty header
+                            <>  Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet Unicode expr)
+                            <>  "\n"
+        formattedText =
+                Pretty.Text.renderStrict (Pretty.layoutSmart layoutOpts doc)
+    pure formattedText
+

dhall-lsp-server/src/LSP/Dispatcher.hs

@@ -13,6 +13,7 @@ import qualified Language.Haskell.LSP.Types.Lens       as J
 
 import LSP.Common
 import LSP.Handlers.Diagnostics
+import LSP.Handlers.DocumentFormatting
 
 import Control.Lens 
 
@@ -25,12 +26,12 @@ dispatcher lf inp = do
     inval <- liftIO $ atomically $ readTChan inp
     case inval of
 
-       (RspFromClient rm) ->
+      (RspFromClient rm) ->
         liftIO $ LSP.Utility.logs $ "reactor:got RspFromClient:" ++ show rm
 
       -- -------------------------------
 
-       (NotInitialized _notification) -> do
+      (NotInitialized _notification) -> do
         liftIO $ LSP.Utility.logm "****** reactor: processing Initialized Notification"
         
         let
@@ -51,7 +52,7 @@ dispatcher lf inp = do
 
       -- -------------------------------
 
-       (NotDidOpenTextDocument notification) -> do
+      (NotDidOpenTextDocument notification) -> do
         liftIO $ LSP.Utility.logm "****** reactor: processing NotDidOpenTextDocument"
         let
             doc  = notification ^. J.params
@@ -66,7 +67,7 @@ dispatcher lf inp = do
 
       
 
-       (NotDidSaveTextDocument notification) -> do
+      (NotDidSaveTextDocument notification) -> do
         liftIO $ LSP.Utility.logm "****** reactor: processing NotDidSaveTextDocument"
         let
             doc  = notification ^. J.params
@@ -78,7 +79,7 @@ dispatcher lf inp = do
         sendDiagnostics doc Nothing
 
       
-       (NotDidCloseTextDocument req) -> do
+      (NotDidCloseTextDocument req) -> do
         liftIO $ LSP.Utility.logm "****** reactor: processing NotDidCloseTextDocument"
         let
             doc  = req ^. J.params
@@ -87,7 +88,36 @@ dispatcher lf inp = do
             fileName = J.uriToFilePath doc
         liftIO $ LSP.Utility.logs $ "********* fileName=" ++ show fileName
         sendEmptyDiagnostics doc Nothing
-       om -> do
-        liftIO $ LSP.Utility.logs $ "\nIGNORING!!!\n HandlerRequest:" ++ show om
 
--- ---------------------------------------------------------------------
+
+      (ReqDocumentFormatting req) -> do
+          liftIO $ LSP.Utility.logm "****** reactor: processing ReqDocumentFormatting"
+          let
+            uri = req ^. J.params
+                       . J.textDocument
+                       . J.uri
+            range = req ^. J.params
+                         . J.options
+            tabSize      = range ^. J.tabSize
+            insertSpaces = range ^. J.insertSpaces
+            
+          formattedDocument <- formatDocument uri tabSize insertSpaces
+          publish req RspDocumentFormatting formattedDocument
+
+      unknown -> 
+        liftIO $ LSP.Utility.logs $ "\nIGNORING!!!\n HandlerRequest:" ++ show unknown
+
+       
+-- ---------------------------------------------------------------------
+
+
+publish :: J.RequestMessage J.ClientMethod req resp 
+         -> (J.ResponseMessage resp -> FromServerMessage) 
+         -> resp 
+         -> ReaderT (LSP.Core.LspFuncs ()) IO ()
+publish req unwrap response = 
+  do
+    lf <- ask
+    let 
+      rspMessage = LSP.Core.makeResponseMessage req response 
+    liftIO $ LSP.Core.sendFunc lf (unwrap rspMessage) 

dhall-lsp-server/src/LSP/Handlers/DocumentFormatting.hs

@@ -0,0 +1,35 @@
+module LSP.Handlers.DocumentFormatting(formatDocument) where
+
+
+
+import qualified Backend.Dhall.Formatting as Formatting
+
+import qualified Language.Haskell.LSP.Core as LSP.Core
+
+import qualified Data.Aeson                            as J
+import qualified Language.Haskell.LSP.Types            as J
+import qualified Language.Haskell.LSP.Types.Lens       as J
+import qualified Language.Haskell.LSP.Utility  as LSP.Utility
+import           Language.Haskell.LSP.Messages
+
+import qualified Data.Text
+import qualified Data.Text.IO
+import qualified Data.SortedList
+
+-- TODO: implement tabSize and spaces/tabs options
+-- * Note: any formatting errors would be swallowed. I think this is fine in this case, but generally we'd like to send user a notification
+-- (e.g. the error occurred in the formatter itself, and user requests format constantly and nothing happens)
+formatDocument :: J.Uri -> Int -> Bool -> ReaderT (LSP.Core.LspFuncs ()) IO (J.List J.TextEdit)
+formatDocument fileUri tabSize insertSpaces = do
+    let
+      filePath = maybe (error "can't convert uri to file path") id $ J.uriToFilePath fileUri -- !FIXME: handle non-file uris
+    txt <- lift $ Data.Text.IO.readFile filePath
+    case Formatting.formatDocument txt of 
+      (Right formatted) -> let
+                             numLines = Data.Text.length txt
+                             range = J.Range  (J.Position 0 0) (J.Position numLines 0)
+                           in pure $ J.List [J.TextEdit range formatted]
+      (Left err) -> do
+                  lift $ LSP.Utility.logs $ "Error while formatting the document " <> show err
+                  pure (J.List [])
+    

dhall-lsp-server/src/LSP/Server.hs

@@ -91,6 +91,7 @@ lspHandlers rin
         , LSP.Core.responseHandler                          = Just $ responseHandlerCb rin
         -- , Core.codeActionHandler                        = Just $ passHandler rin ReqCodeAction
         , LSP.Core.executeCommandHandler                    = Just $ passHandler rin ReqExecuteCommand
+        , LSP.Core.documentFormattingHandler                = Just $ passHandler rin ReqDocumentFormatting
         }
 
 -- ---------------------------------------------------------------------