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

import           Control.Monad.IO.Class
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Development.IDE                 hiding (pluginHandlers)
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.PluginUtils
import           Ide.Types
import           Language.Haskell.Stylish
import           Language.LSP.Types              as J
import           System.Directory
import           System.FilePath

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = FormattingHandler IdeState -> PluginHandlers IdeState
forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers FormattingHandler IdeState
provider
  }

-- | 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 FormattingType
typ Text
contents NormalizedFilePath
fp FormattingOptions
_opts = do
  DynFlags
dyn <- (ModSummaryResult -> DynFlags)
-> LspT Config IO ModSummaryResult -> LspT Config IO DynFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags)
-> (ModSummaryResult -> ModSummary) -> ModSummaryResult -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummaryResult -> ModSummary
msrModSummary) (LspT Config IO ModSummaryResult -> LspT Config IO DynFlags)
-> LspT Config IO ModSummaryResult -> LspT Config IO DynFlags
forall a b. (a -> b) -> a -> b
$ IO ModSummaryResult -> LspT Config IO ModSummaryResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummaryResult -> LspT Config IO ModSummaryResult)
-> IO ModSummaryResult -> LspT Config IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ String
-> IdeState -> Action ModSummaryResult -> IO ModSummaryResult
forall a. String -> IdeState -> Action a -> IO a
runAction String
"stylish-haskell" IdeState
ide (Action ModSummaryResult -> IO ModSummaryResult)
-> Action ModSummaryResult -> IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
fp
  let file :: String
file = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
fp
  Config
config <- IO Config -> LspT Config IO Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> LspT Config IO Config)
-> IO Config -> LspT Config IO Config
forall a b. (a -> b) -> a -> b
$ String -> IO Config
loadConfigFrom String
file
  Config
mergedConfig <- IO Config -> LspT Config IO Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> LspT Config IO Config)
-> IO Config -> LspT Config IO 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
extractRange 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 -> Either ResponseError (List TextEdit)
-> LspM Config (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List TextEdit)
 -> LspM Config (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> LspM Config (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (List TextEdit)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (List TextEdit))
-> ResponseError -> Either ResponseError (List TextEdit)
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
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 -> Either ResponseError (List TextEdit)
-> LspM Config (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List TextEdit)
 -> LspM Config (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> LspM Config (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ List TextEdit -> Either ResponseError (List TextEdit)
forall a b. b -> Either a b
Right (List TextEdit -> Either ResponseError (List TextEdit))
-> List TextEdit -> Either ResponseError (List TextEdit)
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
TextEdit Range
range Text
new]
  where
    getMergedConfig :: DynFlags -> Config -> IO Config
getMergedConfig DynFlags
dyn Config
config
      | [String] -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure
            (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ Config
config
              { configLanguageExtensions :: [String]
configLanguageExtensions = DynFlags -> [String]
getExtensions DynFlags
dyn }
      | Bool
otherwise
      = Config -> IO Config
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 (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 (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