{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Ide.Plugin.Fourmolu (
    descriptor,
    provider,
    LogEvent,
) where

import           Control.Exception
import           Control.Lens                    ((^.))
import           Control.Monad                   (guard)
import           Control.Monad.Error.Class       (MonadError (throwError))
import           Control.Monad.IO.Class          (MonadIO (liftIO))
import           Control.Monad.Trans.Class       (MonadTrans (lift))
import           Control.Monad.Trans.Except      (ExceptT (..), runExceptT)
import           Data.Bifunctor                  (bimap)
import           Data.List                       (intercalate)
import           Data.Maybe                      (catMaybes)
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Data.Version                    (showVersion)
import           Development.IDE                 hiding (pluginHandlers)
import           Development.IDE.GHC.Compat      as Compat hiding (Cpp, Warning,
                                                            hang, vcat)
import qualified Development.IDE.GHC.Compat.Util as S
import           GHC.LanguageExtensions.Type     (Extension (Cpp))
import           Ide.Plugin.Error
import           Ide.Plugin.Properties
import           Ide.PluginUtils                 (makeDiffTextEdit)
import           Ide.Types
import           Language.LSP.Protocol.Lens      (HasTabSize (tabSize))
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server             hiding (defaultConfig)
import           Ormolu
import           Ormolu.Config
import qualified Paths_fourmolu                  as Fourmolu
import           System.Exit
import           System.FilePath
import           System.Process.Run              (cwd, proc)
import           System.Process.Text             (readCreateProcessWithExitCode)
import           Text.Read                       (readMaybe)

#if MIN_VERSION_fourmolu(0,16,0)
import qualified Data.Yaml                       as Yaml
#endif

descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority LogEvent)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority LogEvent)
recorder PluginId
plId =
    (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
        { pluginHandlers = mkFormattingHandlers $ provider recorder plId
        , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties}
        }
  where
    desc :: Text
desc = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Provides formatting of Haskell files via fourmolu. Built with fourmolu-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
Fourmolu.version

properties :: Properties '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
properties :: Properties
  '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
properties =
    Properties '[]
emptyProperties
        Properties '[]
-> (Properties '[] -> Properties '[ 'PropertyKey "path" 'TString])
-> Properties '[ 'PropertyKey "path" 'TString]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "path"
-> Text
-> Text
-> Properties '[]
-> Properties '[ 'PropertyKey "path" 'TString]
forall (s :: Symbol) (r :: [PropertyKey]).
(KnownSymbol s, NotElem s r) =>
KeyNameProxy s
-> Text
-> Text
-> Properties r
-> Properties ('PropertyKey s 'TString : r)
defineStringProperty
            #path
            Text
"Set path to executable (for \"external\" mode)."
            Text
"fourmolu"
        Properties '[ 'PropertyKey "path" 'TString]
-> (Properties '[ 'PropertyKey "path" 'TString]
    -> Properties
         '[ 'PropertyKey "external" 'TBoolean,
            'PropertyKey "path" 'TString])
-> Properties
     '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "external"
-> Text
-> Bool
-> Properties '[ 'PropertyKey "path" 'TString]
-> Properties
     '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
forall (s :: Symbol) (r :: [PropertyKey]).
(KnownSymbol s, NotElem s r) =>
KeyNameProxy s
-> Text
-> Bool
-> Properties r
-> Properties ('PropertyKey s 'TBoolean : r)
defineBooleanProperty
            #external
            Text
"Call out to an external \"fourmolu\" executable, rather than using the bundled library."
            Bool
False

provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState
provider :: Recorder (WithPriority LogEvent)
-> PluginId -> FormattingHandler IdeState
provider Recorder (WithPriority LogEvent)
recorder PluginId
plId IdeState
ideState Maybe ProgressToken
token FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
fo = HandlerM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HandlerM Config (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> HandlerM Config ())
    -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall config a.
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> HandlerM config ()) -> HandlerM config a)
-> HandlerM config a
pluginWithIndefiniteProgress Text
title Maybe ProgressToken
token ProgressCancellable
Cancellable (((Text -> HandlerM Config ())
  -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
 -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> ((Text -> HandlerM Config ())
    -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ \Text -> HandlerM Config ()
_updater -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
 -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ do
    [String]
fileOpts <-
        [String] -> (HscEnvEq -> [String]) -> Maybe HscEnvEq -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (DynFlags -> [String]
convertDynFlags (DynFlags -> [String])
-> (HscEnvEq -> DynFlags) -> HscEnvEq -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv)
            (Maybe HscEnvEq -> [String])
-> ExceptT PluginError (HandlerM Config) (Maybe HscEnvEq)
-> ExceptT PluginError (HandlerM Config) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe HscEnvEq)
-> ExceptT PluginError (HandlerM Config) (Maybe HscEnvEq)
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
    Bool
useCLI <- IO Bool -> ExceptT PluginError (HandlerM Config) Bool
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT PluginError (HandlerM Config) Bool)
-> IO Bool -> ExceptT PluginError (HandlerM Config) Bool
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Bool -> IO Bool
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Fourmolu" IdeState
ideState (Action Bool -> IO Bool) -> Action Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "external"
-> PluginId
-> Properties
     '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
-> Action
     (ToHsType
        (FindByKeyName
           "external"
           '[ 'PropertyKey "external" 'TBoolean,
              'PropertyKey "path" 'TString]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "external"
#external PluginId
plId Properties
  '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
properties
    String
fourmoluExePath <- (Text -> String)
-> ExceptT PluginError (HandlerM Config) Text
-> ExceptT PluginError (HandlerM Config) String
forall a b.
(a -> b)
-> ExceptT PluginError (HandlerM Config) a
-> ExceptT PluginError (HandlerM Config) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack (ExceptT PluginError (HandlerM Config) Text
 -> ExceptT PluginError (HandlerM Config) String)
-> ExceptT PluginError (HandlerM Config) Text
-> ExceptT PluginError (HandlerM Config) String
forall a b. (a -> b) -> a -> b
$ IO Text -> ExceptT PluginError (HandlerM Config) Text
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT PluginError (HandlerM Config) Text)
-> IO Text -> ExceptT PluginError (HandlerM Config) Text
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Text -> IO Text
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Fourmolu" IdeState
ideState (Action Text -> IO Text) -> Action Text -> IO Text
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "path"
-> PluginId
-> Properties
     '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
-> Action
     (ToHsType
        (FindByKeyName
           "path"
           '[ 'PropertyKey "external" 'TBoolean,
              'PropertyKey "path" 'TString]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "path"
#path PluginId
plId Properties
  '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]
properties
    if Bool
useCLI
        then HandlerM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HandlerM Config (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> (IO (Either PluginError ([TextEdit] |? Null))
    -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either PluginError ([TextEdit] |? Null))
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall a. IO a -> HandlerM Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$
                forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle @IOException (Either PluginError ([TextEdit] |? Null)
-> IO (Either PluginError ([TextEdit] |? Null))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError ([TextEdit] |? Null)
 -> IO (Either PluginError ([TextEdit] |? Null)))
-> (IOException -> Either PluginError ([TextEdit] |? Null))
-> IOException
-> IO (Either PluginError ([TextEdit] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginError -> Either PluginError ([TextEdit] |? Null)
forall a b. a -> Either a b
Left (PluginError -> Either PluginError ([TextEdit] |? Null))
-> (IOException -> PluginError)
-> IOException
-> Either PluginError ([TextEdit] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PluginError
PluginInternalError (Text -> PluginError)
-> (IOException -> Text) -> IOException -> PluginError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (IOException -> String) -> IOException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show) (IO (Either PluginError ([TextEdit] |? Null))
 -> IO (Either PluginError ([TextEdit] |? Null)))
-> IO (Either PluginError ([TextEdit] |? Null))
-> IO (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$
                    ExceptT PluginError IO ([TextEdit] |? Null)
-> IO (Either PluginError ([TextEdit] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (String -> [String] -> ExceptT PluginError IO ([TextEdit] |? Null)
cliHandler String
fourmoluExePath [String]
fileOpts)
        else do
            Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError (HandlerM Config) ())
-> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ String -> LogEvent
LogCompiledInVersion (Version -> String
showVersion Version
Fourmolu.version)
            FourmoluConfig{PrinterOptsPartial
ModuleReexports
FixityOverrides
cfgFilePrinterOpts :: PrinterOptsPartial
cfgFileFixities :: FixityOverrides
cfgFileReexports :: ModuleReexports
cfgFilePrinterOpts :: FourmoluConfig -> PrinterOptsPartial
cfgFileFixities :: FourmoluConfig -> FixityOverrides
cfgFileReexports :: FourmoluConfig -> ModuleReexports
..} <- Recorder (WithPriority LogEvent)
-> String -> ExceptT PluginError (HandlerM Config) FourmoluConfig
loadConfig Recorder (WithPriority LogEvent)
recorder String
fp'
            let config :: Config RegionIndices
config =
                    SourceType
-> Maybe CabalInfo
-> Maybe FixityOverrides
-> Maybe ModuleReexports
-> Config RegionIndices
-> Config RegionIndices
forall region.
SourceType
-> Maybe CabalInfo
-> Maybe FixityOverrides
-> Maybe ModuleReexports
-> Config region
-> Config region
refineConfig SourceType
ModuleSource Maybe CabalInfo
forall a. Maybe a
Nothing Maybe FixityOverrides
forall a. Maybe a
Nothing Maybe ModuleReexports
forall a. Maybe a
Nothing (Config RegionIndices -> Config RegionIndices)
-> Config RegionIndices -> Config RegionIndices
forall a b. (a -> b) -> a -> b
$
                        Config RegionIndices
defaultConfig
                            { cfgDynOptions = map DynOption fileOpts
                            , cfgFixityOverrides = cfgFileFixities
                            , cfgRegion = region
                            , cfgDebug = False
                            , cfgPrinterOpts = resolvePrinterOpts [lspPrinterOpts, cfgFilePrinterOpts]
                            }
            HandlerM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HandlerM Config (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> (IO (Either PluginError ([TextEdit] |? Null))
    -> HandlerM Config (Either PluginError ([TextEdit] |? Null)))
-> IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either PluginError ([TextEdit] |? Null))
-> HandlerM Config (Either PluginError ([TextEdit] |? Null))
forall a. IO a -> HandlerM Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$
                (OrmoluException -> PluginError)
-> (Text -> [TextEdit] |? Null)
-> Either OrmoluException Text
-> Either PluginError ([TextEdit] |? Null)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> PluginError
PluginInternalError (Text -> PluginError)
-> (OrmoluException -> Text) -> OrmoluException -> PluginError
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) ([TextEdit] -> [TextEdit] |? Null
forall a b. a -> a |? b
InL ([TextEdit] -> [TextEdit] |? Null)
-> (Text -> [TextEdit]) -> Text -> [TextEdit] |? Null
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents)
                    (Either OrmoluException Text
 -> Either PluginError ([TextEdit] |? Null))
-> IO (Either OrmoluException Text)
-> IO (Either PluginError ([TextEdit] |? Null))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try @OrmoluException (Config RegionIndices -> String -> Text -> IO Text
forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> Text -> m Text
ormolu Config RegionIndices
config String
fp' Text
contents)
  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 :: PrinterOptsPartial
lspPrinterOpts = PrinterOptsPartial
forall a. Monoid a => a
mempty{poIndentation = Just $ fromIntegral $ fo ^. 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)
    cliHandler :: FilePath -> [String] -> ExceptT PluginError IO ([TextEdit] |? Null)
    cliHandler :: String -> [String] -> ExceptT PluginError IO ([TextEdit] |? Null)
cliHandler String
path [String]
fileOpts = do
        CLIVersionInfo{Bool
noCabal :: Bool
noCabal :: CLIVersionInfo -> Bool
noCabal} <- do -- check Fourmolu version so that we know which flags to use
            (ExitCode
exitCode, Text
out, Text
_err) <- IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode ( String -> [String] -> CreateProcess
proc String
path [String
"-v"] ) Text
""
            let version :: Maybe [Int]
version = do
                    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
                    Text
"fourmolu" : Text
v : [Text]
_ <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
out
                    (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (forall a. Read a => String -> Maybe a
readMaybe @Int (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> Maybe [Int]) -> [Text] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
v
            case Maybe [Int]
version of
                Just [Int]
v -> do
                    Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> LogEvent
LogExternalVersion [Int]
v
                    CLIVersionInfo -> ExceptT PluginError IO CLIVersionInfo
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
                        { noCabal :: Bool
noCabal = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
0, Int
7]
                        }
                Maybe [Int]
Nothing -> do
                    Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> LogEvent
LogExternalVersion []
                    Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Warning (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
NoVersion Text
out
                    CLIVersionInfo -> ExceptT PluginError IO CLIVersionInfo
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
                        { noCabal :: Bool
noCabal = Bool
True
                        }
        (ExitCode
exitCode, Text
out, Text
err) <- -- run Fourmolu
            IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode
                ( String -> [String] -> CreateProcess
proc String
path ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$
                    (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-o" <>) [String]
fileOpts
                        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Bool -> [String] -> [String]
forall a. Monoid a => Bool -> a -> a
mwhen Bool
noCabal [String
"--no-cabal"]
                        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
                            [ (String
"--start-line=" <>) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Maybe Int -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionStartLine RegionIndices
region
                            , (String
"--end-line=" <>) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Maybe Int -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionEndLine RegionIndices
region
                            ]
                ){cwd = Just $ takeDirectory fp'}
                Text
contents
        case ExitCode
exitCode of
            ExitCode
ExitSuccess -> do
                Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
                ([TextEdit] |? Null) -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TextEdit] |? Null)
 -> ExceptT PluginError IO ([TextEdit] |? Null))
-> ([TextEdit] |? Null)
-> ExceptT PluginError IO ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> [TextEdit] |? Null
forall a b. a -> a |? b
InL ([TextEdit] -> [TextEdit] |? Null)
-> [TextEdit] -> [TextEdit] |? Null
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents Text
out
            ExitFailure Int
n -> do
                Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
                PluginError -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError IO ([TextEdit] |? Null))
-> PluginError -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ Text
"Fourmolu failed with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)

loadConfig ::
    Recorder (WithPriority LogEvent) ->
    FilePath ->
    ExceptT PluginError (HandlerM Ide.Types.Config) FourmoluConfig
#if MIN_VERSION_fourmolu(0,16,0)
loadConfig recorder fp = do
    liftIO (findConfigFile fp) >>= \case
        Left (ConfigNotFound searchDirs) -> do
            logWith recorder Info $ NoConfigPath searchDirs
            pure emptyConfig
        Right file -> do
            logWith recorder Info $ ConfigPath file
            liftIO (Yaml.decodeFileEither file) >>= \case
                Left err -> do
                    let errorMessage = "Failed to load " <> T.pack file <> ": " <> T.pack (show err)
                    lift $ pluginSendNotification SMethod_WindowShowMessage $
                        ShowMessageParams
                            { _type_ = MessageType_Error
                            , _message = errorMessage
                            }
                    throwError $ PluginInternalError errorMessage
                Right cfg -> do
                  pure cfg
#else
loadConfig :: Recorder (WithPriority LogEvent)
-> String -> ExceptT PluginError (HandlerM Config) FourmoluConfig
loadConfig Recorder (WithPriority LogEvent)
recorder String
fp = do
    IO ConfigFileLoadResult
-> ExceptT PluginError (HandlerM Config) ConfigFileLoadResult
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ConfigFileLoadResult
loadConfigFile String
fp) ExceptT PluginError (HandlerM Config) ConfigFileLoadResult
-> (ConfigFileLoadResult
    -> ExceptT PluginError (HandlerM Config) FourmoluConfig)
-> ExceptT PluginError (HandlerM Config) FourmoluConfig
forall a b.
ExceptT PluginError (HandlerM Config) a
-> (a -> ExceptT PluginError (HandlerM Config) b)
-> ExceptT PluginError (HandlerM Config) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ConfigLoaded String
file FourmoluConfig
opts -> do
            Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info (LogEvent -> ExceptT PluginError (HandlerM Config) ())
-> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ String -> LogEvent
ConfigPath String
file
            FourmoluConfig
-> ExceptT PluginError (HandlerM Config) FourmoluConfig
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FourmoluConfig
opts
        ConfigNotFound [String]
searchDirs -> do
            Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info (LogEvent -> ExceptT PluginError (HandlerM Config) ())
-> LogEvent -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ [String] -> LogEvent
NoConfigPath [String]
searchDirs
            FourmoluConfig
-> ExceptT PluginError (HandlerM Config) FourmoluConfig
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FourmoluConfig
emptyConfig
        ConfigParseError String
f ParseException
err -> do
            HandlerM Config () -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HandlerM Config () -> ExceptT PluginError (HandlerM Config) ())
-> HandlerM Config () -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> HandlerM Config ()
forall (m :: Method 'ServerToClient 'Notification) config.
SServerMethod m -> MessageParams m -> HandlerM config ()
pluginSendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageParams 'Method_WindowShowMessage -> HandlerM Config ())
-> MessageParams 'Method_WindowShowMessage -> HandlerM Config ()
forall a b. (a -> b) -> a -> b
$
                ShowMessageParams
                    { $sel:_type_:ShowMessageParams :: MessageType
_type_ = MessageType
MessageType_Error
                    , $sel:_message:ShowMessageParams :: Text
_message = Text
errorMessage
                    }
            PluginError -> ExceptT PluginError (HandlerM Config) FourmoluConfig
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) FourmoluConfig)
-> PluginError
-> ExceptT PluginError (HandlerM Config) FourmoluConfig
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError 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 (ParseException -> String
forall a. Show a => a -> String
show ParseException
err)
#endif

data LogEvent
    = NoVersion Text
    | ConfigPath FilePath
    | NoConfigPath [FilePath]
    | StdErr Text
    | LogCompiledInVersion String
    | LogExternalVersion [Int]
    deriving (Int -> LogEvent -> String -> String
[LogEvent] -> String -> String
LogEvent -> String
(Int -> LogEvent -> String -> String)
-> (LogEvent -> String)
-> ([LogEvent] -> String -> String)
-> Show LogEvent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LogEvent -> String -> String
showsPrec :: Int -> LogEvent -> String -> String
$cshow :: LogEvent -> String
show :: LogEvent -> String
$cshowList :: [LogEvent] -> String -> String
showList :: [LogEvent] -> String -> String
Show)

instance Pretty LogEvent where
    pretty :: forall ann. LogEvent -> Doc ann
pretty = \case
        NoVersion Text
t -> Doc ann
"Couldn't get Fourmolu version:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
        ConfigPath String
p -> Doc ann
"Loaded Fourmolu config from: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> String
forall a. Show a => a -> String
show String
p)
        NoConfigPath [String]
ps -> Doc ann
"No " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
configFileName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" found in any of:"
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((String -> Doc ann) -> [String] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (String -> String) -> String -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) [String]
ps))
        StdErr Text
t -> Doc ann
"Fourmolu stderr:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
        LogCompiledInVersion String
v -> Doc ann
"Using compiled in fourmolu-" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v
        LogExternalVersion [Int]
v ->
            Doc ann
"Using external fourmolu"
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
v then Doc ann
"" else Doc ann
"-"
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
v)

convertDynFlags :: DynFlags -> [String]
convertDynFlags :: DynFlags -> [String]
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 a. [a] -> 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)
-> (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 [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

newtype CLIVersionInfo = CLIVersionInfo
    { CLIVersionInfo -> Bool
noCabal :: Bool
    }

mwhen :: Monoid a => Bool -> a -> a
mwhen :: forall a. Monoid a => Bool -> a -> a
mwhen Bool
b a
x = if Bool
b then a
x else a
forall a. Monoid a => a
mempty