{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
module Ide.Plugin.StylishHaskell
  ( descriptor
  , provider
  )
where

import           Control.Monad.Except             (throwError)
import           Control.Monad.IO.Class
import           Data.Text                        (Text)
import qualified Data.Text                        as T
import           Development.IDE                  hiding (getExtensions,
                                                   pluginHandlers)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.GHC.Compat       (ModSummary (ms_hspp_opts),
                                                   extensionFlags)
import qualified Development.IDE.GHC.Compat.Util  as Util
import           GHC.LanguageExtensions.Type
import           Ide.Plugin.Error                 (PluginError (PluginInternalError))
import           Ide.PluginUtils
import           Ide.Types                        hiding (Config)
import           Language.Haskell.Stylish
import           Language.LSP.Protocol.Types      as LSP
import           System.Directory
import           System.FilePath

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
  { pluginHandlers = mkFormattingHandlers provider
  }
  where
    desc :: Text
desc = Text
"Provides formatting of Haskell files via stylish-haskell. Built with stylish-haskell-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VERSION_stylish_haskell

-- | Formatter provider of stylish-haskell.
-- 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 :: FormattingHandler IdeState
provider :: FormattingHandler IdeState
provider IdeState
ide Maybe ProgressToken
_token FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
_opts = do
  (ModSummaryResult -> ModSummary
msrModSummary -> ModSummary -> DynFlags
ms_hspp_opts -> DynFlags
dyn) <- String
-> IdeState
-> ExceptT PluginError Action ModSummaryResult
-> ExceptT PluginError (LspM Config) ModSummaryResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"stylish-haskell" IdeState
ide (ExceptT PluginError Action ModSummaryResult
 -> ExceptT PluginError (LspM Config) ModSummaryResult)
-> ExceptT PluginError Action ModSummaryResult
-> ExceptT PluginError (LspM Config) ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummary
-> NormalizedFilePath
-> ExceptT PluginError Action ModSummaryResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetModSummary
GetModSummary NormalizedFilePath
fp
  let file :: String
file = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
fp
  Config
config <- IO Config -> ExceptT PluginError (LspM Config) Config
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> ExceptT PluginError (LspM Config) Config)
-> IO Config -> ExceptT PluginError (LspM Config) Config
forall a b. (a -> b) -> a -> b
$ String -> IO Config
loadConfigFrom String
file
  Config
mergedConfig <- IO Config -> ExceptT PluginError (LspM Config) Config
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> ExceptT PluginError (LspM Config) Config)
-> IO Config -> ExceptT PluginError (LspM Config) Config
forall a b. (a -> b) -> a -> b
$ DynFlags -> Config -> IO Config
getMergedConfig DynFlags
dyn Config
config
  let (Range
range, Text
selectedContents) = case FormattingType
typ of
        FormattingType
FormatText    -> (Text -> Range
fullRange Text
contents, Text
contents)
        FormatRange Range
r -> (Range -> Range
normalize Range
r, Range -> Text -> Text
extractTextInRange (Range -> Range
extendToFullLines Range
r) Text
contents)
      result :: Either String Text
result = String -> Config -> Text -> Either String Text
runStylishHaskell String
file Config
mergedConfig Text
selectedContents
  case Either String Text
result of
    Left  String
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) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"stylishHaskellCmd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
    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
LSP.InL [Range -> Text -> TextEdit
TextEdit Range
range Text
new]
  where
    getMergedConfig :: DynFlags -> Config -> IO Config
getMergedConfig DynFlags
dyn Config
config
      | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> [String]
configLanguageExtensions Config
config)
      = do
          Logger -> Text -> IO ()
logInfo (IdeState -> Logger
ideLogger IdeState
ide) Text
"stylish-haskell uses the language extensions from DynFlags"
          Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ Config
config
              { configLanguageExtensions = getExtensions dyn }
      | Bool
otherwise
      = Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config

    getExtensions :: DynFlags -> [String]
getExtensions = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
showExtension ([Extension] -> [String])
-> (DynFlags -> [Extension]) -> DynFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
Util.toList (EnumSet Extension -> [Extension])
-> (DynFlags -> EnumSet Extension) -> DynFlags -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
extensionFlags

    showExtension :: Extension -> String
showExtension Extension
Cpp   = String
"CPP"
    showExtension Extension
other = Extension -> String
forall a. Show a => a -> String
show Extension
other

-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
-- If no such file has been found, return default config.
loadConfigFrom :: FilePath -> IO Config
loadConfigFrom :: String -> IO Config
loadConfigFrom String
file = do
  String
currDir <- IO String
getCurrentDirectory
  String -> IO ()
setCurrentDirectory (String -> String
takeDirectory String
file)
  Config
config <- (String -> IO ()) -> Maybe String -> IO Config
loadConfig (Bool -> String -> IO ()
makeVerbose Bool
False) Maybe String
forall a. Maybe a
Nothing
  String -> IO ()
setCurrentDirectory String
currDir
  Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config

-- | Run stylish-haskell on the given text with the given configuration.
runStylishHaskell :: FilePath           -- ^ Location of the file being formatted. Used for error message
                  -> Config             -- ^ Configuration for stylish-haskell
                  -> Text               -- ^ Text to format
                  -> Either String Text -- ^ Either formatted Text or an error message
runStylishHaskell :: String -> Config -> Text -> Either String Text
runStylishHaskell String
file Config
config = ([String] -> Text) -> Either String [String] -> Either String Text
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> Text
fromLines (Either String [String] -> Either String Text)
-> (Text -> Either String [String]) -> Text -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Either String [String]
fmt ([String] -> Either String [String])
-> (Text -> [String]) -> Text -> Either String [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [String]
toLines
  where
    fromLines :: [String] -> Text
fromLines = String -> Text
T.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    fmt :: [String] -> Either String [String]
fmt = [String]
-> Maybe String -> [Step] -> [String] -> Either String [String]
runSteps (Config -> [String]
configLanguageExtensions Config
config) (String -> Maybe String
forall a. a -> Maybe a
Just String
file) (Config -> [Step]
configSteps Config
config)
    toLines :: Text -> [String]
toLines = String -> [String]
lines (String -> [String]) -> (Text -> String) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack