{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}

-- | Provides code actions to add missing pragmas (whenever GHC suggests to)
module Ide.Plugin.Pragmas
  ( descriptor
  ) where

import           Control.Applicative              ((<|>))
import           Control.Lens                     hiding (List)
import           Control.Monad                    (join)
import           Control.Monad.IO.Class           (MonadIO (liftIO))
import           Control.Monad.Trans.State.Strict (State)
import           Data.Bits                        (Bits (bit, complement, setBit, (.&.)))
import           Data.Char                        (isSpace)
import qualified Data.Char                        as Char
import           Data.Coerce                      (coerce)
import           Data.Functor                     (void, ($>))
import qualified Data.HashMap.Strict              as H
import qualified Data.List                        as List
import           Data.List.Extra                  (nubOrdOn)
import qualified Data.Map.Strict                  as Map
import           Data.Maybe                       (catMaybes, listToMaybe,
                                                   mapMaybe)
import qualified Data.Maybe                       as Maybe
import           Data.Ord                         (Down (Down))
import           Data.Semigroup                   (Semigroup ((<>)))
import qualified Data.Text                        as T
import           Data.Word                        (Word64)
import           Development.IDE                  as D (Diagnostic (Diagnostic, _code, _message),
                                                        GhcSession (GhcSession),
                                                        HscEnvEq (hscEnv),
                                                        IdeState, List (List),
                                                        ParseResult (POk),
                                                        Position (Position),
                                                        Range (Range), Uri,
                                                        getFileContents,
                                                        getParsedModule,
                                                        prettyPrint, runAction,
                                                        srcSpanToRange,
                                                        toNormalizedUri,
                                                        uriToFilePath',
                                                        useWithStale)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util  (StringBuffer, atEnd,
                                                   nextChar,
                                                   stringToStringBuffer)
import qualified Development.IDE.Spans.Pragmas    as Pragmas
import           Development.IDE.Types.HscEnvEq   (HscEnvEq, hscEnv)
import           Ide.Types
import qualified Language.LSP.Server              as LSP
import qualified Language.LSP.Types               as J
import qualified Language.LSP.Types.Lens          as J
import qualified Language.LSP.VFS                 as VFS
import qualified Text.Fuzzy                       as Fuzzy

-- ---------------------------------------------------------------------

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor plId = (defaultPluginDescriptor plId)
  { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider
                  <> mkPluginHandler J.STextDocumentCompletion completion
  }

-- ---------------------------------------------------------------------
-- | Title and pragma
type PragmaEdit = (T.Text, Pragma)

data Pragma = LangExt T.Text | OptGHC T.Text
  deriving (Show, Eq, Ord)

codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly))
  | let J.TextDocumentIdentifier{ _uri = uri } = docId
  , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do
      -- ghc session to get some dynflags even if module isn't parsed
      ghcSession <- liftIO $ runAction "Pragmas.GhcSession" state $ useWithStale GhcSession normalizedFilePath
      (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath
      parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath
      let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule

      case ghcSession of
        Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) ->
          let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
              pedits = nubOrdOn snd . concat $ suggest parsedModuleDynFlags <$> diags
          in
            pure $ Right $ List $ pragmaEditToAction uri nextPragmaInfo <$> pedits
        Nothing -> pure $ Right $ List []
  | otherwise = pure $ Right $ List []


-- | Add a Pragma to the given URI at the top of the file.
-- It is assumed that the pragma name is a valid pragma,
-- thus, not validated.
pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (J.Command J.|? J.CodeAction)
pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) =
  J.InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing Nothing
  where
    render (OptGHC x)  = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n"
    render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n"
    pragmaInsertPosition = Position (fromIntegral nextPragmaLine) 0
    pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition
    -- workaround the fact that for some reason lsp-test applies text
    -- edits in reverse order than lsp (tried in both coc.nvim and vscode)
    textEdits =
      if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits
         , let J.TextEdit{ _range, _newText } = insertTextEdit ->
             [J.TextEdit _range (render p <> _newText), deleteTextEdit]
         | otherwise -> [J.TextEdit pragmaInsertRange (render p)]

    edit =
      J.WorkspaceEdit
        (Just $ H.singleton uri (J.List textEdits))
        Nothing
        Nothing

suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggest dflags diag =
  suggestAddPragma dflags diag
    ++ suggestDisableWarning diag

-- ---------------------------------------------------------------------

suggestDisableWarning :: Diagnostic -> [PragmaEdit]
suggestDisableWarning Diagnostic {_code}
  | Just (J.InR (T.stripPrefix "-W" -> Just w)) <- _code
  , w `notElem` warningBlacklist =
    pure ("Disable \"" <> w <> "\" warnings", OptGHC w)
  | otherwise = []

-- Don't suggest disabling type errors as a solution to all type errors
warningBlacklist :: [T.Text]
-- warningBlacklist = []
warningBlacklist = ["deferred-type-errors"]

-- ---------------------------------------------------------------------

