{-# 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  (moduleNameString)
import qualified DynFlags                    as D
import qualified EnumSet                     as S
import           GHC.LanguageExtensions.Type (Extension (Cpp))
import           GhcPlugins                  (HscEnv (hsc_dflags))
import           Ide.PluginUtils             (makeDiffTextEdit)
import           Ide.Types
import           Language.LSP.Server         hiding (defaultConfig)
import           Language.LSP.Types
import           Language.LSP.Types.Lens
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
$ FormattingOptions
fo FormattingOptions -> Getting Int FormattingOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int FormattingOptions Int
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 Int
sl Int
_) (Position Int
el Int
_)) ->
            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
$ Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
el Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

convertDynFlags :: D.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
D.sPgm_F (Settings -> String) -> Settings -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
D.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]
D.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
D.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