{-# LANGUAGE PolyKinds    #-}
{-# LANGUAGE TypeFamilies #-}
module Ide.Plugin.Brittany where

import           Control.Exception           (bracket_)
import           Control.Lens
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe   (MaybeT, runMaybeT)
import           Data.Coerce
import           Data.Maybe                  (mapMaybe, maybeToList)
import           Data.Semigroup
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Development.IDE             hiding (pluginHandlers)
import           Development.IDE.GHC.Compat  (ModSummary (ms_hspp_opts), topDir)
import qualified DynFlags                    as D
import qualified EnumSet                     as S
import           GHC.LanguageExtensions.Type
import           Ide.PluginUtils
import           Ide.Types
import           Language.Haskell.Brittany
import           Language.LSP.Types          as J
import qualified Language.LSP.Types.Lens     as J
import           System.Environment          (setEnv, unsetEnv)
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 Brittany.
-- 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
nfp FormattingOptions
opts = IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (List TextEdit))
 -> LspT Config IO (Either ResponseError (List TextEdit)))
-> IO (Either ResponseError (List TextEdit))
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ do
    Maybe FilePath
confFile <- NormalizedFilePath -> IO (Maybe FilePath)
getConfFile NormalizedFilePath
nfp
    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)
    ModSummary
modsum <- (ModSummaryResult -> ModSummary)
-> IO ModSummaryResult -> IO ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModSummaryResult -> ModSummary
msrModSummary (IO ModSummaryResult -> IO ModSummary)
-> IO ModSummaryResult -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ FilePath
-> IdeState -> Action ModSummaryResult -> IO ModSummaryResult
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"brittany" IdeState
ide (Action ModSummaryResult -> IO ModSummaryResult)
-> Action ModSummaryResult -> IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummaryWithoutTimestamps
-> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
nfp
    let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
modsum
    let withRuntimeLibdir :: IO (Either [BrittanyError] Text)
