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

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

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogProcessInvocationFailure Int
code -> Doc ann
"Invocation of cabal-fmt failed with code" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Int
code
    LogReadCreateProcessInfo String
stdErrorOut [String]
args ->
      forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$
        [Doc ann
"Invocation of cabal-fmt with arguments" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [String]
args]
          forall a. [a] -> [a] -> [a]
++ [Doc ann
"failed with standard error:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
stdErrorOut | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
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 =
  (forall ideState. PluginId -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId)
    { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers (Recorder (WithPriority Log) -> FormattingHandler IdeState
provider Recorder (WithPriority Log)
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
_ (FormatRange Range
_) Text
_ NormalizedFilePath
_ FormattingOptions
_ = do
  forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info Log
LogInvalidInvocationInfo
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 FormattingType
FormatText Text
contents NormalizedFilePath
nfp FormattingOptions
opts = do
  let cabalFmtArgs :: [String]
cabalFmtArgs = [String
fp, String
"--indent", forall a. Show a => a -> String
show UInt
tabularSize]
  Maybe String
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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, String
out, String
err) <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode
          ( String -> [String] -> CreateProcess
proc String
"cabal-fmt" [String]
cabalFmtArgs
          )
            { cwd :: Maybe String
cwd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fp
            }
          String
""
      Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Debug forall a b. (a -> b) -> a -> b
$ String -> [String] -> Log
LogReadCreateProcessInfo String
err [String]
cabalFmtArgs
      case ExitCode
exitCode of
        ExitFailure Int
code -> do
          Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Error forall a b. (a -> b) -> a -> b
$ Int -> Log
LogProcessInvocationFailure Int
code
          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 (String -> Text
T.pack String
out)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [TextEdit]
fmtDiff
    Maybe String
Nothing -> do
      Priority -> Log -> ExceptT PluginError (LspM Config) ()
log Priority
Error Log
LogCabalFmtNotFound
      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 forall s a. s -> Getting a s a -> a
^. forall s a. HasTabSize s a => Lens' s a
L.tabSize
    log :: Priority -> Log -> ExceptT PluginError (LspM Config) ()
log = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder