[Plugin] stylish-haskell formatter

exe/Main.hs

@@ -94,6 +94,7 @@ import Ide.Plugin.Example2                as Example2
 import Ide.Plugin.GhcIde                  as GhcIde
 import Ide.Plugin.Floskell                as Floskell
 import Ide.Plugin.Ormolu                  as Ormolu
+import Ide.Plugin.StylishHaskell          as StylishHaskell
 #if AGPL
 import Ide.Plugin.Brittany                as Brittany
 #endif
@@ -129,6 +130,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       -- , genericDescriptor     "generic"
       -- , ghcmodDescriptor      "ghcmod"
       , Ormolu.descriptor   "ormolu"
+      , StylishHaskell.descriptor "stylish-haskell"
 #if AGPL
       , Brittany.descriptor    "brittany"
 #endif

haskell-language-server.cabal

@@ -49,6 +49,7 @@ library
       Ide.Plugin.Pragmas
       Ide.Plugin.Floskell
       Ide.Plugin.Formatter
+      Ide.Plugin.StylishHaskell
       Ide.PluginUtils
       Ide.Types
       Ide.Version
@@ -84,6 +85,7 @@ library
     , process
     , regex-tdfa >= 1.3.1.0
     , shake >= 0.17.5
+    , stylish-haskell == 0.11.*
     , text
     , transformers
     , unordered-containers

src/Ide/Plugin/Config.hs

@@ -64,6 +64,7 @@ instance Default Config where
     -- , formattingProvider          = "brittany"
     , formattingProvider          = "ormolu"
     -- , formattingProvider          = "floskell"
+    -- , formattingProvider          = "stylish-haskell"
     }
 
 -- TODO: Add API for plugins to expose their own LSP config options

src/Ide/Plugin/StylishHaskell.hs

@@ -0,0 +1,59 @@
+module Ide.Plugin.StylishHaskell
+  (
+    descriptor
+  , provider
+  )
+where
+
+import           Control.Monad.IO.Class
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Ide.Plugin.Formatter
+import           Ide.PluginUtils
+import           Ide.Types
+import           Language.Haskell.Stylish
+import           Language.Haskell.LSP.Types            as J
+
+import           System.Directory
+import           System.FilePath
+
+descriptor :: PluginId -> PluginDescriptor
+descriptor plId = (defaultPluginDescriptor plId)
+  { pluginFormattingProvider = Just provider
+  }
+
+-- | Formatter provider of stylish-haskell.
+-- 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 _lf _ideState typ contents fp _opts = do
+  let file = fromNormalizedFilePath fp
+  config <- liftIO $ loadConfigFrom file
+  let (range, selectedContents) = case typ of
+        FormatText    -> (fullRange contents, contents)
+        FormatRange r -> (normalize r, extractRange r contents)
+      result = runStylishHaskell file config selectedContents
+  case result of
+    Left  err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err
+    Right new -> return $ Right $ J.List [TextEdit range new]
+
+-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
+-- If no such file has been found, return default config.
+loadConfigFrom :: FilePath -> IO Config
+loadConfigFrom file = do
+  currDir <- getCurrentDirectory
+  setCurrentDirectory (takeDirectory file)
+  config <- loadConfig (makeVerbose False) Nothing
+  setCurrentDirectory currDir
+  return config
+
+-- | Run stylish-haskell on the given text with the given configuration.
+runStylishHaskell :: FilePath           -- ^ Location of the file being formatted. Used for error message
+                  -> Config             -- ^ Configuration for stylish-haskell
+                  -> Text               -- ^ Text to format
+                  -> Either String Text -- ^ Either formatted Text or an error message
+runStylishHaskell file config = fmap fromLines . fmt . toLines
+  where
+    fromLines = T.pack . unlines
+    fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config)
+    toLines = lines . T.unpack

stack-8.6.4.yaml

@@ -33,6 +33,8 @@ extra-deps:
 - hlint-2.2.8
 - hoogle-5.0.17.11
 - hsimport-0.11.0@rev:2
+- HsYAML-0.2.1.0@rev:1
+- HsYAML-aeson-0.2.0.0@rev:1
 - lens-4.18
 - lsp-test-0.10.3.0
 - microlens-th-0.4.2.3@rev:1
@@ -48,6 +50,7 @@ extra-deps:
 # - shake-0.18.5
 - github: wz1000/shake
   commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
+- stylish-haskell-0.11.0.0
 - syz-0.2.0.0
 - tasty-rerun-1.1.17
 - temporary-1.2.1.1

stack-8.6.5.yaml