-- | Offer to add a missing Language Pragma to the top of a file.
-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggestAddPragma mDynflags Diagnostic {_message} = genPragma _message
  where
    genPragma target =
      [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
    disabled
      | Just dynFlags <- mDynflags =
        -- GHC does not export 'OnOff', so we have to view it as string
        catMaybes $ T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags
      | otherwise =
        -- When the module failed to parse, we don't have access to its
        -- dynFlags. In that case, simply don't disable any pragmas.
        []

-- | Find all Pragmas are an infix of the search term.
findPragma :: T.Text -> [T.Text]
findPragma str = concatMap check possiblePragmas
  where
    check p = [p | T.isInfixOf p str]

    -- We exclude the Strict extension as it causes many false positives, see
    -- the discussion at https://github.com/haskell/ghcide/pull/638
    --
    -- We don't include the No- variants, as GHC never suggests disabling an
    -- extension in an error message.
    possiblePragmas :: [T.Text]
    possiblePragmas =
       [ name
       | FlagSpec{flagSpecName = T.pack -> name} <- xFlags
       , "Strict" /= name
       ]

-- | All language pragmas, including the No- variants
allPragmas :: [T.Text]
allPragmas =
  concat
    [ [name, "No" <> name]
    | FlagSpec{flagSpecName = T.pack -> name} <- xFlags
    ]
  <>
  -- These pragmas are not part of xFlags as they are not reversable
  -- by prepending "No".
  [ -- Safe Haskell
    "Unsafe"
  , "Trustworthy"
  , "Safe"

    -- Language Version Extensions
  , "Haskell98"
  , "Haskell2010"
    -- Maybe, GHC 2021 after its release?
  ]

-- ---------------------------------------------------------------------
flags :: [T.Text]
flags = map (T.pack . stripLeading '-') $ flagsForCompletion False

completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion
completion _ide _ complParams = do
    let (J.TextDocumentIdentifier uri) = complParams ^. J.textDocument
        position = complParams ^. J.position
    contents <- LSP.getVirtualFile $ toNormalizedUri uri
    fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of
        (Just cnts, Just _path) ->
            result <$> VFS.getCompletionPrefix position cnts
            where
                result (Just pfix)
                    | "{-# language" `T.isPrefixOf` line
                    = J.List $ map buildCompletion
                        (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
                    | "{-# options_ghc" `T.isPrefixOf` line
                    = J.List $ map mkExtCompl
                        (Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
                    | "{-#" `T.isPrefixOf` line
                    = J.List $ map (\(a, b, c) -> mkPragmaCompl (a <> suffix) b c) validPragmas
                    | otherwise
                    = J.List []
                    where
                        line = T.toLower $ VFS.fullLine pfix
                        suffix
                            | "#-}" `T.isSuffixOf` line = " "
                            | "-}"  `T.isSuffixOf` line = " #"
                            | "}"   `T.isSuffixOf` line = " #-"
                            | otherwise                 = " #-}"
                result Nothing = J.List []
                buildCompletion p =
                    J.CompletionItem
                      { _label = p,
                        _kind = Just J.CiKeyword,
                        _tags = Nothing,
                        _detail = Nothing,
                        _documentation = Nothing,
                        _deprecated = Nothing,
                        _preselect = Nothing,
                        _sortText = Nothing,
                        _filterText = Nothing,
                        _insertText = Nothing,
                        _insertTextFormat = Nothing,
                        _insertTextMode = Nothing,
                        _textEdit = Nothing,
                        _additionalTextEdits = Nothing,
                        _commitCharacters = Nothing,
                        _command = Nothing,
                        _xdata = Nothing
                      }
        _ -> return $ J.List []

-----------------------------------------------------------------------
validPragmas :: [(T.Text, T.Text, T.Text)]
validPragmas =
  [ ("LANGUAGE ${1:extension}"         , "LANGUAGE",           "{-# LANGUAGE #-}")
  , ("OPTIONS_GHC -${1:option}"        , "OPTIONS_GHC",        "{-# OPTIONS_GHC #-}")
  , ("INLINE ${1:function}"            , "INLINE",             "{-# INLINE #-}")
  , ("NOINLINE ${1:function}"          , "NOINLINE",           "{-# NOINLINE #-}")
  , ("INLINABLE ${1:function}"         , "INLINABLE",          "{-# INLINABLE #-}")
  , ("WARNING ${1:message}"            , "WARNING",            "{-# WARNING #-}")
  , ("DEPRECATED ${1:message}"         , "DEPRECATED",         "{-# DEPRECATED  #-}")
  , ("ANN ${1:annotation}"             , "ANN",                "{-# ANN #-}")
  , ("RULES"                           , "RULES",              "{-# RULES #-}")
  , ("SPECIALIZE ${1:function}"        , "SPECIALIZE",         "{-# SPECIALIZE #-}")
  , ("SPECIALIZE INLINE ${1:function}" , "SPECIALIZE INLINE",  "{-# SPECIALIZE INLINE #-}")
  ]


mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem
mkPragmaCompl insertText label detail =
  J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail)
    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet)
    Nothing Nothing Nothing Nothing Nothing Nothing


stripLeading :: Char -> String -> String
stripLeading _ [] = []
stripLeading c (s:ss)
  | s == c = ss
  | otherwise = s:ss


mkExtCompl :: T.Text -> J.CompletionItem
mkExtCompl label =
  J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing Nothing Nothing



