{-# 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 plId = (defaultPluginDescriptor plId)
{ pluginHandlers = mkFormattingHandlers $ provider recorder
}
-- ---------------------------------------------------------------------
provider :: Recorder (WithPriority T.Text) -> FormattingHandler IdeState
provider recorder ideState typ contents fp _ = ExceptT $ withIndefiniteProgress title Cancellable $ runExceptT $ do
ghc <- liftIO $ runAction "Ormolu" ideState $ use GhcSession fp
let df = hsc_dflags . hscEnv <$> ghc
fileOpts <- case df of
Nothing -> pure []
Just df -> pure $ fromDyn df
logWith recorder Debug $ "Using ormolu-" <> VERSION_ormolu
let
fullRegion = RegionIndices Nothing Nothing
rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1)
mkConf o region = defaultConfig { cfgDynOptions = o, cfgRegion = region }
fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text)
fmt cont conf = flip catches handlers $ do
let fp' = fromNormalizedFilePath 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' = conf
cont' = T.unpack cont
#endif
Right <$> ormolu conf' fp' cont'
handlers =
[ Handler $ pure . Left . SomeException @OrmoluException
, Handler $ pure . Left . SomeException @IOException
]
case typ of
FormatText -> do
res <- liftIO $ fmt contents (mkConf fileOpts fullRegion)
ret res
FormatRange (Range (Position sl _) (Position el _)) -> do
res <- liftIO $ fmt contents (mkConf fileOpts (rangeRegion (fromIntegral sl) (fromIntegral el)))
ret res
where
title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)
ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null)
ret (Left err) = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err
ret (Right new) = pure $ InL $ makeDiffTextEdit contents new
fromDyn :: D.DynFlags -> [DynOption]
fromDyn df =
let
pp =
let p = D.sPgm_F $ D.settings df
in ["-pgmF=" <> p | not (null p)]
pm = ("-fplugin=" <>) . moduleNameString <$> D.pluginModNames df
ex = showExtension <$> S.toList (D.extensionFlags df)
in
DynOption <$> pp <> pm <> ex
showExtension :: Extension -> String
showExtension Cpp = "-XCPP"
showExtension other = "-X" ++ show other