-> IO (Either [BrittanyError] Text)
withRuntimeLibdir = IO ()
-> IO ()
-> IO (Either [BrittanyError] Text)
-> IO (Either [BrittanyError] Text)
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (FilePath -> FilePath -> IO ()
setEnv FilePath
key (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath
topDir DynFlags
dflags) (FilePath -> IO ()
unsetEnv FilePath
key)
          where key :: FilePath
key = FilePath
"GHC_EXACTPRINT_GHC_LIBDIR"
    Either [BrittanyError] Text
res <- IO (Either [BrittanyError] Text)
-> IO (Either [BrittanyError] Text)
withRuntimeLibdir (IO (Either [BrittanyError] Text)
 -> IO (Either [BrittanyError] Text))
-> IO (Either [BrittanyError] Text)
-> IO (Either [BrittanyError] Text)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe FilePath
-> FormattingOptions
-> Text
-> IO (Either [BrittanyError] Text)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> Maybe FilePath
-> FormattingOptions
-> Text
-> m (Either [BrittanyError] Text)
formatText DynFlags
dflags Maybe FilePath
confFile FormattingOptions
opts Text
selectedContents
    case Either [BrittanyError] Text
res of
      Left [BrittanyError]
err -> Either ResponseError (List TextEdit)
-> IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List TextEdit)
 -> IO (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> IO (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 (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"brittanyCmd: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines ((BrittanyError -> FilePath) -> [BrittanyError] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map BrittanyError -> FilePath
showErr [BrittanyError]
err))
      Right Text
newText -> Either ResponseError (List TextEdit)
-> IO (Either ResponseError (List TextEdit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List TextEdit)
 -> IO (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> IO (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
newText]

-- | Primitive to format text with the given option.
-- May not throw exceptions but return a Left value.
-- Errors may be presented to the user.
formatText
  :: MonadIO m
  => D.DynFlags
  -> Maybe FilePath -- ^ Path to configs. If Nothing, default configs will be used.
  -> FormattingOptions -- ^ Options for the formatter such as indentation.
  -> Text -- ^ Text to format
  -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany.
formatText :: DynFlags
-> Maybe FilePath
-> FormattingOptions
-> Text
-> m (Either [BrittanyError] Text)
formatText DynFlags
df Maybe FilePath
confFile FormattingOptions
opts Text
text =
  IO (Either [BrittanyError] Text) -> m (Either [BrittanyError] Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [BrittanyError] Text)
 -> m (Either [BrittanyError] Text))
-> IO (Either [BrittanyError] Text)
-> m (Either [BrittanyError] Text)
forall a b. (a -> b) -> a -> b
$ Int
-> DynFlags
-> Maybe FilePath
-> Text
-> IO (Either [BrittanyError] Text)
runBrittany Int
tabSize DynFlags
df Maybe FilePath
confFile Text
text
  where tabSize :: Int
tabSize = FormattingOptions
opts FormattingOptions -> Getting Int FormattingOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int FormattingOptions Int
forall s a. HasTabSize s a => Lens' s a
J.tabSize

-- | Recursively search in every directory of the given filepath for brittany.yaml.
-- If no such file has been found, return Nothing.
getConfFile :: NormalizedFilePath -> IO (Maybe FilePath)
getConfFile :: NormalizedFilePath -> IO (Maybe FilePath)
getConfFile = FilePath -> IO (Maybe FilePath)
findLocalConfigPath (FilePath -> IO (Maybe FilePath))
-> (NormalizedFilePath -> FilePath)
-> NormalizedFilePath
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory (FilePath -> FilePath)
-> (NormalizedFilePath -> FilePath)
-> NormalizedFilePath
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> FilePath
fromNormalizedFilePath

-- | Run Brittany on the given text with the given tab size and
-- a configuration path. If no configuration path is given, a
-- default configuration is chosen. The configuration may overwrite
-- tab size parameter.
--
-- Returns either a list of Brittany Errors or the reformatted text.
-- May not throw an exception.
runBrittany :: Int              -- ^ tab  size
            -> D.DynFlags
            -> Maybe FilePath   -- ^ local config file
            -> Text             -- ^ text to format
            -> IO (Either [BrittanyError] Text)
runBrittany :: Int
-> DynFlags
-> Maybe FilePath
-> Text
-> IO (Either [BrittanyError] Text)
runBrittany Int
tabSize DynFlags
df Maybe FilePath
confPath Text
text = do
  let cfg :: CConfig Option
cfg = CConfig Option
forall a. Monoid a => a
mempty
              { _conf_layout :: CLayoutConfig Option
_conf_layout =
                  CLayoutConfig Option
forall a. Monoid a => a
mempty { _lconfig_indentAmount :: Option (Last Int)
_lconfig_indentAmount = Last Int -> Option (Last Int)
forall a. a -> Option a
opt (Int -> Last Int
coerce Int
tabSize)
                         }
              , _conf_forward :: CForwardOptions Option
_conf_forward =
                  (CForwardOptions Option
forall a. Monoid a => a
mempty :: CForwardOptions Option)
                    { _options_ghc :: Option [FilePath]
_options_ghc = [FilePath] -> Option [FilePath]
forall a. a -> Option a
opt (DynFlags -> [FilePath]
getExtensions DynFlags
df)
                    }
              }

  Config
config <- IO Config -> MaybeT IO Config -> IO Config
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a -> m a
fromMaybeT (Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
staticDefaultConfig) (CConfig Option -> [FilePath] -> MaybeT IO Config
readConfigsWithUserConfig CConfig Option
cfg (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
confPath))
  Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule Config
config Text
text

fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
fromMaybeT :: m a -> MaybeT m a -> m a
fromMaybeT m a
def MaybeT m a
act = MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT m a
act m (Maybe a) -> (Maybe a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
def a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

opt :: a -> Option a
opt :: a -> Option a
opt = Maybe a -> Option a
forall a. Maybe a -> Option a
Option (Maybe a -> Option a) -> (a -> Maybe a) -> a -> Option a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just

showErr :: BrittanyError -> String
showErr :: BrittanyError -> FilePath
showErr (ErrorInput FilePath
s)          = FilePath
s
showErr (ErrorMacroConfig  FilePath
err FilePath
input)
  = FilePath
"Error: parse error in inline configuration: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in the string \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"."
showErr (ErrorUnusedComment FilePath
s)  = FilePath
s
showErr (LayoutWarning FilePath
s)       = FilePath
s
showErr (ErrorUnknownNode FilePath
s GenLocated SrcSpan ast
_)  = FilePath
s
showErr BrittanyError
ErrorOutputCheck        = FilePath
"Brittany error - invalid output"

showExtension :: Extension -> Maybe String
showExtension :: Extension -> Maybe FilePath
showExtension Extension
Cpp              = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"-XCPP"
-- Brittany chokes on parsing extensions that produce warnings
showExtension Extension
DatatypeContexts = Maybe FilePath
forall a. Maybe a
Nothing
showExtension Extension
RecordPuns       = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"-XNamedFieldPuns"
showExtension Extension
other            = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"-X" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Extension -> FilePath
forall a. Show a => a -> FilePath
show Extension
other

getExtensions :: D.DynFlags -> [String]
getExtensions :: DynFlags -> [FilePath]
getExtensions = (Extension -> Maybe FilePath) -> [Extension] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Extension -> Maybe FilePath
showExtension ([Extension] -> [FilePath])
-> (DynFlags -> [Extension]) -> DynFlags -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
S.toList (EnumSet Extension -> [Extension])
-> (DynFlags -> EnumSet Extension) -> DynFlags -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
D.extensionFlags