{-# 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