Merge pull request #42 from alanz/add-floskell-formatter

 Generalize formatter plugin support, add Floskell

Author: alanz

.gitmodules

@@ -8,3 +8,7 @@
 #     Commit git commit -m "Removed submodule <name>"
 #     Delete the now untracked submodule files
 #     rm -rf path_to_submodule
+[submodule "ghcide"]
+	path = ghcide
+	url = https://github.com/digital-asset/ghcide.git
+	# url = https://github.com/alanz/ghcide.git

cabal.project

@@ -1,6 +1,6 @@
 packages:
          ./
-         -- ghcide
+         ghcide
 
 tests: true
 
@@ -11,4 +11,4 @@ package ghcide
 
 write-ghc-environment-files: never
 
-index-state: 2020-02-04T19:45:47Z
+index-state: 2020-02-09T06:58:05Z

exe/Main.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main(main) where
 
@@ -16,9 +17,9 @@ import Data.Default
 import Data.List.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
-import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
+import Development.IDE.Core.Debouncer
 import Development.IDE.Core.FileStore
 import Development.IDE.Core.OfInterest
 import Development.IDE.Core.RuleTypes
@@ -36,9 +37,12 @@ import Development.IDE.Types.Options
 import Development.Shake (Action, action)
 import GHC hiding (def)
 import HIE.Bios
+import Ide.Plugin.Formatter
+import Ide.Plugin.Config
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types (LspId(IdInt))
 import Linker
+import qualified Data.HashSet as HashSet
 import System.Directory.Extra as IO
 import System.Exit
 import System.FilePath
@@ -50,6 +54,7 @@ import System.Time.Extra
 import Development.IDE.Plugin.CodeAction  as CodeAction
 import Development.IDE.Plugin.Completions as Completions
 import Ide.Plugin.Example                 as Example
+import Ide.Plugin.Floskell                as Floskell
 import Ide.Plugin.Ormolu                  as Ormolu
 
 -- ---------------------------------------------------------------------
@@ -58,11 +63,12 @@ import Ide.Plugin.Ormolu                  as Ormolu
 -- server.
 -- These can be freely added or removed to tailor the available
 -- features of the server.
-idePlugins :: Bool -> Plugin
+idePlugins :: Bool -> Plugin Config
 idePlugins includeExample
   = Completions.plugin <>
     CodeAction.plugin <>
-    Ormolu.plugin <>
+    formatterPlugins [("ormolu",   Ormolu.provider)
+                     ,("floskell", Floskell.provider)] <>
     if includeExample then Example.plugin else mempty
 
 -- ---------------------------------------------------------------------
@@ -91,7 +97,7 @@ main = do
         t <- offsetTime
         hPutStrLn stderr "Starting (haskell-language-server)LSP server..."
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do
+        runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
             -- very important we only call loadSession once, and it's fast, so just do it before starting
@@ -100,7 +106,8 @@ main = do
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     }
-            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs
+            debouncer <- newAsyncDebouncer
+            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs
     else do
         putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"
