{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Ide.Plugin.Fourmolu (
descriptor,
provider,
) where
import Control.Exception (try)
import Control.Lens ((^.))
import Control.Monad.IO.Class
import Data.Bifunctor (first)
import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers)
import Development.IDE.GHC.Compat as Compat hiding (Cpp)
import qualified Development.IDE.GHC.Compat.Util as S
import GHC.LanguageExtensions.Type (Extension (Cpp))
import Ide.PluginUtils (makeDiffTextEdit)
import Ide.Types
import Language.LSP.Server hiding (defaultConfig)
import Language.LSP.Types
import Language.LSP.Types.Lens (HasTabSize (tabSize))
import Ormolu
import System.FilePath
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
(PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = FormattingHandler IdeState -> PluginHandlers IdeState
forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers FormattingHandler IdeState
provider
}
provider :: FormattingHandler IdeState
provider :: FormattingHandler IdeState
provider IdeState
ideState FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
fo = Text
-> ProgressCancellable
-> LspT Config IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
title ProgressCancellable
Cancellable (LspT Config IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> LspT Config IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ do
Maybe HscEnvEq
ghc <- IO (Maybe HscEnvEq) -> LspT Config IO (Maybe HscEnvEq)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HscEnvEq) -> LspT Config IO (Maybe HscEnvEq))
-> IO (Maybe HscEnvEq) -> LspT Config IO (Maybe HscEnvEq)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState -> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Fourmolu" IdeState
ideState (Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq))
-> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)
forall a b. (a -> b) -> a -> b
$ GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
fp
[DynOption]
fileOpts <- case HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv (HscEnvEq -> DynFlags) -> Maybe HscEnvEq -> Maybe DynFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HscEnvEq
ghc of
Maybe DynFlags
Nothing -> [DynOption] -> LspT Config IO [DynOption]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just DynFlags
df -> IO [DynOption] -> LspT Config IO [DynOption]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DynOption] -> LspT Config IO [DynOption])
-> IO [DynOption] -> LspT Config IO [DynOption]
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO [DynOption]
convertDynFlags DynFlags
df
let format :: PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit))
format PrinterOpts Maybe
printerOpts =
(OrmoluException -> ResponseError)
-> Either OrmoluException (List TextEdit)
-> Either ResponseError (List TextEdit)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ResponseError
responseError (Text -> ResponseError)
-> (OrmoluException -> Text) -> OrmoluException -> ResponseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Fourmolu: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> (OrmoluException -> Text) -> OrmoluException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (OrmoluException -> String) -> OrmoluException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrmoluException -> String
forall a. Show a => a -> String
show)
(Either OrmoluException (List TextEdit)
-> Either ResponseError (List TextEdit))
-> IO (Either OrmoluException (List TextEdit))
-> IO (Either ResponseError (List TextEdit))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (List TextEdit) -> IO (Either OrmoluException (List TextEdit))
forall e a. Exception e => IO a -> IO (Either e a)
try @OrmoluException (Text -> Text -> List TextEdit
makeDiffTextEdit Text
contents (Text -> List TextEdit) -> IO Text -> IO (List TextEdit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config RegionIndices -> String -> String -> IO Text
forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> String -> m Text
ormolu Config RegionIndices
config String
fp' (Text -> String
T.unpack Text
contents))
where
config :: Config RegionIndices
config =
Config RegionIndices
defaultConfig
{ cfgDynOptions :: [DynOption]
cfgDynOptions = [DynOption]
fileOpts
, cfgRegion :: RegionIndices
cfgRegion = RegionIndices
region
, cfgDebug :: Bool
cfgDebug = Bool
True
, cfgPrinterOpts :: PrinterOptsTotal
cfgPrinterOpts =
PrinterOpts Maybe -> PrinterOptsTotal -> PrinterOptsTotal
forall (f :: * -> *).
Applicative f =>
PrinterOpts Maybe -> PrinterOpts f -> PrinterOpts f
fillMissingPrinterOpts
(PrinterOpts Maybe
printerOpts PrinterOpts Maybe -> PrinterOpts Maybe -> PrinterOpts Maybe
forall a. Semigroup a => a -> a -> a
<> PrinterOpts Maybe
lspPrinterOpts)
PrinterOptsTotal
defaultPrinterOpts
}
IO ConfigFileLoadResult -> LspT Config IO ConfigFileLoadResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ConfigFileLoadResult
loadConfigFile String
fp') LspT Config IO ConfigFileLoadResult
-> (ConfigFileLoadResult
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ConfigLoaded String
file PrinterOpts Maybe
opts -> IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Loaded Fourmolu config from: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file
PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit))
format PrinterOpts Maybe
opts
ConfigNotFound [String]
searchDirs -> IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn
(String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ (String
"No " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
configFileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found in any of:") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
searchDirs
PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit))
format PrinterOpts Maybe
forall a. Monoid a => a
mempty
ConfigParseError String
f (Pos
_, String
err) -> do
SServerMethod 'WindowShowMessage
-> MessageParams 'WindowShowMessage -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'WindowShowMessage
SWindowShowMessage (MessageParams 'WindowShowMessage -> LspT Config IO ())
-> MessageParams 'WindowShowMessage -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
ShowMessageParams :: MessageType -> Text -> ShowMessageParams
ShowMessageParams
{ $sel:_xtype:ShowMessageParams :: MessageType
_xtype = MessageType
MtError
, $sel:_message:ShowMessageParams :: Text
_message = Text
errorMessage
}
Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> (ResponseError -> Either ResponseError (List TextEdit))
-> ResponseError
-> LspT Config IO (Either ResponseError (List TextEdit))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> Either ResponseError (List TextEdit)
forall a b. a -> Either a b
Left (ResponseError
-> LspT Config IO (Either ResponseError (List TextEdit)))
-> ResponseError
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError Text
errorMessage
where
errorMessage :: Text
errorMessage = Text
"Failed to load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
where
fp' :: String
fp' = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
fp
title :: Text
title = Text
"Formatting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
takeFileName String
fp')
lspPrinterOpts :: PrinterOpts Maybe
lspPrinterOpts = PrinterOpts Maybe
forall a. Monoid a => a
mempty{poIndentation :: Maybe Int
poIndentation = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ FormattingOptions
fo FormattingOptions -> Getting UInt FormattingOptions UInt -> UInt
forall s a. s -> Getting a s a -> a
^. Getting UInt FormattingOptions UInt
forall s a. HasTabSize s a => Lens' s a
tabSize}
region :: RegionIndices
region = case FormattingType
typ of
FormattingType
FormatText ->
Maybe Int -> Maybe Int -> RegionIndices
RegionIndices Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
FormatRange (Range (Position UInt
sl UInt
_) (Position UInt
el UInt
_)) ->
Maybe Int -> Maybe Int -> RegionIndices
RegionIndices (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
sl UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
el UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1)
convertDynFlags :: DynFlags -> IO [DynOption]
convertDynFlags :: DynFlags -> IO [DynOption]
convertDynFlags DynFlags
df =
let pp :: [String]
pp = [String
"-pgmF=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p)]
p :: String
p = Settings -> String
sPgm_F (Settings -> String) -> Settings -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
Compat.settings DynFlags
df
pm :: [String]
pm = (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"-fplugin=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (ModuleName -> String) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString) ([ModuleName] -> [String]) -> [ModuleName] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModuleName]
pluginModNames DynFlags
df
ex :: [String]
ex = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
showExtension ([Extension] -> [String]) -> [Extension] -> [String]
forall a b. (a -> b) -> a -> b
$ EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
S.toList (EnumSet Extension -> [Extension])
-> EnumSet Extension -> [Extension]
forall a b. (a -> b) -> a -> b
$ DynFlags -> EnumSet Extension
extensionFlags DynFlags
df
showExtension :: Extension -> String
showExtension = \case
Extension
Cpp -> String
"-XCPP"
Extension
x -> String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Extension -> String
forall a. Show a => a -> String
show Extension
x
in [DynOption] -> IO [DynOption]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DynOption] -> IO [DynOption]) -> [DynOption] -> IO [DynOption]
forall a b. (a -> b) -> a -> b
$ (String -> DynOption) -> [String] -> [DynOption]
forall a b. (a -> b) -> [a] -> [b]
map String -> DynOption
DynOption ([String] -> [DynOption]) -> [String] -> [DynOption]
forall a b. (a -> b) -> a -> b
$ [String]
pp [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
pm [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ex