{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Ide.Plugin.Ormolu
( descriptor
, provider
)
where
import Control.Exception (Handler (..), IOException,
SomeException (..), catches)
import Control.Monad.Except (ExceptT (ExceptT), runExceptT,
throwError)
import Control.Monad.Extra
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans
import Data.Functor ((<&>))
import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers)
import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString)
import qualified Development.IDE.GHC.Compat as D
import qualified Development.IDE.GHC.Compat.Util as S
import GHC.LanguageExtensions.Type
import Ide.Plugin.Error (PluginError (PluginInternalError))
import Ide.PluginUtils
import Ide.Types hiding (Config)
import qualified Ide.Types as Types
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server hiding (defaultConfig)
import Ormolu
import System.FilePath (takeFileName)
descriptor :: Recorder (WithPriority T.Text) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Text)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Text)
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 Text) -> FormattingHandler IdeState
provider Recorder (WithPriority Text)
recorder
}
provider :: Recorder (WithPriority T.Text) -> FormattingHandler IdeState
provider :: Recorder (WithPriority Text) -> FormattingHandler IdeState
provider Recorder (WithPriority Text)
recorder IdeState
ideState FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
_ = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ 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
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
Maybe HscEnvEq
ghc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"Ormolu" 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
let df :: Maybe DynFlags
df = 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
<$> Maybe HscEnvEq
ghc
[DynOption]
fileOpts <- case Maybe DynFlags
df of
Maybe DynFlags
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just DynFlags
df -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DynFlags -> [DynOption]
fromDyn DynFlags
df
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Text)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ Text
"Using ormolu-" forall a. Semigroup a => a -> a -> a
<> VERSION_ormolu
let
fullRegion :: RegionIndices
fullRegion = Maybe Int -> Maybe Int -> RegionIndices
RegionIndices forall a. Maybe a
Nothing forall a. Maybe a
Nothing
rangeRegion :: Int -> Int -> RegionIndices
rangeRegion Int
s Int
e = Maybe Int -> Maybe Int -> RegionIndices
RegionIndices (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
s forall a. Num a => a -> a -> a
+ Int
1) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
e forall a. Num a => a -> a -> a
+ Int
1)
mkConf :: [DynOption] -> region -> Config region
mkConf [DynOption]
o region
region = Config RegionIndices
defaultConfig { cfgDynOptions :: [DynOption]
cfgDynOptions = [DynOption]
o, cfgRegion :: region
cfgRegion = region
region }
fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text)
fmt :: Text -> Config RegionIndices -> IO (Either SomeException Text)
fmt Text
cont Config RegionIndices
conf = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IO a -> [Handler a] -> IO a
catches forall {b}. [Handler (Either SomeException b)]
handlers forall a b. (a -> b) -> a -> b
$ do
let fp' :: [Char]
fp' = NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp
#if MIN_VERSION_ormolu(0,5,3)
cabalInfo <- getCabalInfoForSourceFile fp' <&> \case
CabalNotFound -> Nothing
CabalDidNotMention cabalInfo -> Just cabalInfo
CabalFound cabalInfo -> Just cabalInfo
#if MIN_VERSION_ormolu(0,7,0)
(fixityOverrides, moduleReexports) <- getDotOrmoluForSourceFile fp'
let conf' = refineConfig ModuleSource cabalInfo (Just fixityOverrides) (Just moduleReexports) conf
#else
fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo
let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf
#endif
let cont' = cont
#else
let conf' :: Config RegionIndices
conf' = Config RegionIndices
conf
cont' :: [Char]
cont' = Text -> [Char]
T.unpack Text
cont
#endif
forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> [Char] -> [Char] -> m Text
ormolu Config RegionIndices
conf' [Char]
fp' [Char]
cont'
handlers :: [Handler (Either SomeException b)]
handlers =
[ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ 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
. forall e. Exception e => e -> SomeException
SomeException @OrmoluException
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ 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
. forall e. Exception e => e -> SomeException
SomeException @IOException
]
case FormattingType
typ of
FormattingType
FormatText -> do
Either SomeException Text
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> Config RegionIndices -> IO (Either SomeException Text)
fmt Text
contents (forall {region}. [DynOption] -> region -> Config region
mkConf [DynOption]
fileOpts RegionIndices
fullRegion)
Either SomeException Text
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
ret Either SomeException Text
res
FormatRange (Range (Position UInt
sl UInt
_) (Position UInt
el UInt
_)) -> do
Either SomeException Text
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> Config RegionIndices -> IO (Either SomeException Text)
fmt Text
contents (forall {region}. [DynOption] -> region -> Config region
mkConf [DynOption]
fileOpts (Int -> Int -> RegionIndices
rangeRegion (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl) (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
el)))
Either SomeException Text
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
ret Either SomeException Text
res
where
title :: Text
title = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Formatting " forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
takeFileName (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)
ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null)
ret :: Either SomeException Text
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
ret (Left SomeException
err) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"ormoluCmd: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
err
ret (Right Text
new) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents Text
new
fromDyn :: D.DynFlags -> [DynOption]
fromDyn :: DynFlags -> [DynOption]
fromDyn DynFlags
df =
let
pp :: [[Char]]
pp =
let p :: [Char]
p = Settings -> [Char]
D.sPgm_F forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
D.settings DynFlags
df
in [[Char]
"-pgmF=" forall a. Semigroup a => a -> a -> a
<> [Char]
p | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
p)]
pm :: [[Char]]
pm = ([Char]
"-fplugin=" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [ModuleName]
D.pluginModNames DynFlags
df
ex :: [[Char]]
ex = Extension -> [Char]
showExtension forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Enum a => EnumSet a -> [a]
S.toList (DynFlags -> EnumSet Extension
D.extensionFlags DynFlags
df)
in
[Char] -> DynOption
DynOption forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
pp forall a. Semigroup a => a -> a -> a
<> [[Char]]
pm forall a. Semigroup a => a -> a -> a
<> [[Char]]
ex
showExtension :: Extension -> String
showExtension :: Extension -> [Char]
showExtension Extension
Cpp = [Char]
"-XCPP"
showExtension Extension
other = [Char]
"-X" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Extension
other