@@ -135,10 +142,10 @@ main = do
         let options =
               (defaultIdeOptions $ return $ return . grab)
                     { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
-        setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
+        setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
         results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
         let (worked, failed) = partition fst $ zip (map isJust results) files
         when (failed /= []) $
@@ -166,7 +173,7 @@ expandFiles = concatMapM $ \x -> do
 kick :: Action ()
 kick = do
     files <- getFilesOfInterest
-    void $ uses TypeCheck $ Set.toList files
+    void $ uses TypeCheck $ HashSet.toList files
 
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()

ghcide

@@ -28,8 +28,11 @@ source-repository head
 library
   exposed-modules:
       Ide.Cradle
+      Ide.Plugin.Config
       Ide.Plugin.Example
       Ide.Plugin.Ormolu
+      Ide.Plugin.Floskell
+      Ide.Plugin.Formatter
       Ide.Version
   other-modules:
       Paths_haskell_language_server
@@ -39,17 +42,21 @@ library
       base >=4.7 && <5
     , aeson
     , binary
+    , bytestring
     , Cabal
     , cabal-helper >= 1.0
     , containers
+    , data-default
     , deepseq
     , directory
+    , extra
     , filepath
+    , floskell == 0.10.*
     , ghc
     , ghcide >= 0.1
     , gitrev
     , hashable
-    , haskell-lsp == 0.19.*
+    , haskell-lsp == 0.20.*
     , hie-bios >= 0.4
     , hslogger
     , optparse-simple
@@ -117,6 +124,7 @@ executable haskell-language-server
     , optparse-applicative
     , shake >= 0.17.5
     , text
+    , unordered-containers
   default-language: Haskell2010
 
 executable haskell-language-server-wrapper

haskell-language-server.cabal

@@ -0,0 +1,103 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Ide.Plugin.Config
+    (
+      getInitialConfig
+    , getConfigFromNotification
+    , Config(..)
+    ) where
+
+import qualified Data.Aeson                    as A
+import           Data.Aeson              hiding ( Error )
+import           Data.Default
+import qualified Data.Text                     as T
+import           Language.Haskell.LSP.Types
+
+-- ---------------------------------------------------------------------
+
+-- | Given a DidChangeConfigurationNotification message, this function returns the parsed
+-- Config object if possible.
+getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config
+getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) =
+  case fromJSON p of
+    A.Success c -> Right c
+    A.Error err -> Left $ T.pack err
+
+-- | Given an InitializeRequest message, this function returns the parsed
+-- Config object if possible. Otherwise, it returns the default configuration
+getInitialConfig :: InitializeRequest -> Either T.Text Config
+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def
+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) =
+  case fromJSON opts of
+    A.Success c -> Right c
+    A.Error err -> Left $ T.pack err
+
+-- ---------------------------------------------------------------------
+
+-- | We (initially anyway) mirror the hie configuration, so that existing
+-- clients can simply switch executable and not have any nasty surprises.  There
+-- will be surprises relating to config options being ignored, initially though.
+data Config =
+  Config
+    { hlintOn                     :: Bool
+    , diagnosticsOnChange         :: Bool
+    , maxNumberOfProblems         :: Int
+    , diagnosticsDebounceDuration :: Int
+    , liquidOn                    :: Bool
+    , completionSnippetsOn        :: Bool
+    , formatOnImportOn            :: Bool
+    , formattingProvider          :: T.Text
+    } deriving (Show,Eq)
+
+instance Default Config where
+  def = Config
+    { hlintOn                     = True
+    , diagnosticsOnChange         = True
+    , maxNumberOfProblems         = 100
+    , diagnosticsDebounceDuration = 350000
+    , liquidOn                    = False
+    , completionSnippetsOn        = True
+    , formatOnImportOn            = True
+    -- , formattingProvider          = "brittany"
+    , formattingProvider          = "ormolu"
+    -- , formattingProvider          = "floskell"
+    }
+
+-- TODO: Add API for plugins to expose their own LSP config options
+instance A.FromJSON Config where
+  parseJSON = A.withObject "Config" $ \v -> do
+    s <- v .: "languageServerHaskell"
+    flip (A.withObject "Config.settings") s $ \o -> Config
+      <$> o .:? "hlintOn"                     .!= hlintOn def
+      <*> o .:? "diagnosticsOnChange"         .!= diagnosticsOnChange def
+      <*> o .:? "maxNumberOfProblems"         .!= maxNumberOfProblems def
+      <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def
+      <*> o .:? "liquidOn"                    .!= liquidOn def
+      <*> o .:? "completionSnippetsOn"        .!= completionSnippetsOn def
+      <*> o .:? "formatOnImportOn"            .!= formatOnImportOn def
+      <*> o .:? "formattingProvider"          .!= formattingProvider def
+
+-- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"languageServerHaskell":{"maxNumberOfProblems":100,"hlintOn":true}}}}
+-- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification:
+-- NotificationMessage
+--   {_jsonrpc = "2.0"
+--   , _method = WorkspaceDidChangeConfiguration
+--   , _params = DidChangeConfigurationParams
+--                 {_settings = Object (fromList [("languageServerHaskell",Object (fromList [("hlintOn",Bool True)
+--                                                                                          ,("maxNumberOfProblems",Number 100.0)]))])}}
+
+instance A.ToJSON Config where
+  toJSON (Config h diag m d l c f fp) = object [ "languageServerHaskell" .= r ]
+    where
+      r = object [ "hlintOn"                     .= h
+                 , "diagnosticsOnChange"         .= diag
+                 , "maxNumberOfProblems"         .= m
+                 , "diagnosticsDebounceDuration" .= d
+                 , "liquidOn"                    .= l
+                 , "completionSnippetsOn"        .= c
+                 , "formatOnImportOn"            .= f
+                 , "formattingProvider"          .= fp
+                 ]

src/Ide/Plugin/Config.hs

@@ -20,7 +20,7 @@ import Data.Binary
 import Data.Functor
 import qualified Data.HashMap.Strict as Map
 import Data.Hashable
-import qualified Data.Set                     as Set
+import qualified Data.HashSet as HashSet
 import qualified Data.Text as T
 import Data.Typeable
 import Development.IDE.Core.OfInterest
@@ -42,7 +42,7 @@ import Text.Regex.TDFA.Text()
 
 -- ---------------------------------------------------------------------
 
-plugin :: Plugin
+plugin :: Plugin c
 plugin = Plugin exampleRules handlersExample
          <> codeActionPlugin codeAction
          <> Plugin mempty handlersCodeLens
@@ -54,7 +54,7 @@ blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
 blah _ (Position line col)
   = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"])
 
-handlersExample :: PartialHandlers
+handlersExample :: PartialHandlers c
 handlersExample = PartialHandlers $ \WithMessage{..} x ->
   return x{LSP.hoverHandler = withResponse RspHover $ const hover}
 
@@ -78,7 +78,7 @@ exampleRules = do
 
   action $ do
     files <- getFilesOfInterest
-    void $ uses Example $ Set.toList files
+    void $ uses Example $ HashSet.toList files
 
 mkDiag :: NormalizedFilePath
        -> DiagnosticSource
@@ -100,7 +100,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,)
 
 -- | Generate code actions.
 codeAction
-    :: LSP.LspFuncs ()
+    :: LSP.LspFuncs c
     -> IdeState
     -> TextDocumentIdentifier
     -> Range
@@ -118,14 +118,14 @@ codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_di
 -- ---------------------------------------------------------------------
 
 -- | Generate code lenses.
-handlersCodeLens :: PartialHandlers
+handlersCodeLens :: PartialHandlers c
 handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.codeLensHandler = withResponse RspCodeLens codeLens,
     LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
     }
 
 codeLens
-    :: LSP.LspFuncs ()
+    :: LSP.LspFuncs c
     -> IdeState
     -> CodeLensParams
     -> IO (Either ResponseError (List CodeLens))
@@ -149,7 +149,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
 
 -- | Execute the "codelens.todo" command.
 executeAddSignatureCommand
-    :: LSP.LspFuncs ()
+    :: LSP.LspFuncs c
     -> IdeState
     -> ExecuteCommandParams
     -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

src/Ide/Plugin/Example.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Ide.Plugin.Floskell
+  (
+    provider
+  )
+where
+
+import qualified Data.ByteString.Lazy           as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding             as T
+import           Development.IDE.Types.Diagnostics as D
+import           Development.IDE.Types.Location
+import           Floskell
+import           Ide.Plugin.Formatter
+import           Language.Haskell.LSP.Types
+import           Text.Regex.TDFA.Text()
+
+-- ---------------------------------------------------------------------
+
+-- | Format provider of Floskell.
+-- Formats the given source in either a given Range or the whole Document.
+-- If the provider fails an error is returned that can be displayed to the user.
+provider :: FormattingProvider IO
+provider _ideState typ contents fp _ = do
+    let file = fromNormalizedFilePath fp
+    config <- findConfigOrDefault file
+    let (range, selectedContents) = case typ of
+          FormatText    -> (fullRange contents, contents)
+          FormatRange r -> (r, extractRange r contents)
+        result = reformat config (Just file) (BS.fromStrict (T.encodeUtf8 selectedContents))
+    case result of
+      Left  err -> return $ Left $ responseError (T.pack $  "floskellCmd: " ++ err)
+      Right new -> return $ Right $ List [TextEdit range (T.decodeUtf8 (BS.toStrict new))]
+
+-- | Find Floskell Config, user and system wide or provides a default style.
+-- Every directory of the filepath will be searched to find a user configuration.
+-- Also looks into places such as XDG_CONFIG_DIRECTORY<https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html>.
+-- This function may not throw an exception and returns a default config.
+findConfigOrDefault :: FilePath -> IO AppConfig
+findConfigOrDefault file = do
+  mbConf <- findAppConfigIn file
+  case mbConf of
+    Just confFile -> readAppConfig confFile
+    Nothing ->
+      let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles)
+      in return $ defaultAppConfig { appStyle = gibiansky }
+
+-- ---------------------------------------------------------------------