{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}
module Ide.Plugin.Ormolu
  ( descriptor
  , provider
  , LogEvent
  )
where

import           Control.Exception               (Handler (..), IOException,
                                                  SomeException (..), catches,
                                                  handle)
import           Control.Monad.Except            (runExceptT, throwError)
import           Control.Monad.Extra
import           Control.Monad.Trans
import           Control.Monad.Trans.Except      (ExceptT (..), mapExceptT)
import           Data.Functor                    ((<&>))
import           Data.List                       (intercalate)
import           Data.Maybe                      (catMaybes)
import           Data.Text                       (Text)
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.Plugin.Properties
import           Ide.PluginUtils
import           Ide.Types                       hiding (Config)
import qualified Ide.Types                       as Types
import           Language.LSP.Protocol.Types
import           Language.LSP.Server             hiding (defaultConfig)
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 =
  (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
    { pluginHandlers = mkFormattingHandlers $ provider recorder plId,
      pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
    }
  where
    desc :: Text
desc = Text
"Provides formatting of Haskell files via ormolu. Built with ormolu-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VERSION_ormolu

properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
properties =
  Properties '[]
emptyProperties
    Properties '[]
-> (Properties '[]
    -> Properties '[ 'PropertyKey "external" 'TBoolean])
-> Properties '[ 'PropertyKey "external" 'TBoolean]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "external"
-> Text
-> Bool
-> Properties '[]
-> Properties '[ 'PropertyKey "external" 'TBoolean]
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 \"ormolu\" 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 Maybe ProgressToken
token FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
_ = LspM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LspM Config (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null))
-> LspM Config (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> LspT Config IO ())
    -> LspM Config (Either PluginError ([TextEdit] |? Null)))
-> LspM Config (Either PluginError ([TextEdit] |? Null))
forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
title Maybe ProgressToken
token ProgressCancellable
Cancellable (((Text -> LspT Config IO ())
  -> LspM Config (Either PluginError ([TextEdit] |? Null)))
 -> LspM Config (Either PluginError ([TextEdit] |? Null)))
-> ((Text -> LspT Config IO ())
    -> LspM Config (Either PluginError ([TextEdit] |? Null)))
-> LspM Config (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ \Text -> LspT Config IO ()
_updater -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
-> LspM Config (Either PluginError ([TextEdit] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
 -> LspM Config (Either PluginError ([TextEdit] |? Null)))
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
-> LspM Config (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ do
  [[Char]]
fileOpts <-
      [[Char]] -> (HscEnvEq -> [[Char]]) -> Maybe HscEnvEq -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (DynFlags -> [[Char]]
fromDyn (DynFlags -> [[Char]])
-> (HscEnvEq -> DynFlags) -> HscEnvEq -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv)
          (Maybe HscEnvEq -> [[Char]])
-> ExceptT PluginError (LspM Config) (Maybe HscEnvEq)
-> ExceptT PluginError (LspM Config) [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe HscEnvEq)
-> ExceptT PluginError (LspM Config) (Maybe HscEnvEq)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char]
-> IdeState -> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"Ormolu" IdeState
ideState (Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq))
-> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)
forall a b. (a -> b) -> a -> b
$ GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
fp)
  Bool
useCLI <- IO Bool -> ExceptT PluginError (LspM Config) Bool
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT PluginError (LspM Config) Bool)
-> IO Bool -> ExceptT PluginError (LspM Config) Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IdeState -> Action Bool -> IO Bool
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"Ormolu" IdeState
ideState (Action Bool -> IO Bool) -> Action Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "external"
-> PluginId
-> Properties '[ 'PropertyKey "external" 'TBoolean]
-> Action
     (ToHsType
        (FindByKeyName "external" '[ 'PropertyKey "external" 'TBoolean]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "external"
#external PluginId
plId Properties '[ 'PropertyKey "external" 'TBoolean]
properties

  if Bool
useCLI
      then (IO (Either PluginError ([TextEdit] |? Null))
 -> LspM Config (Either PluginError ([TextEdit] |? Null)))
-> ExceptT PluginError IO ([TextEdit] |? Null)
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT IO (Either PluginError ([TextEdit] |? Null))
-> LspM Config (Either PluginError ([TextEdit] |? Null))
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT PluginError IO ([TextEdit] |? Null)
 -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null))
-> ExceptT PluginError IO ([TextEdit] |? Null)
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError IO ([TextEdit] |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
           (IO (Either PluginError ([TextEdit] |? Null))
 -> ExceptT PluginError IO ([TextEdit] |? Null))
-> IO (Either PluginError ([TextEdit] |? Null))
-> ExceptT PluginError IO ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle @IOException
          (Either PluginError ([TextEdit] |? Null)
-> IO (Either PluginError ([TextEdit] |? Null))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError ([TextEdit] |? Null)
 -> IO (Either PluginError ([TextEdit] |? Null)))
-> (IOException -> Either PluginError ([TextEdit] |? Null))
-> IOException
-> IO (Either PluginError ([TextEdit] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginError -> Either PluginError ([TextEdit] |? Null)
forall a b. a -> Either a b
Left (PluginError -> Either PluginError ([TextEdit] |? Null))
-> (IOException -> PluginError)
-> IOException
-> Either PluginError ([TextEdit] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PluginError
PluginInternalError (Text -> PluginError)
-> (IOException -> Text) -> IOException -> PluginError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> (IOException -> [Char]) -> IOException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> [Char]
forall a. Show a => a -> [Char]
show)
           (IO (Either PluginError ([TextEdit] |? Null))
 -> IO (Either PluginError ([TextEdit] |? Null)))
-> IO (Either PluginError ([TextEdit] |? Null))
-> IO (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ ExceptT PluginError IO ([TextEdit] |? Null)
-> IO (Either PluginError ([TextEdit] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError IO ([TextEdit] |? Null)
 -> IO (Either PluginError ([TextEdit] |? Null)))
-> ExceptT PluginError IO ([TextEdit] |? Null)
-> IO (Either PluginError ([TextEdit] |? Null))
forall a b. (a -> b) -> a -> b
$ [[Char]] -> ExceptT PluginError IO ([TextEdit] |? Null)
cliHandler [[Char]]
fileOpts
      else do
          Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError (LspM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError (LspM Config) ())
-> LogEvent -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> LogEvent
LogCompiledInVersion VERSION_ormolu

          let
            fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text)
            fmt :: Text -> Config RegionIndices -> IO (Either SomeException Text)
fmt Text
cont Config RegionIndices
conf = (IO (Either SomeException Text)
 -> [Handler (Either SomeException Text)]
 -> IO (Either SomeException Text))
-> [Handler (Either SomeException Text)]
-> IO (Either SomeException Text)
-> IO (Either SomeException Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either SomeException Text)
-> [Handler (Either SomeException Text)]
-> IO (Either SomeException Text)
forall a. IO a -> [Handler a] -> IO a
catches [Handler (Either SomeException Text)]
forall {b}. [Handler (Either SomeException b)]
handlers (IO (Either SomeException Text) -> IO (Either SomeException Text))
-> IO (Either SomeException Text) -> IO (Either SomeException Text)
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ormolu(0,5,3)
              Maybe CabalInfo
cabalInfo <- [Char] -> IO CabalSearchResult
forall (m :: * -> *). MonadIO m => [Char] -> m CabalSearchResult
getCabalInfoForSourceFile [Char]
fp' IO CabalSearchResult
-> (CabalSearchResult -> Maybe CabalInfo) -> IO (Maybe CabalInfo)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                CabalSearchResult
CabalNotFound                -> Maybe CabalInfo
forall a. Maybe a
Nothing
                CabalDidNotMention CabalInfo
cabalInfo -> CabalInfo -> Maybe CabalInfo
forall a. a -> Maybe a
Just CabalInfo
cabalInfo
                CabalFound CabalInfo
cabalInfo         -> CabalInfo -> Maybe CabalInfo
forall a. a -> Maybe a
Just CabalInfo
cabalInfo
#if MIN_VERSION_ormolu(0,7,0)
              (FixityOverrides
fixityOverrides, ModuleReexports
moduleReexports) <- [Char] -> IO (FixityOverrides, ModuleReexports)
forall (m :: * -> *).
MonadIO m =>
[Char] -> m (FixityOverrides, ModuleReexports)
getDotOrmoluForSourceFile [Char]
fp'
              let conf' :: Config RegionIndices
conf' = SourceType
-> Maybe CabalInfo
-> Maybe FixityOverrides
-> Maybe ModuleReexports
-> Config RegionIndices
-> Config RegionIndices
forall region.
SourceType
-> Maybe CabalInfo
-> Maybe FixityOverrides
-> Maybe ModuleReexports
-> Config region
-> Config region
refineConfig SourceType
ModuleSource Maybe CabalInfo
cabalInfo (FixityOverrides -> Maybe FixityOverrides
forall a. a -> Maybe a
Just FixityOverrides
fixityOverrides) (ModuleReexports -> Maybe ModuleReexports
forall a. a -> Maybe a
Just ModuleReexports
moduleReexports) Config RegionIndices
conf
#else
              fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo
              let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf
#endif
              let cont' :: Text
cont' = Text
cont
#else
              let conf' = conf
                  cont' = T.unpack cont
#endif
              Text -> Either SomeException Text
forall a b. b -> Either a b
Right (Text -> Either SomeException Text)
-> IO Text -> IO (Either SomeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config RegionIndices -> [Char] -> Text -> IO Text
forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> [Char] -> Text -> m Text
ormolu Config RegionIndices
conf' [Char]
fp' Text
cont'
            handlers :: [Handler (Either SomeException b)]
handlers =
              [ (OrmoluException -> IO (Either SomeException b))
-> Handler (Either SomeException b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((OrmoluException -> IO (Either SomeException b))
 -> Handler (Either SomeException b))
-> (OrmoluException -> IO (Either SomeException b))
-> Handler (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ Either SomeException b -> IO (Either SomeException b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException b -> IO (Either SomeException b))
-> (OrmoluException -> Either SomeException b)
-> OrmoluException
-> IO (Either SomeException b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException b
forall a b. a -> Either a b
Left (SomeException -> Either SomeException b)
-> (OrmoluException -> SomeException)
-> OrmoluException
-> Either SomeException b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
SomeException @OrmoluException
              , (IOException -> IO (Either SomeException b))
-> Handler (Either SomeException b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO (Either SomeException b))
 -> Handler (Either SomeException b))
-> (IOException -> IO (Either SomeException b))
-> Handler (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ Either SomeException b -> IO (Either SomeException b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException b -> IO (Either SomeException b))
-> (IOException -> Either SomeException b)
-> IOException
-> IO (Either SomeException b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException b
forall a b. a -> Either a b
Left (SomeException -> Either SomeException b)
-> (IOException -> SomeException)
-> IOException
-> Either SomeException b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
SomeException @IOException
              ]

          Either SomeException Text
res <- IO (Either SomeException Text)
-> ExceptT PluginError (LspM Config) (Either SomeException Text)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Text)
 -> ExceptT PluginError (LspM Config) (Either SomeException Text))
-> IO (Either SomeException Text)
-> ExceptT PluginError (LspM Config) (Either SomeException Text)
forall a b. (a -> b) -> a -> b
$ Text -> Config RegionIndices -> IO (Either SomeException Text)
fmt Text
contents Config RegionIndices
defaultConfig { cfgDynOptions = map DynOption fileOpts, cfgRegion = region }
          Either SomeException Text
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
ret Either SomeException Text
res
 where
   fp' :: [Char]
fp' = NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp

   region :: RegionIndices
   region :: RegionIndices
region = case FormattingType
typ of
       FormattingType
FormatText ->
           Maybe Int -> Maybe Int -> RegionIndices
RegionIndices Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
       FormatRange (Range (Position UInt
sl UInt
_) (Position UInt
el UInt
_)) ->
           Maybe Int -> Maybe Int -> RegionIndices
RegionIndices (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
sl UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
el UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1)

   title :: Text
title = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Formatting " [Char] -> [Char] -> [Char]
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)  = PluginError
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (LspM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null))
-> PluginError
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Text -> PluginError) -> ([Char] -> Text) -> [Char] -> PluginError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> PluginError) -> [Char] -> PluginError
forall a b. (a -> b) -> a -> b
$ [Char]
"ormoluCmd: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
err
   ret (Right Text
new) = ([TextEdit] |? Null)
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TextEdit] |? Null)
 -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null))
