|
1 | | -{-# LANGUAGE OverloadedStrings #-} |
2 | | -{-# LANGUAGE PackageImports #-} |
3 | | -{-# LANGUAGE RecordWildCards #-} |
4 | | -{-# LANGUAGE ScopedTypeVariables #-} |
5 | | -{-# LANGUAGE TypeApplications #-} |
| 1 | +{-# LANGUAGE LambdaCase #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE PackageImports #-} |
| 4 | +{-# LANGUAGE RecordWildCards #-} |
| 5 | +{-# LANGUAGE TypeApplications #-} |
6 | 6 |
|
7 | | -module Ide.Plugin.Fourmolu |
8 | | - ( |
9 | | - descriptor |
10 | | - , provider |
11 | | - ) |
12 | | -where |
| 7 | +module Ide.Plugin.Fourmolu ( |
| 8 | + descriptor, |
| 9 | + provider, |
| 10 | +) where |
13 | 11 |
|
14 | | -import Control.Exception |
15 | | -import qualified Data.Text as T |
16 | | -import Development.IDE as D |
17 | | -import qualified DynFlags as D |
18 | | -import qualified EnumSet as S |
19 | | -import GHC |
20 | | -import GHC.LanguageExtensions.Type |
21 | | -import GhcPlugins (HscEnv (hsc_dflags)) |
22 | | -import Ide.Plugin.Formatter |
23 | | -import Ide.PluginUtils |
24 | | -import Ide.Types |
25 | | -import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), |
26 | | - ProgressCancellable (Cancellable)) |
27 | | -import Language.Haskell.LSP.Types |
| 12 | +import Control.Exception |
| 13 | +import Data.Either.Extra |
| 14 | +import System.FilePath |
| 15 | + |
| 16 | +import Control.Lens ((^.)) |
| 17 | +import qualified Data.Text as T |
| 18 | +import Development.IDE as D |
| 19 | +import qualified DynFlags as D |
| 20 | +import qualified EnumSet as S |
| 21 | +import GHC (DynFlags, moduleNameString) |
| 22 | +import GHC.LanguageExtensions.Type (Extension (Cpp)) |
| 23 | +import GhcPlugins (HscEnv (hsc_dflags)) |
| 24 | +import Ide.Plugin.Formatter (responseError) |
| 25 | +import Ide.PluginUtils (makeDiffTextEdit) |
| 26 | +import Language.Haskell.LSP.Messages (FromServerMessage (ReqShowMessage)) |
| 27 | + |
| 28 | +import Ide.Types |
| 29 | +import Language.Haskell.LSP.Core |
| 30 | +import Language.Haskell.LSP.Types |
| 31 | +import Language.Haskell.LSP.Types.Lens |
28 | 32 | import "fourmolu" Ormolu |
29 | | -import System.FilePath (takeFileName) |
30 | | -import Text.Regex.TDFA.Text () |
31 | 33 |
|
32 | 34 | -- --------------------------------------------------------------------- |
33 | 35 |
|
34 | 36 | descriptor :: PluginId -> PluginDescriptor |
35 | | -descriptor plId = (defaultPluginDescriptor plId) |
36 | | - { pluginFormattingProvider = Just provider |
37 | | - } |
| 37 | +descriptor plId = |
| 38 | + (defaultPluginDescriptor plId) |
| 39 | + { pluginFormattingProvider = Just provider |
| 40 | + } |
38 | 41 |
|
39 | 42 | -- --------------------------------------------------------------------- |
40 | 43 |
|
41 | 44 | provider :: FormattingProvider IO |
42 | | -provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do |
43 | | - let |
44 | | - fromDyn :: DynFlags -> IO [DynOption] |
45 | | - fromDyn df = |
46 | | - let |
47 | | - pp = |
48 | | - let p = D.sPgm_F $ D.settings df |
49 | | - in if null p then [] else ["-pgmF=" <> p] |
50 | | - pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df |
51 | | - ex = map showExtension $ S.toList $ D.extensionFlags df |
52 | | - in |
53 | | - return $ map DynOption $ pp <> pm <> ex |
| 45 | +provider lf ideState typ contents fp fo = withIndefiniteProgress lf title Cancellable $ do |
| 46 | + ghc <- runAction "Fourmolu" ideState $ use GhcSession fp |
| 47 | + fileOpts <- case hsc_dflags . hscEnv <$> ghc of |
| 48 | + Nothing -> return [] |
| 49 | + Just df -> convertDynFlags df |
54 | 50 |
|
55 | | - ghc <- runAction "Fourmolu" ideState $ use GhcSession fp |
56 | | - let df = hsc_dflags . hscEnv <$> ghc |
57 | | - fileOpts <- case df of |
58 | | - Nothing -> return [] |
59 | | - Just df -> fromDyn df |
| 51 | + let format printerOpts = |
| 52 | + mapLeft (responseError . ("Fourmolu: " <>) . T.pack . show) |
| 53 | + <$> try @OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T.unpack contents)) |
| 54 | + where |
| 55 | + config = |
| 56 | + defaultConfig |
| 57 | + { cfgDynOptions = fileOpts |
| 58 | + , cfgRegion = region |
| 59 | + , cfgDebug = True |
| 60 | + , cfgPrinterOpts = |
| 61 | + fillMissingPrinterOpts |
| 62 | + (lspPrinterOpts <> printerOpts) |
| 63 | + defaultPrinterOpts |
| 64 | + } |
60 | 65 |
|
61 | | - let |
62 | | - fullRegion = RegionIndices Nothing Nothing |
63 | | - rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1) |
64 | | - mkConf o region = do |
65 | | - printerOpts <- loadConfigFile True (Just fp') defaultPrinterOpts |
66 | | - return $ defaultConfig |
67 | | - { cfgDynOptions = o |
68 | | - , cfgRegion = region |
69 | | - , cfgDebug = True |
70 | | - , cfgPrinterOpts = printerOpts |
71 | | - } |
72 | | - fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) |
73 | | - fmt cont conf = |
74 | | - try @OrmoluException (ormolu conf fp' $ T.unpack cont) |
| 66 | + loadConfigFile fp' >>= \case |
| 67 | + ConfigLoaded file opts -> do |
| 68 | + putStrLn $ "Loaded Fourmolu config from: " <> file |
| 69 | + format opts |
| 70 | + ConfigNotFound searchDirs -> do |
| 71 | + putStrLn |
| 72 | + . unlines |
| 73 | + $ ("No " ++ show configFileName ++ " found in any of:") : |
| 74 | + map (" " ++) searchDirs |
| 75 | + format mempty |
| 76 | + ConfigParseError f (_, err) -> do |
| 77 | + sendFunc lf . ReqShowMessage $ |
| 78 | + RequestMessage |
| 79 | + { _jsonrpc = "" |
| 80 | + , _id = IdString "fourmolu" |
| 81 | + , _method = WindowShowMessageRequest |
| 82 | + , _params = |
| 83 | + ShowMessageRequestParams |
| 84 | + { _xtype = MtError |
| 85 | + , _message = errorMessage |
| 86 | + , _actions = Nothing |
| 87 | + } |
| 88 | + } |
| 89 | + return . Left $ responseError errorMessage |
| 90 | + where |
| 91 | + errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err |
| 92 | + where |
75 | 93 | fp' = fromNormalizedFilePath fp |
| 94 | + title = "Formatting " <> T.pack (takeFileName fp') |
| 95 | + lspPrinterOpts = mempty{poIndentation = Just $ fo ^. tabSize} |
| 96 | + region = case typ of |
| 97 | + FormatText -> |
| 98 | + RegionIndices Nothing Nothing |
| 99 | + FormatRange (Range (Position sl _) (Position el _)) -> |
| 100 | + RegionIndices (Just $ sl + 1) (Just $ el + 1) |
76 | 101 |
|
77 | | - case typ of |
78 | | - FormatText -> ret <$> (fmt contents =<< mkConf fileOpts fullRegion) |
79 | | - FormatRange (Range (Position sl _) (Position el _)) -> |
80 | | - ret <$> (fmt contents =<< mkConf fileOpts (rangeRegion sl el)) |
81 | | - where |
82 | | - title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) |
83 | | - ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) |
84 | | - ret (Left err) = Left |
85 | | - (responseError (T.pack $ "fourmoluCmd: " ++ show err) ) |
86 | | - ret (Right new) = Right (makeDiffTextEdit contents new) |
87 | | - |
88 | | -showExtension :: Extension -> String |
89 | | -showExtension Cpp = "-XCPP" |
90 | | -showExtension other = "-X" ++ show other |
| 102 | +convertDynFlags :: DynFlags -> IO [DynOption] |
| 103 | +convertDynFlags df = |
| 104 | + let pp = if null p then [] else ["-pgmF=" <> p] |
| 105 | + p = D.sPgm_F $ D.settings df |
| 106 | + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df |
| 107 | + ex = map showExtension $ S.toList $ D.extensionFlags df |
| 108 | + showExtension = \case |
| 109 | + Cpp -> "-XCPP" |
| 110 | + x -> "-X" ++ show x |
| 111 | + in return $ map DynOption $ pp <> pm <> ex |
0 commit comments