{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}

module Ide.Plugin.CabalGild where

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           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 T.Text
  | LogReadCreateProcessInfo [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 Text
err ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"Invocation of cabal-gild 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
        , Doc ann
"Stderr:" 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
err
        ]
    LogReadCreateProcessInfo [String]
args ->
      Doc ann
"Formatter invocation: cabal-gild " 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
    Log
LogInvalidInvocationInfo -> Doc ann
"Invocation of cabal-gild with range was called but is not supported."
    LogFormatterBinNotFound String
fp -> Doc ann
"Couldn't find formatter executable 'cabal-gild' 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-gild")
    { 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-gild' executable"
            Text
"cabal-gild"

-- | Formatter provider of cabal gild.
-- 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-gild."
provider Recorder (WithPriority Log)
recorder PluginId
plId IdeState
ideState Maybe ProgressToken
_ FormattingType
FormatText Text
contents NormalizedFilePath
nfp FormattingOptions
_ = do
  let cabalGildArgs :: [String]
cabalGildArgs = [String
"--stdin=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fp, String
"--input=-"] -- < Read from stdin

  String
cabalGildExePath <- (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
cabalGildExePath
  case Maybe String
x of
    Just String
_ -> do
      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
$ [String] -> Log
LogReadCreateProcessInfo [String]
cabalGildArgs
      (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
cabalGildExePath [String]
cabalGildArgs
          )
            { cwd = Just $ takeDirectory fp
            }
          Text
contents
      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 -> Text -> Log
LogProcessInvocationFailure Int
code Text
err
          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-gild")
        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
cabalGildExePath
      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
    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