-> ([TextEdit] |? Null)
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> [TextEdit] |? Null
forall a b. a -> a |? b
InL ([TextEdit] -> [TextEdit] |? Null)
-> [TextEdit] -> [TextEdit] |? Null
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents Text
new

   fromDyn :: D.DynFlags -> [String]
   fromDyn :: DynFlags -> [[Char]]
fromDyn DynFlags
df =
     let
       pp :: [[Char]]
pp =
         let p :: [Char]
p = Settings -> [Char]
D.sPgm_F (Settings -> [Char]) -> Settings -> [Char]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
D.settings DynFlags
df
         in  [[Char]
"-pgmF=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
p | Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
p)]
       pm :: [[Char]]
pm = ([Char]
"-fplugin=" <>) ([Char] -> [Char])
-> (ModuleName -> [Char]) -> ModuleName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [ModuleName]
D.pluginModNames DynFlags
df
       ex :: [[Char]]
ex = Extension -> [Char]
showExtension (Extension -> [Char]) -> [Extension] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
S.toList (DynFlags -> EnumSet Extension
D.extensionFlags DynFlags
df)
     in [[Char]]
pp [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
pm [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
ex

   cliHandler :: [String] -> ExceptT PluginError IO ([TextEdit] |? Null)
   cliHandler :: [[Char]] -> ExceptT PluginError IO ([TextEdit] |? Null)
cliHandler [[Char]]
fileOpts = do
       CLIVersionInfo{Bool
noCabal :: Bool
noCabal :: CLIVersionInfo -> Bool
noCabal} <- do -- check Ormolu version so that we know which flags to use
           (ExitCode
exitCode, Text
out, Text
_err) <- IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode ( [Char] -> [[Char]] -> CreateProcess
proc [Char]
"ormolu" [[Char]
"--version"] ) Text
""
           let version :: Maybe [Int]
version = do
                   Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
                   Text
"ormolu" : Text
v : [Text]
_ <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
out
                   (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (forall a. Read a => [Char] -> Maybe a
readMaybe @Int ([Char] -> Maybe Int) -> (Text -> [Char]) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) ([Text] -> Maybe [Int]) -> [Text] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
v
           case Maybe [Int]
version of
               Just [Int]
v -> do
                   Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> LogEvent
LogExternalVersion [Int]
v
                   CLIVersionInfo -> ExceptT PluginError IO CLIVersionInfo
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
                       { noCabal :: Bool
noCabal = [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
0, Int
7]
                       }
               Maybe [Int]
Nothing -> do
                   Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> LogEvent
LogExternalVersion []
                   Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Warning (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
NoVersion Text
out
                   CLIVersionInfo -> ExceptT PluginError IO CLIVersionInfo
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIVersionInfo
                       { noCabal :: Bool
noCabal = Bool
True
                       }
       (ExitCode
exitCode, Text
out, Text
err) <- do -- run Ormolu
           let commandArgs :: [[Char]]
commandArgs = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-o" <>) [[Char]]
fileOpts
                       -- "The --stdin-input-file option is necessary when using input from
                       -- stdin and accounting for .cabal files" as per Ormolu documentation
                       [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> (if Bool
noCabal then [[Char]
"--no-cabal"] else [[Char]
"--stdin-input-file", [Char]
fp'])
                       [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes
                           [ ([Char]
"--start-line=" <>) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Maybe Int -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionStartLine RegionIndices
region
                           , ([Char]
"--end-line=" <>) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Maybe Int -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegionIndices -> Maybe Int
regionEndLine RegionIndices
region
                           ]
               cwd :: [Char]
cwd = [Char] -> [Char]
takeDirectory [Char]
fp'
           Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char] -> LogEvent
LogOrmoluCommand [[Char]]
commandArgs [Char]
cwd
           IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCode ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"ormolu" [[Char]]
commandArgs) {cwd = Just cwd} Text
contents
       case ExitCode
exitCode of
           ExitCode
ExitSuccess -> do
               Bool -> ExceptT PluginError IO () -> ExceptT PluginError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
err) (ExceptT PluginError IO () -> ExceptT PluginError IO ())
-> ExceptT PluginError IO () -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Debug (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
               ([TextEdit] |? Null) -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TextEdit] |? Null)
 -> ExceptT PluginError IO ([TextEdit] |? Null))
-> ([TextEdit] |? Null)
-> ExceptT PluginError IO ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> [TextEdit] |? Null
forall a b. a -> a |? b
InL ([TextEdit] -> [TextEdit] |? Null)
-> [TextEdit] -> [TextEdit] |? Null
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents Text
out
           ExitFailure Int
n -> do
               Recorder (WithPriority LogEvent)
-> Priority -> LogEvent -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogEvent)
recorder Priority
Info (LogEvent -> ExceptT PluginError IO ())
-> LogEvent -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEvent
StdErr Text
err
               PluginError -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError IO ([TextEdit] |? Null))
-> PluginError -> ExceptT PluginError IO ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ Text
"Ormolu failed with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)

newtype CLIVersionInfo =   CLIVersionInfo
    { CLIVersionInfo -> Bool
noCabal :: Bool
    }

data LogEvent
    = NoVersion Text
    | StdErr Text
    | LogCompiledInVersion String
    | LogExternalVersion [Int]
    | LogOrmoluCommand [String] FilePath
    deriving (Int -> LogEvent -> [Char] -> [Char]
[LogEvent] -> [Char] -> [Char]
LogEvent -> [Char]
(Int -> LogEvent -> [Char] -> [Char])
-> (LogEvent -> [Char])
-> ([LogEvent] -> [Char] -> [Char])
-> Show LogEvent
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> LogEvent -> [Char] -> [Char]
showsPrec :: Int -> LogEvent -> [Char] -> [Char]
$cshow :: LogEvent -> [Char]
show :: LogEvent -> [Char]
$cshowList :: [LogEvent] -> [Char] -> [Char]
showList :: [LogEvent] -> [Char] -> [Char]
Show)

instance Pretty LogEvent where
    pretty :: forall ann. LogEvent -> Doc ann
pretty = \case
        NoVersion Text
t -> Doc ann
"Couldn't get Ormolu version:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
        StdErr Text
t -> Doc ann
"Ormolu stderr:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t)
        LogCompiledInVersion [Char]
v -> Doc ann
"Using compiled in ormolu-" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
v
        LogExternalVersion [Int]
v ->
            Doc ann
"Using external ormolu"
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
v then Doc ann
"" else Doc ann
"-"
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show [Int]
v)
        LogOrmoluCommand [[Char]]
commandArgs [Char]
cwd -> Doc ann
"Running: `ormolu " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([[Char]] -> [Char]
unwords [[Char]]
commandArgs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"` in directory " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
cwd

showExtension :: Extension -> String
showExtension :: Extension -> [Char]
showExtension Extension
Cpp   = [Char]
"-XCPP"
showExtension Extension
other = [Char]
"-X" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Extension -> [Char]
forall a. Show a => a -> [Char]
show Extension
other