@@ -25,6 +25,8 @@ extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
 - hie-bios-0.5.0
+- HsYAML-0.2.1.0@rev:1
+- HsYAML-aeson-0.2.0.0@rev:1
 - indexed-profunctors-0.1
 - lens-4.18
 - lsp-test-0.10.3.0
@@ -40,6 +42,7 @@ extra-deps:
 - semialign-1.1
 - github: wz1000/shake
   commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
+- stylish-haskell-0.11.0.0
 - tasty-rerun-1.1.17
 - temporary-1.2.1.1
 - type-equality-1

stack-8.8.2.yaml

@@ -23,6 +23,8 @@ extra-deps:
 - hlint-2.2.8
 - hoogle-5.0.17.11
 - hsimport-0.11.0
+- HsYAML-0.2.1.0@rev:1
+- HsYAML-aeson-0.2.0.0@rev:1
 - ilist-0.3.1.0
 - lsp-test-0.10.3.0
 - monad-dijkstra-0.1.1.2
@@ -31,6 +33,7 @@ extra-deps:
 - semigroups-0.18.5
 - github: wz1000/shake
   commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
+- stylish-haskell-0.11.0.0
 - temporary-1.2.1.1
 
 flags:

stack-8.8.3.yaml

@@ -30,6 +30,7 @@ extra-deps:
 - semigroups-0.18.5
 - github: wz1000/shake
   commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
+- stylish-haskell-0.11.0.0
 - temporary-1.2.1.1
 
 flags:

stack.yaml

@@ -25,6 +25,8 @@ extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
 - hie-bios-0.5.0
+- HsYAML-0.2.1.0@rev:1
+- HsYAML-aeson-0.2.0.0@rev:1
 - indexed-profunctors-0.1
 - lens-4.18
 - lsp-test-0.10.3.0
@@ -40,6 +42,7 @@ extra-deps:
 - semialign-1.1
 - github: wz1000/shake
   commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
+- stylish-haskell-0.11.0.0
 - tasty-rerun-1.1.17
 - temporary-1.2.1.1
 - type-equality-1

test/functional/Format.hs

@@ -24,6 +24,7 @@ tests = testGroup "format document" [
         documentContents doc >>= liftIO . (`shouldBe` formattedDocTabSize5)
     , rangeTests
     , providerTests
+    , stylishHaskellTests
     , brittanyTests
     , ormoluTests
     ]
@@ -68,6 +69,38 @@ providerTests = testGroup "formatting provider" [
         documentContents doc >>= liftIO . (`shouldBe` formattedBrittanyPostFloskell)
     ]
 
+stylishHaskellTests :: TestTree
+stylishHaskellTests = testGroup "stylish-haskell" [
+  testCase "formats a file" $ runSession hieCommand fullCaps "test/testdata" $ do
+      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell"))
+      doc <- openDoc "StylishHaskell.hs" "haskell"
+      formatDoc doc (FormattingOptions 2 True)
+      contents <- documentContents doc
+      liftIO $ contents `shouldBe`
+        "import           Data.Char\n\
+        \import qualified Data.List\n\
+        \import           Data.String\n\
+        \\n\
+        \bar :: Maybe (Either String Integer) -> Integer\n\
+        \bar Nothing          = 0\n\
+        \bar (Just (Left _))  = 0\n\
+        \bar (Just (Right x)) = x\n"
+  , testCase "formats a range" $ runSession hieCommand fullCaps "test/testdata" $ do
+      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell"))
+      doc <- openDoc "StylishHaskell.hs" "haskell"
+      formatRange doc (FormattingOptions 2 True) (Range (Position 0 0) (Position 2 21))
+      contents <- documentContents doc
+      liftIO $ contents `shouldBe`
+        "import           Data.Char\n\
+        \import qualified Data.List\n\
+        \import           Data.String\n\
+        \\n\
+        \bar :: Maybe (Either String Integer) -> Integer\n\
+        \bar Nothing = 0\n\
+        \bar (Just (Left _)) = 0\n\
+        \bar (Just (Right x)) = x\n"
+  ]
+
 brittanyTests :: TestTree
 brittanyTests = testGroup "brittany" [
     ignoreTestBecause "Broken" $ testCase "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do

test/testdata/StylishHaskell.hs

@@ -0,0 +1,8 @@
+import Data.Char
+import qualified Data.List
+import    Data.String
+
+bar :: Maybe (Either String Integer) -> Integer
+bar Nothing = 0
+bar (Just (Left _)) = 0
+bar (Just (Right x)) = x