{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Ide.Plugin.CabalFmt where

import           Control.Lens
import           Control.Monad.Except        (throwError)
import           Control.Monad.IO.Class
import qualified Data.Text                   as T
import           Development.IDE             hiding (pluginHandlers)
import           Ide.Plugin.Error            (PluginError (PluginInternalError, PluginInvalidParams))
import           Ide.PluginUtils
import           Ide.Types
import qualified Language.LSP.Protocol.Lens  as L
import           Language.LSP.Protocol.Types
import           Prelude                     hiding (log)
import           System.Directory
import           System.Exit
import           System.FilePath
import           System.Process.ListLike
import qualified System.Process.Text         as Process

data Log
  = LogProcessInvocationFailure Int
  | LogReadCreateProcessInfo T.Text [String]
  | LogInvalidInvocationInfo
  | LogCabalFmtNotFound
  deriving (Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show)

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogProcessInvocationFailure Int
exitCode -> Doc ann
"Invocation of cabal-fmt failed with code" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
exitCode
    LogReadCreateProcessInfo Text
stdErrorOut [String]
args ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann
"Invocation of cabal-fmt with arguments" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> Doc ann
forall ann. [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [String]
args]
          [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann
"failed with standard error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
stdErrorOut | Bool -> Bool
not (Text -> Bool
T.null Text
stdErrorOut)]
    Log
LogInvalidInvocationInfo -> Doc ann
"Invocation of cabal-fmt with range was called but is not supported."
    Log
LogCabalFmtNotFound -> Doc ann
"Couldn't find executable 'cabal-fmt'"

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
  (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId Text
"Provides formatting of cabal files with cabal-fmt")
    { pluginHandlers = mkFormattingHandlers (provider recorder)
    }

-- | Formatter provider of cabal fmt.
-- Formats the given source in either a given Range or the whole Document.
-- If the provider fails an error is returned that can be displayed to the user.
provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState
provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState
provider Recorder (WithPriority Log)
recorder IdeState
_ Maybe ProgressToken
_ (FormatRange Range
_) Text
_ NormalizedFilePath
_ FormattingOptions
_ = do
  Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info Log
LogInvalidInvocationInfo
  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
PluginInvalidParams Text
"You cannot format a text-range using cabal-fmt."
provider Recorder (WithPriority Log)
recorder IdeState
_ide Maybe ProgressToken
_ FormattingType
FormatText Text
contents NormalizedFilePath
nfp FormattingOptions
opts = do
  let cabalFmtArgs :: [String]
cabalFmtArgs = [ String
"--indent", UInt -> String
forall a. Show a => a -> String
show UInt
tabularSize]
  Maybe String
x <- IO (Maybe String)
-> ExceptT PluginError (LspM Config) (Maybe String)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String)
 -> ExceptT PluginError (LspM Config) (Maybe String))
-> IO (Maybe String)
-> ExceptT PluginError (LspM Config) (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
"cabal-fmt"
  case Maybe String
x of
    Just String
_ -> do
      (ExitCode
exitCode, Text
out, Text
err) <-
        IO (ExitCode, Text, Text)
-> ExceptT PluginError (LspM Config) (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError (LspM Config) (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError (LspM Config) (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
Process.readCreateProcessWithExitCode
          ( String -> [String] -> CreateProcess
proc String
"cabal-fmt" [String]
cabalFmtArgs
          )
            { cwd = Just $ takeDirectory fp
            }
          Text
contents
      Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Debug (Log -> ExceptT PluginError (LspM Config) ())
-> Log -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ Text -> [String] -> Log
LogReadCreateProcessInfo Text
err [String]
cabalFmtArgs
      case ExitCode
exitCode of
        ExitFailure Int
code -> do
          Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Error (Log -> ExceptT PluginError (LspM Config) ())
-> Log -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ Int -> Log
LogProcessInvocationFailure Int
code
          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 (Text -> PluginError
PluginInternalError Text
"Failed to invoke cabal-fmt")
        ExitCode
ExitSuccess -> do
          let fmtDiff :: [TextEdit]
fmtDiff = Text -> Text -> [TextEdit]
makeDiffTextEdit Text
contents Text
out
          ([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]
fmtDiff
    Maybe String
Nothing -> do
      Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Error Log
LogCabalFmtNotFound
      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 (Text -> PluginError
PluginInternalError Text
"No installation of cabal-fmt could be found. Please install it into your global environment.")
  where
    fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
    tabularSize :: UInt
tabularSize = FormattingOptions
opts FormattingOptions -> Getting UInt FormattingOptions UInt -> UInt
forall s a. s -> Getting a s a -> a
^. Getting UInt FormattingOptions UInt
forall s a. HasTabSize s a => Lens' s a
Lens' FormattingOptions UInt
L.tabSize
    log :: Priority -> Log -> ExceptT PluginError (LspM Config) ()
log = Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder