{-# LANGUAGE CPP          #-}
{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE MultiWayIf   #-}
{-# 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.Maybe                                      (fromMaybe,
                                                                  mapMaybe,
                                                                  maybeToList)
import           Data.Semigroup
import           Data.Text                                       (Text)
import qualified Data.Text                                       as T
import           Development.IDE                                 hiding
                                                                 (pluginHandlers)
import qualified Development.IDE.GHC.Compat                      as GHC hiding
                                                                        (Cpp)
import qualified Development.IDE.GHC.Compat.Util                 as GHC
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

-- These imports are for the temporary pPrintText & can be removed when
-- issue #2005 is resolved
import           Control.Monad.Trans.Class                       (lift)
import qualified Control.Monad.Trans.Except                      as ExceptT
import           Data.CZipWith
import qualified Data.List                                       as List
import qualified Data.Text                                       as Text
import qualified Data.Text.Lazy                                  as TextL
import qualified GHC.LanguageExtensions.Type                     as GHC
import           Language.Haskell.Brittany.Internal
import           Language.Haskell.Brittany.Internal.Config
import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.Obfuscation
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint                 as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types           as ExactPrint


descriptor :: PluginId -> PluginDescriptor IdeState
descriptor plId = (defaultPluginDescriptor plId)
  { pluginHandlers = mkFormattingHandlers 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 ide typ contents nfp opts = liftIO $ do
    confFile <- getConfFile nfp
    let (range, selectedContents) = case typ of
          FormatText    -> (fullRange contents, contents)
          FormatRange r -> (normalize r, extractRange r contents)
    modsum <- fmap msrModSummary $ runAction "brittany" ide $ use_ GetModSummaryWithoutTimestamps nfp
    let dflags = GHC.ms_hspp_opts modsum
    let withRuntimeLibdir = bracket_ (setEnv key $ GHC.topDir dflags) (unsetEnv key)
          where key = "GHC_EXACTPRINT_GHC_LIBDIR"
    res <- withRuntimeLibdir $ formatText dflags confFile opts selectedContents
    case res of
      Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err))
      Right newText -> return $ Right $ J.List [TextEdit range 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
  => GHC.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 df confFile opts text =
  liftIO $ runBrittany tabSize df confFile text
  where tabSize = fromIntegral $ opts ^. 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 = findLocalConfigPath . takeDirectory . 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
            -> GHC.DynFlags
            -> Maybe FilePath   -- ^ local config file
            -> Text             -- ^ text to format
            -> IO (Either [BrittanyError] Text)
runBrittany tabSize df confPath text = do
  let cfg = mempty
              { _conf_layout =
                  mempty { _lconfig_indentAmount = opt (Last tabSize)
                         }
              , _conf_forward =
                  (mempty :: CForwardOptions CMaybe)
                    { _options_ghc = opt (getExtensions df)
                    }
              }
  config <- fromMaybeT (pure staticDefaultConfig)
                       (readConfigsWithUserConfig cfg (maybeToList confPath))
  (errsAndWarnings, resultText) <- pPrintText config text
  if any isError errsAndWarnings then
    return $ Left errsAndWarnings
  else
    return $ Right resultText

#if MIN_VERSION_brittany(0,14,0)
type CMaybe = Maybe
opt :: a -> Maybe a
opt = Just
#else
type CMaybe = Option
opt :: a -> Option a
opt = Option . Just
#endif

fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
fromMaybeT def act = runMaybeT act >>= maybe def return

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

showExtension :: Extension -> Maybe String
showExtension Cpp              = Just "-XCPP"
-- Brittany chokes on parsing extensions that produce warnings
showExtension DatatypeContexts = Nothing
showExtension RecordPuns       = Just "-XNamedFieldPuns"
showExtension other            = Just $ "-X" ++ show other

getExtensions :: GHC.DynFlags -> [String]
getExtensions = mapMaybe showExtension . GHC.toList . GHC.extensionFlags


-- | This is a temporary fix that allows us to format the text if brittany
-- throws warnings during pretty printing.
--
-- It should be removed when our PR to brittany is merged + released.
-- See:
--  - https://github.com/haskell/haskell-language-server/issues/2005
--  - https://github.com/lspitzner/brittany/pull/351
pPrintText
  :: Config -- ^ global program config
  -> Text   -- ^ input text
  -> IO ([BrittanyError], Text) -- ^ list of errors/warnings & result text
pPrintText config text =
  fmap (either id id) . ExceptT.runExceptT $ do
    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
    -- there is a good of code duplication between the following code and the
    -- `pureModuleTransform` function. Unfortunately, there are also a good
    -- amount of slight differences: This module is a bit more verbose, and
    -- it tries to use the full-blown `parseModule` function which supports
    -- CPP (but requires the input to be a file..).
    let cppMode    = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
    -- the flag will do the following: insert a marker string
    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
    -- "#include" before processing (parsing) input; and remove that marker
    -- string from the transformation output.
    -- The flag is intentionally misspelled to prevent clashing with
    -- inline-config stuff.
    let hackAroundIncludes =
          config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
    let exactprintOnly = viaGlobal || viaDebug
         where
          viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
          viaDebug =
            config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack

    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
          then case cppMode of
            CPPModeAbort ->
              return $ Left "Encountered -XCPP. Aborting."
            CPPModeWarn ->
              return $ Right True
            CPPModeNowarn ->
              return $ Right True
          else return $ Right False
    parseResult <- do
        -- TODO: refactor this hack to not be mixed into parsing logic
        let hackF s = if "#include" `List.isPrefixOf` s
              then "-- BRITANY_INCLUDE_HACK " ++ s
              else s
        let hackTransform = if hackAroundIncludes && not exactprintOnly
              then List.intercalate "\n" . fmap hackF . lines'
              else id
        liftIO $ parseModuleFromString ghcOptions
                                                   "stdin"
                                                   cppCheckFunc
                                                   (hackTransform $ Text.unpack text)
    case parseResult of
      Left left -> do
        ExceptT.throwE ([ErrorInput left], text)
      Right (anns, parsedSource, hasCPP) -> do
        (inlineConf, perItemConf) <-
          case
            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
          of
            Left (err, input) -> do
              let errMsg =
                    "Error: parse error in inline configuration: "
                    <> err
                    <> "  in the string \""
                    <> input
                    <> "\"."
              ExceptT.throwE ([ErrorInput errMsg], text)
            Right c ->
              pure c
        let moduleConf = cZipWith fromOptionIdentity config inlineConf
        let disableFormatting =
              moduleConf & _conf_disable_formatting & confUnpack
        (errsWarns, outSText, _) <- do
          if
            | disableFormatting -> do
              pure ([], text, False)
            | exactprintOnly -> do
              let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
              pure ([], r, r /= text)
            | otherwise -> do
              (ews, outRaw) <- if hasCPP
                then return
                  $ pPrintModule moduleConf perItemConf anns parsedSource
                else liftIO $ pPrintModuleAndCheck moduleConf
                                                   perItemConf
                                                   anns
                                                   parsedSource
              let hackF s = fromMaybe s $ TextL.stripPrefix
                    (TextL.pack "-- BRITANY_INCLUDE_HACK ")
                    s
              let out = TextL.toStrict $ if hackAroundIncludes
                    then
                      TextL.intercalate (TextL.pack "\n")
                      $ hackF
                      <$> TextL.splitOn (TextL.pack "\n") outRaw
                    else outRaw
              out' <- if moduleConf & _conf_obfuscate & confUnpack
                then lift $ obfuscate out
                else pure out
              pure (ews, out', out' /= text)
        let customErrOrder ErrorInput{}         = 4
            customErrOrder LayoutWarning{}      = -1 :: Int
            customErrOrder ErrorOutputCheck{}   = 1
            customErrOrder ErrorUnusedComment{} = 2
            customErrOrder ErrorUnknownNode{}   = -2 :: Int
            customErrOrder ErrorMacroConfig{}   = 5
            hasErrors =
              if config & _conf_errorHandling & _econf_Werror & confUnpack
                then not $ null errsWarns
                else 0 < maximum (-1 : fmap customErrOrder errsWarns)
        return (errsWarns, if hasErrors then text else outSText)

isError :: BrittanyError -> Bool
isError = \case
    LayoutWarning{}    -> False
    ErrorUnknownNode{} -> False
    _                  -> True
