{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# 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.Plugin.Properties
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
  | LogFormatterBinNotFound FilePath
  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."
    LogFormatterBinNotFound String
fp -> Doc ann
"Couldn't find formatter executable 'cabal-fmt' at:" 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
fp

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 plId)
    , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties}
    }

properties :: Properties '[ 'PropertyKey "path" 'TString]
properties :: Properties '[ 'PropertyKey "path" 'TString]
properties =
    Properties '[]
emptyProperties
        Properties '[]
-> (Properties '[] -> Properties '[ 'PropertyKey "path" 'TString])
-> Properties '[ 'PropertyKey "path" 'TString]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "path"
-> Text
-> Text
-> Properties '[]
-> Properties '[ 'PropertyKey "path" 'TString]
forall (s :: Symbol) (r :: [PropertyKey]).
(KnownSymbol s, NotElem s r) =>
KeyNameProxy s
-> Text
-> Text
-> Properties r
-> Properties ('PropertyKey s 'TString : r)
defineStringProperty
            #path
            Text
"Set path to 'cabal-fmt' executable"
            Text
"cabal-fmt"

-- | 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) -> PluginId -> FormattingHandler IdeState
provider :: Recorder (WithPriority Log)
-> PluginId -> FormattingHandler IdeState
provider Recorder (WithPriority Log)
recorder PluginId
_ IdeState
_ Maybe ProgressToken
_ (FormatRange Range
_) Text
_ NormalizedFilePath
_ FormattingOptions
_ = do
  Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (HandlerM 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 (HandlerM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> PluginError
-> ExceptT PluginError (HandlerM 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 PluginId
plId IdeState
ideState 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]
  String
cabalFmtExePath <- (Text -> String)
-> ExceptT PluginError (HandlerM Config) Text
-> ExceptT PluginError (HandlerM Config) String
forall a b.
(a -> b)
-> ExceptT PluginError (HandlerM Config) a
-> ExceptT PluginError (HandlerM Config) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack (ExceptT PluginError (HandlerM Config) Text
 -> ExceptT PluginError (HandlerM Config) String)
-> ExceptT PluginError (HandlerM Config) Text
-> ExceptT PluginError (HandlerM Config) String
forall a b. (a -> b) -> a -> b
$ IO Text -> ExceptT PluginError (HandlerM Config) Text
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT PluginError (HandlerM Config) Text)
-> IO Text -> ExceptT PluginError (HandlerM Config) Text
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Text -> IO Text
forall a. String -> IdeState -> Action a -> IO a
runAction String
"cabal-gild" IdeState
ideState (Action Text -> IO Text) -> Action Text -> IO Text
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "path"
-> PluginId
-> Properties '[ 'PropertyKey "path" 'TString]
-> Action
     (ToHsType (FindByKeyName "path" '[ 'PropertyKey "path" 'TString]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "path"
#path PluginId
plId Properties '[ 'PropertyKey "path" 'TString]
properties
  Maybe String
x <- IO (Maybe String)
-> ExceptT PluginError (HandlerM Config) (Maybe String)
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String)
 -> ExceptT PluginError (HandlerM Config) (Maybe String))
-> IO (Maybe String)
-> ExceptT PluginError (HandlerM Config) (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
cabalFmtExePath
  case Maybe String
x of
    Just String
_ -> do
      (ExitCode
exitCode, Text
out, Text
err) <-
        IO (ExitCode, Text, Text)
-> ExceptT PluginError (HandlerM Config) (ExitCode, Text, Text)
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text)
 -> ExceptT PluginError (HandlerM Config) (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> ExceptT PluginError (HandlerM Config) (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text -> IO (ExitCode, Text, Text)
Process.readCreateProcessWithExitCode
          ( String -> [String] -> CreateProcess
proc String
cabalFmtExePath [String]
cabalFmtArgs
          )
            { cwd = Just $ takeDirectory fp
            }
          Text
contents
      Priority -> Log -> ExceptT PluginError (HandlerM Config) ()
log Priority
Debug (Log -> ExceptT PluginError (HandlerM Config) ())
-> Log -> ExceptT PluginError (HandlerM 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 (HandlerM Config) ()
log Priority
Error (Log -> ExceptT PluginError (HandlerM Config) ())
-> Log -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ Int -> Log
LogProcessInvocationFailure Int
code
          PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (HandlerM 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 (HandlerM Config) ([TextEdit] |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TextEdit] |? Null)
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> ([TextEdit] |? Null)
-> ExceptT PluginError (HandlerM 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 (HandlerM Config) ()
log Priority
Error (Log -> ExceptT PluginError (HandlerM Config) ())
-> Log -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogFormatterBinNotFound String
cabalFmtExePath
      PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> PluginError
PluginInternalError Text
"No installation of cabal-gild could be found. Please install it globally, or provide the full path to the executable")
  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 (HandlerM Config) ()
log = Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder