{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

module Ide.Plugin.Ormolu
  ( descriptor
  , provider
  )
where

import           Control.Exception               (try)
import           Control.Monad.IO.Class          (liftIO)
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.PluginUtils
import           Ide.Types
import           Language.LSP.Server             hiding (defaultConfig)
import           Language.LSP.Types
import           Ormolu
import           System.FilePath                 (takeFileName)

-- ---------------------------------------------------------------------

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers FormattingHandler IdeState
provider
  }

-- ---------------------------------------------------------------------

provider :: FormattingHandler IdeState
provider :: FormattingHandler IdeState
provider IdeState
ideState FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
_ = 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Maybe HscEnvEq
ghc <- 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

  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 OrmoluException T.Text)
    fmt :: Text -> Config RegionIndices -> IO (Either OrmoluException Text)
fmt Text
cont Config RegionIndices
conf =
      forall e a. Exception e => IO a -> IO (Either e a)
try @OrmoluException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> [Char] -> [Char] -> m Text
ormolu Config RegionIndices
conf (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp) forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
cont

  case FormattingType
typ of
    FormattingType
FormatText -> Either OrmoluException Text -> Either ResponseError (List TextEdit)
ret forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Config RegionIndices -> IO (Either OrmoluException Text)
fmt Text
contents (forall {region}. [DynOption] -> region -> Config region
mkConf [DynOption]
fileOpts RegionIndices
fullRegion)
    FormatRange (Range (Position UInt
sl UInt
_) (Position UInt
el UInt
_)) ->
      Either OrmoluException Text -> Either ResponseError (List TextEdit)
ret forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Config RegionIndices -> IO (Either OrmoluException 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)))
 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 OrmoluException T.Text -> Either ResponseError (List TextEdit)
   ret :: Either OrmoluException Text -> Either ResponseError (List TextEdit)
ret (Left OrmoluException
err)  = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResponseError
responseError 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 OrmoluException
err
   ret (Right Text
new) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> List 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