diff --git a/exe/Main.hs b/exe/Main.hs index 0835c38675..05140584db 100644 --- a/exe/Main.hs +++ b/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..." diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 23731e1850..677f574404 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/src/Ide/Plugin/Brittany.hs b/src/Ide/Plugin/Brittany.hs new file mode 100644 index 0000000000..5281e847fb --- /dev/null +++ b/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" diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 66db73c202..f323cb7feb 100644 --- a/test/functional/FormatSpec.hs +++ b/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"] -- --------------------------------- diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 7cb70cc1e4..fce8d4bd23 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -12,7 +12,6 @@ module TestUtils -- , runIGM' , ghcVersion, GhcVersion(..) , logFilePath - , readResolver , hieCommand , hieCommandVomit , hieCommandExamplePlugin @@ -112,27 +111,9 @@ withFileLogging logFile f = do -- --------------------------------------------------------------------- --- If an executable @stack@ is present on the system then setup stack files, --- otherwise specify a direct cradle with -isrc setupBuildToolFiles :: IO () setupBuildToolFiles = do - stack <- findExecutable "stack" - let s = case stack of - Nothing -> setupDirectFilesIn - Just _ -> setupStackFilesIn - forM_ files $ \f -> do - s f - -- Cleanup stack directory in case the presence of stack has changed since - -- the last run - removePathForcibly (f ++ ".stack-work") - -setupStackFilesIn :: FilePath -> IO () -setupStackFilesIn f = do - resolver <- readResolver - writeFile (f ++ "stack.yaml") $ stackFileContents resolver - case f of - "./test/testdata/" -> writeFile (f ++ "hie.yaml") testdataHieYamlCradleStackContents - _ -> writeFile (f ++ "hie.yaml") hieYamlCradleStackContents + forM_ files setupDirectFilesIn setupDirectFilesIn :: FilePath -> IO () setupDirectFilesIn f = @@ -172,32 +153,8 @@ ghcVersion = GHC86 ghcVersion = GHC84 #endif -stackYaml :: FilePath -stackYaml = -#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,2,0))) - "stack-8.8.2.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0))) - "stack-8.8.1.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,5,0))) - "stack-8.6.5.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,4,0))) - "stack-8.6.4.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,3,0))) - "stack-8.6.3.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,2,0))) - "stack-8.6.2.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,1,0))) - "stack-8.6.1.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,4,0))) - "stack-8.4.4.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0))) - "stack-8.4.3.yaml" -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,2,0))) - "stack-8.4.2.yaml" -#endif - logFilePath :: String -logFilePath = "hie-" ++ stackYaml ++ ".log" +logFilePath = "hie-" ++ show ghcVersion ++ ".log" -- | The command to execute the version of hie for the current compiler. -- @@ -216,92 +173,17 @@ hieCommandVomit = hieCommand ++ " --vomit" hieCommandExamplePlugin :: String hieCommandExamplePlugin = hieCommand ++ " --example" --- |Choose a resolver based on the current compiler, otherwise HaRe/ghc-mod will --- not be able to load the files -readResolver :: IO String -readResolver = readResolverFrom stackYaml - -newtype StackResolver = StackResolver String - -instance FromJSON StackResolver where - parseJSON (Object x) = StackResolver <$> x .: pack "resolver" - parseJSON invalid = typeMismatch "StackResolver" invalid - -readResolverFrom :: FilePath -> IO String -readResolverFrom yamlPath = do - result <- decodeFileEither yamlPath - case result of - Left err -> error $ yamlPath ++ " parsing failed: " ++ show err - Right (StackResolver res) -> return res - -- --------------------------------------------------------------------- -hieYamlCradleStackContents :: String -hieYamlCradleStackContents = unlines - [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" - , "cradle:" - , " stack:" - ] - -testdataHieYamlCradleStackContents :: String -testdataHieYamlCradleStackContents = unlines - [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" - , "cradle:" - , " stack:" - -- , " - path: \"ApplyRefact.hs\"" - -- , " component: \"testdata:exe:applyrefact\"" - -- , " - path: \"ApplyRefact2.hs\"" - -- , " component: \"testdata:exe:applyrefact2\"" - -- , " - path: \"CodeActionRename.hs\"" - -- , " component: \"testdata:exe:codeactionrename\"" - -- , " - path: \"Hover.hs\"" - -- , " component: \"testdata:exe:hover\"" - -- , " - path: \"Symbols.hs\"" - -- , " component: \"testdata:exe:symbols\"" - -- , " - path: \"ApplyRefact2.hs\"" - -- , " component: \"testdata:exe:applyrefact2\"" - -- , " - path: \"HlintPragma.hs\"" - -- , " component: \"testdata:exe:hlintpragma\"" - -- , " - path: \"HaReCase.hs\"" - -- , " component: \"testdata:exe:harecase\"" - -- , " - path: \"HaReDemote.hs\"" - -- , " component: \"testdata:exe:haredemote\"" - -- , " - path: \"HaReMoveDef.hs\"" - -- , " component: \"testdata:exe:haremovedef\"" - -- , " - path: \"HaReRename.hs\"" - -- , " component: \"testdata:exe:harerename\"" - -- , " - path: \"HaReGA1.hs\"" - -- , " component: \"testdata:exe:haregenapplicative\"" - -- , " - path: \"FuncTest.hs\"" - -- , " component: \"testdata:exe:functests\"" - -- , " - path: \"liquid/Evens.hs\"" - -- , " component: \"testdata:exe:evens\"" - -- , " - path: \"FileWithWarning.hs\"" - -- , " component: \"testdata:exe:filewithwarning\"" - -- , " - path: ." - -- , " component: \"testdata:exe:filewithwarning\"" - ] - - hieYamlCradleDirectContents :: String hieYamlCradleDirectContents = unlines [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" , "cradle:" , " direct:" , " arguments:" - , " - -isrc" + , " - -i." ] -stackFileContents :: String -> String -stackFileContents resolver = unlines - [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" - , "resolver: " ++ resolver - , "packages:" - , "- '.'" - , "extra-deps: []" - , "flags: {}" - , "extra-package-dbs: []" - ] -- ---------------------------------------------------------------------