Skip to content

Commit f846a6a

Browse files
georgefstgeorgefst
committed
Update Fourmolu to 0.2
1 parent 9f13e8f commit f846a6a

File tree

2 files changed

+90
-75
lines changed

2 files changed

+90
-75
lines changed

‎haskell-language-server.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -116,7 +116,7 @@ executable haskell-language-server
116116
, containers
117117
, deepseq
118118
, floskell ^>=0.10
119-
, fourmolu ^>=0.1
119+
, fourmolu ^>=0.2
120120
, ghc
121121
, ghc-boot-th
122122
, ghcide >=0.1

‎plugins/default/src/Ide/Plugin/Fourmolu.hs

Lines changed: 89 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -1,90 +1,105 @@
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 #-}
66

7-
module Ide.Plugin.Fourmolu
8-
(
9-
descriptor
10-
, provider
11-
)
12-
where
7+
module Ide.Plugin.Fourmolu (
8+
descriptor,
9+
provider,
10+
) where
1311

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 qualified Data.Text as T
17+
import Development.IDE as D
18+
import qualified DynFlags as D
19+
import qualified EnumSet as S
20+
import GHC (DynFlags, moduleNameString)
21+
import GHC.LanguageExtensions.Type (Extension (Cpp))
22+
import GhcPlugins (HscEnv (hsc_dflags))
23+
import Ide.Plugin.Formatter (responseError)
24+
import Ide.PluginUtils (makeDiffTextEdit)
25+
import Language.Haskell.LSP.Messages (FromServerMessage (ReqShowMessage))
26+
27+
import Ide.Types
28+
import Language.Haskell.LSP.Core
29+
import Language.Haskell.LSP.Types
2830
import "fourmolu" Ormolu
29-
import System.FilePath (takeFileName)
30-
import Text.Regex.TDFA.Text ()
3131

3232
-- ---------------------------------------------------------------------
3333

3434
descriptor :: PluginId -> PluginDescriptor
35-
descriptor plId = (defaultPluginDescriptor plId)
36-
{ pluginFormattingProvider = Just provider
37-
}
35+
descriptor plId =
36+
(defaultPluginDescriptor plId)
37+
{ pluginFormattingProvider = Just provider
38+
}
3839

3940
-- ---------------------------------------------------------------------
4041

4142
provider :: FormattingProvider IO
4243
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
44+
ghc <- runAction "Fourmolu" ideState $ use GhcSession fp
45+
fileOpts <- case hsc_dflags . hscEnv <$> ghc of
46+
Nothing -> return []
47+
Just df -> convertDynFlags df
5448

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
49+
let format printerOpts =
50+
mapLeft (responseError . ("Fourmolu: " <>) . T.pack . show)
51+
<$> try @OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T.unpack contents))
52+
where
53+
config =
54+
defaultConfig
55+
{ cfgDynOptions = fileOpts
56+
, cfgRegion = region
57+
, cfgDebug = True
58+
, cfgPrinterOpts = fillMissingPrinterOpts printerOpts defaultPrinterOpts
59+
}
6060

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)
61+
loadConfigFile fp' >>= \case
62+
ConfigLoaded file opts -> do
63+
putStrLn $ "Loaded Fourmolu config from: " <> file
64+
format opts
65+
ConfigNotFound searchDirs -> do
66+
putStrLn
67+
. unlines
68+
$ ("No " ++ show configFileName ++ " found in any of:") :
69+
map (" " ++) searchDirs
70+
format mempty
71+
ConfigParseError f (_, err) -> do
72+
sendFunc lf . ReqShowMessage $
73+
RequestMessage
74+
{ _jsonrpc = ""
75+
, _id = IdString "fourmolu"
76+
, _method = WindowShowMessageRequest
77+
, _params =
78+
ShowMessageRequestParams
79+
{ _xtype = MtError
80+
, _message = errorMessage
81+
, _actions = Nothing
82+
}
83+
}
84+
return . Left $ responseError errorMessage
85+
where
86+
errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err
87+
where
7588
fp' = fromNormalizedFilePath fp
89+
title = "Formatting " <> T.pack (takeFileName fp')
90+
region = case typ of
91+
FormatText ->
92+
RegionIndices Nothing Nothing
93+
FormatRange (Range (Position sl _) (Position el _)) ->
94+
RegionIndices (Just $ sl + 1) (Just $ el + 1)
7695

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
96+
convertDynFlags :: DynFlags -> IO [DynOption]
97+
convertDynFlags df =
98+
let pp = if null p then [] else ["-pgmF=" <> p]
99+
p = D.sPgm_F $ D.settings df
100+
pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df
101+
ex = map showExtension $ S.toList $ D.extensionFlags df
102+
showExtension = \case
103+
Cpp -> "-XCPP"
104+
x -> "-X" ++ show x
105+
in return $ map DynOption $ pp <> pm <> ex

0 commit comments

Comments
 (0)