Move Brittany plugin from HIE

exe/Main.hs

@@ -92,6 +92,9 @@ import Ide.Plugin.Example2                as Example2
 import Ide.Plugin.GhcIde                  as GhcIde
 import Ide.Plugin.Floskell                as Floskell
 import Ide.Plugin.Ormolu                  as Ormolu
+#if AGPL
+import Ide.Plugin.Brittany                as Brittany
+#endif
 import Ide.Plugin.Pragmas                 as Pragmas
 
 
@@ -113,18 +116,20 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
     basePlugins =
       [
       --   applyRefactDescriptor "applyrefact"
-      -- , brittanyDescriptor    "brittany"
       -- , haddockDescriptor     "haddock"
       -- , hareDescriptor        "hare"
       -- , hsimportDescriptor    "hsimport"
       -- , liquidDescriptor      "liquid"
       -- , packageDescriptor     "package"
-        GhcIde.descriptor  "ghcide"
+      GhcIde.descriptor  "ghcide"
       , Pragmas.descriptor  "pragmas"
       , Floskell.descriptor "floskell"
       -- , genericDescriptor     "generic"
       -- , ghcmodDescriptor      "ghcmod"
       , Ormolu.descriptor   "ormolu"
+#if AGPL
+      , Brittany.descriptor    "brittany"
+#endif
       ]
     examplePlugins =
       [Example.descriptor  "eg"
@@ -172,7 +177,6 @@ main = do
         options = def { LSP.executeCommandCommands = Just commandIds
                       , LSP.completionTriggerCharacters = Just "."
                       }
-
     if argLSP then do
         t <- offsetTime
         hPutStrLn stderr "Starting (haskell-language-server)LSP server..."

haskell-language-server.cabal

@@ -1,4 +1,4 @@
-cabal-version: 1.12
+cabal-version:  2.2
 category:       Development
 name:           haskell-language-server
 version:        0.1.0.0
@@ -16,6 +16,11 @@ extra-source-files:
     README.md
     ChangeLog.md
 
+flag agpl
+  Description: Enable AGPL dependencies
+  Default:     True
+  Manual:      False
+
 flag pedantic
   Description: Enable -Werror
   Default:     False
@@ -25,7 +30,13 @@ source-repository head
   type: git
   location: https://github.com/haskell/haskell-language-server
 
+common agpl
+  if flag(agpl)
+    cpp-options:
+      -DAGPL
+
 library
+  import: agpl
   exposed-modules:
       Ide.Cradle
       Ide.Logger
@@ -77,6 +88,12 @@ library
     build-depends:     Win32
   else
     build-depends:     unix
+  if flag(agpl)
+    build-depends:
+      brittany
+    exposed-modules:
+      Ide.Plugin.Brittany
+
   if impl(ghc >= 8.6)
      build-depends: ormolu >= 0.0.3.1
 
@@ -90,6 +107,7 @@ library
   default-language: Haskell2010
 
 executable haskell-language-server
+  import: agpl
   main-is: Main.hs
   hs-source-dirs:
       exe
@@ -150,6 +168,7 @@ executable haskell-language-server
   default-language: Haskell2010
 
 executable haskell-language-server-wrapper
+  import: agpl
   main-is: Wrapper.hs
   hs-source-dirs:
       exe
@@ -187,6 +206,7 @@ executable haskell-language-server-wrapper
 
 
 test-suite func-test
+  import: agpl
   type: exitcode-stdio-1.0
   default-language: Haskell2010
   build-tool-depends:  hspec-discover:hspec-discover
@@ -244,6 +264,7 @@ test-suite func-test
   --       Development.IDE.Test.Runfiles
 
 library hls-test-utils
+  import: agpl
   hs-source-dirs:      test/utils
   exposed-modules:     TestUtils
   build-depends:       base

src/Ide/Plugin/Brittany.hs

@@ -0,0 +1,112 @@
+module Ide.Plugin.Brittany where
+
+import           Control.Lens
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
+import           Data.Coerce
+import           Data.Semigroup
+import           Data.Text                             (Text)
+import qualified Data.Text                             as T
+import           Development.IDE.Types.Location
+import           Language.Haskell.Brittany
+import           Language.Haskell.LSP.Types            as J
+import qualified Language.Haskell.LSP.Types.Lens       as J
+import           Ide.Plugin.Formatter
+import           Ide.Types
+
+import           System.FilePath
+import           Data.Maybe (maybeToList)
+
+descriptor :: PluginId -> PluginDescriptor
+descriptor plId = PluginDescriptor
+  { pluginId = plId
+  , pluginRules = mempty
+  , pluginCommands = []
+  , pluginCodeActionProvider = Nothing
+  , pluginCodeLensProvider   = Nothing
+  , pluginDiagnosticProvider = Nothing
+  , pluginHoverProvider      = Nothing
+  , pluginSymbolsProvider    = Nothing
+  , pluginFormattingProvider = Just provider
+  , pluginCompletionProvider = Nothing
+  }
+
+-- | Formatter provider of Brittany.
+-- 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 opts = do
+-- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do
+  confFile <- liftIO $ getConfFile fp
+  let (range, selectedContents) = case typ of
+        FormatText    -> (fullRange contents, contents)
+        FormatRange r -> (normalize r, extractRange r contents)
+
+  res <- formatText confFile opts selectedContents
+  case res of
+    Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err))
+    Right newText -> return $ Right $ J.List [TextEdit range newText]
+
+-- | Primitive to format text with the given option.
+-- May not throw exceptions but return a Left value.
+-- Errors may be presented to the user.
+formatText
+  :: MonadIO m
+  => Maybe FilePath -- ^ Path to configs. If Nothing, default configs will be used.
+  -> FormattingOptions -- ^ Options for the formatter such as indentation.
+  -> Text -- ^ Text to format
+  -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany.
+formatText confFile opts text =
+  liftIO $ runBrittany tabSize confFile text
+  where tabSize = opts ^. J.tabSize
+
+-- | Extend to the line below and above to replace newline character.
+normalize :: Range -> Range
+normalize (Range (Position sl _) (Position el _)) =
+  Range (Position sl 0) (Position (el + 1) 0)
+
+-- | Recursively search in every directory of the given filepath for brittany.yaml.
+-- If no such file has been found, return Nothing.
+getConfFile :: NormalizedFilePath -> IO (Maybe FilePath)
+getConfFile = findLocalConfigPath . takeDirectory . fromNormalizedFilePath
+
+-- | Run Brittany on the given text with the given tab size and
+-- a configuration path. If no configuration path is given, a
+-- default configuration is chosen. The configuration may overwrite
+-- tab size parameter.
+--
+-- Returns either a list of Brittany Errors or the reformatted text.
+-- May not throw an exception.
+runBrittany :: Int              -- ^ tab  size
+            -> Maybe FilePath   -- ^ local config file
+            -> Text             -- ^ text to format
+            -> IO (Either [BrittanyError] Text)
+runBrittany tabSize confPath text = do
+  let cfg = mempty
+              { _conf_layout =
+                  mempty { _lconfig_indentAmount = opt (coerce tabSize)
+                         }
+              , _conf_forward =
+                  (mempty :: CForwardOptions Option)
+                    { _options_ghc = opt (runIdentity ( _options_ghc forwardOptionsSyntaxExtsEnabled))
+                    }
+              }
+
+  config <- fromMaybeT (pure staticDefaultConfig) (readConfigsWithUserConfig cfg (maybeToList confPath))
+  parsePrintModule config text
+
+fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
+fromMaybeT def act = runMaybeT act >>= maybe def return
+
+opt :: a -> Option a
+opt = Option . Just
+
+showErr :: BrittanyError -> String
+showErr (ErrorInput s)          = s
+showErr (ErrorMacroConfig  err input)
+  = "Error: parse error in inline configuration: " ++ err ++ " in the string \"" ++ input ++ "\"."
+showErr (ErrorUnusedComment s)  = s
+showErr (LayoutWarning s)       = s
+showErr (ErrorUnknownNode s _)  = s
+showErr ErrorOutputCheck        = "Brittany error - invalid output"

