{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Ide.Plugin.Fourmolu (
descriptor,
provider,
) where
import Control.Exception (IOException, try)
import Control.Lens ((^.))
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifunctor (bimap, first)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
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.Fourmolu.Shim
import Ide.Plugin.Properties
import Ide.PluginUtils (makeDiffTextEdit,
usePropertyLsp)
import Ide.Types
import Language.LSP.Server hiding (defaultConfig)
import Language.LSP.Types hiding (line)
import Language.LSP.Types.Lens (HasTabSize (tabSize))
import Ormolu
import System.Exit
import System.FilePath
import System.Process.Run (cwd, proc)
import System.Process.Text (readCreateProcessWithExitCode)
import Text.Read (readMaybe)
descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority LogEvent)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority LogEvent)
recorder PluginId
plId =
(forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority LogEvent)
-> PluginId -> FormattingHandler IdeState
provider Recorder (WithPriority LogEvent)
recorder PluginId
plId
}
properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
properties =
Properties '[]
emptyProperties
forall a b. a -> (a -> b) -> b
& 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 FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
fo = forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
title ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
[String]
fileOpts <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (DynFlags -> [String]
convertDynFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. String -> IdeState -> Action a -> IO a
runAction String
"Fourmolu" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
fp)
Bool
useCLI <- forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
(r :: [PropertyKey]) (m :: * -> *).
(HasProperty s k t r, MonadLsp Config m) =>
KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t)
usePropertyLsp forall a. IsLabel "external" a => a
#external PluginId
plId Properties '[ 'PropertyKey "external" 'TBoolean]
properties
if Bool
useCLI
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> ResponseError
mkError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @IOException
forall a b. (a -> b) -> a -> b
$ do
CLIVersionInfo{Bool
noCabal :: CLIVersionInfo -> Bool
noCabal :: Bool
noCabal} <- do
(ExitCode
exitCode, Text
out, Text
_err) <- CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode ( String -> [String] -> CreateProcess
proc String
"fourmolu" [String
"-v"] ) Text
""
let version :: Maybe [Int]
version = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
Text
"fourmolu" : Text
v : [Text]
_ <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
out
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. Read a => String -> Maybe a
readMaybe @Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." Text
v
case Maybe [Int]
version of
Just [Int]
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
{ noCabal :: Bool
noCabal = [Int]
v forall a. Ord a => a -> a -> Bool
>= [Int
0, Int
7]
}
Maybe [Int]
Nothing -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Warning forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
NoVersion Text
out
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
{ noCabal :: Bool
noCabal = Bool
True
}
(ExitCode
exitCode, Text
out, Text
err) <-
CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode
( String -> [String] -> CreateProcess
proc String
"fourmolu" forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (String
"-o" forall a. Semigroup a => a -> a -> a
<>) [String]
fileOpts
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => Bool -> a -> a
mwhen Bool
noCabal [String
"--no-cabal"]
forall a. Semigroup a => a -> a -> a
<> forall a. [Maybe a] -> [a]
catMaybes
[ (String
"--start-line=" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionStartLine RegionIndices
region
, (String
"--end-line=" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionEndLine RegionIndices
region
]
){cwd :: Maybe String
cwd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
fp'}
Text
contents
case ExitCode
exitCode of
ExitCode
ExitSuccess -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> List TextEdit
makeDiffTextEdit Text
contents Text
out
ExitFailure Int
n -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResponseError
responseError forall a b. (a -> b) -> a -> b
$ Text
"Fourmolu failed with exit code " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
n)
else do
let format :: FourmoluConfig -> IO (Either ResponseError (List TextEdit))
format FourmoluConfig
fourmoluConfig =
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> ResponseError
mkError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Text -> Text -> List TextEdit
makeDiffTextEdit Text
contents)
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 (forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> String -> m Text
ormolu Config RegionIndices
config String
fp' (Text -> String
T.unpack Text
contents))
where
printerOpts :: PrinterOptsPartial
printerOpts = FourmoluConfig -> PrinterOptsPartial
cfgFilePrinterOpts FourmoluConfig
fourmoluConfig
config :: Config RegionIndices
config =
forall region. FixityMap -> Config region -> Config region
addFixityOverrides (FourmoluConfig -> FixityMap
cfgFileFixities FourmoluConfig
fourmoluConfig) forall a b. (a -> b) -> a -> b
$
Config RegionIndices
defaultConfig
{ cfgDynOptions :: [DynOption]
cfgDynOptions = forall a b. (a -> b) -> [a] -> [b]
map String -> DynOption
DynOption [String]
fileOpts
, cfgRegion :: RegionIndices
cfgRegion = RegionIndices
region
, cfgDebug :: Bool
cfgDebug = Bool
False
, cfgPrinterOpts :: PrinterOptsTotal
cfgPrinterOpts =
forall (f :: * -> *).
Applicative f =>
PrinterOptsPartial -> PrinterOpts f -> PrinterOpts f
fillMissingPrinterOpts
(PrinterOptsPartial
printerOpts forall a. Semigroup a => a -> a -> a
<> PrinterOptsPartial
lspPrinterOpts)
PrinterOptsTotal
defaultPrinterOpts
}
in forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ConfigFileLoadResult
loadConfigFile String
fp') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ConfigLoaded String
file FourmoluConfig
opts -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ String -> LogEvent
ConfigPath String
file
FourmoluConfig -> IO (Either ResponseError (List TextEdit))
format FourmoluConfig
opts
ConfigNotFound [String]
searchDirs -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ [String] -> LogEvent
NoConfigPath [String]
searchDirs
FourmoluConfig -> IO (Either ResponseError (List TextEdit))
format FourmoluConfig
emptyConfig
ConfigParseError String
f ParseException
err -> do
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SMethod 'WindowShowMessage
SWindowShowMessage forall a b. (a -> b) -> a -> b
$
ShowMessageParams
{ $sel:_xtype:ShowMessageParams :: MessageType
_xtype = MessageType
MtError
, $sel:_message:ShowMessageParams :: Text
_message = Text
errorMessage
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError Text
errorMessage
where
errorMessage :: Text
errorMessage = Text
"Failed to load " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
showParseError ParseException
err)
where
fp' :: String
fp' = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
fp
title :: Text
title = Text
"Formatting " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
takeFileName String
fp')
mkError :: String -> ResponseError
mkError = Text -> ResponseError
responseError forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Fourmolu: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
lspPrinterOpts :: PrinterOptsPartial
lspPrinterOpts = forall a. Monoid a => a
mempty{poIndentation :: Maybe Int
poIndentation = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FormattingOptions
fo forall s a. s -> Getting a s a -> a
^. 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing
FormatRange (Range (Position UInt
sl UInt
_) (Position UInt
el UInt
_)) ->
Maybe Int -> Maybe Int -> RegionIndices
RegionIndices (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
sl forall a. Num a => a -> a -> a
+ UInt
1) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
el forall a. Num a => a -> a -> a
+ UInt
1)
data LogEvent
= NoVersion Text
| ConfigPath FilePath
| NoConfigPath [FilePath]
| StdErr Text
deriving (Int -> LogEvent -> String -> String
[LogEvent] -> String -> String
LogEvent -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LogEvent] -> String -> String
$cshowList :: [LogEvent] -> String -> String
show :: LogEvent -> String
$cshow :: LogEvent -> String
showsPrec :: Int -> LogEvent -> String -> String
$cshowsPrec :: Int -> 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:" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
ConfigPath String
p -> Doc ann
"Loaded Fourmolu config from: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show String
p)
NoConfigPath [String]
ps -> Doc ann
"No " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty String
configFileName forall a. Semigroup a => a -> a -> a
<> Doc ann
" found in any of:"
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall ann. [Doc ann] -> Doc ann
vsep (forall a b. (a -> b) -> [a] -> [b]
map (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [String]
ps))
StdErr Text
t -> Doc ann
"Fourmolu stderr:" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
convertDynFlags :: DynFlags -> [String]
convertDynFlags :: DynFlags -> [String]
convertDynFlags DynFlags
df =
let pp :: [String]
pp = [String
"-pgmF=" forall a. Semigroup a => a -> a -> a
<> String
p | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p)]
p :: String
p = Settings -> String
sPgm_F forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
Compat.settings DynFlags
df
pm :: [String]
pm = forall a b. (a -> b) -> [a] -> [b]
map ((String
"-fplugin=" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString) forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModuleName]
pluginModNames DynFlags
df
ex :: [String]
ex = forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
showExtension forall a b. (a -> b) -> a -> b
$ forall a. Enum a => EnumSet a -> [a]
S.toList 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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Extension
x
in [String]
pp forall a. Semigroup a => a -> a -> a
<> [String]
pm 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 forall a. Monoid a => a
mempty