test/functional/FormatSpec.hs

@@ -84,36 +84,41 @@ spec = do
       -- formatDoc doc (FormattingOptions 2 True)
       -- documentContents doc >>= liftIO . (`shouldBe` formattedBrittanyPostFloskell)
 
-  -- describe "brittany" $ do
-  --   it "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
-  --     doc <- openDoc "BrittanyLF.hs" "haskell"
-  --     let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing
-  --     ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts
-  --     liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0))
-  --                                 "foo :: Int -> String -> IO ()\nfoo x y = do\n    print x\n    return 42\n"]
-
-  --   it "formats a document with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
-  --     doc <- openDoc "BrittanyCRLF.hs" "haskell"
-  --     let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing
-  --     ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts
-  --     liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0))
-  --                                 "foo :: Int -> String -> IO ()\nfoo x y = do\n    print x\n    return 42\n"]
-
-  --   it "formats a range with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
-  --     doc <- openDoc "BrittanyLF.hs" "haskell"
-  --     let range = Range (Position 1 0) (Position 2 22)
-  --         opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing
-  --     ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts
-  --     liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0))
-  --                                   "foo x y = do\n    print x\n    return 42\n"]
-
-  --   it "formats a range with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
-  --     doc <- openDoc "BrittanyCRLF.hs" "haskell"
-  --     let range = Range (Position 1 0) (Position 2 22)
-  --         opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing
-  --     ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts
-  --     liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0))
-  --                                   "foo x y = do\n    print x\n    return 42\n"]
+  describe "brittany" $ do
+    let formatLspConfig provider =
+          object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ]
+    it "formats a document with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
+      doc <- openDoc "BrittanyLF.hs" "haskell"
+      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
+      let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing
+      ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts
+      liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0))
+                                  "foo :: Int -> String -> IO ()\nfoo x y = do\n    print x\n    return 42\n"]
+
+    it "formats a document with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
+      doc <- openDoc "BrittanyCRLF.hs" "haskell"
+      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
+      let opts = DocumentFormattingParams doc (FormattingOptions 4 True) Nothing
+      ResponseMessage _ _ (Just edits) _ <- request TextDocumentFormatting opts
+      liftIO $ edits `shouldBe` [TextEdit (Range (Position 0 0) (Position 3 0))
+                                  "foo :: Int -> String -> IO ()\nfoo x y = do\n    print x\n    return 42\n"]
+
+    it "formats a range with LF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
+      doc <- openDoc "BrittanyLF.hs" "haskell"
+      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
+      let range = Range (Position 1 0) (Position 2 22)
+          opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing
+      ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts
+      liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0))
+                                    "foo x y = do\n    print x\n    return 42\n"]
+
+    it "formats a range with CRLF endings" $ runSession hieCommand fullCaps "test/testdata" $ do
+      doc <- openDoc "BrittanyCRLF.hs" "haskell"
+      let range = Range (Position 1 0) (Position 2 22)
+          opts = DocumentRangeFormattingParams doc range (FormattingOptions 4 True) Nothing
+      ResponseMessage _ _ (Just edits) _ <- request TextDocumentRangeFormatting opts
+      liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0))
+                                    "foo x y = do\n    print x\n    return 42\n"]
 
     -- ---------------------------------