refactor issues

hints.txt

PS D:\dev\ws\haskell\hls> hlint .\plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:8:1-34: Warning: Unused LANGUAGE pragma
Found:
  {-# LANGUAGE RecordWildCards #-}
Perhaps you should remove it.
Note: may require `{-# LANGUAGE DisambiguateRecordFields #-}` adding to the top of the file

plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:9:1-34: Warning: Unused LANGUAGE pragma
Found:
  {-# LANGUAGE TupleSections #-}
Perhaps you should remove it.

plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:11:1-34: Warning: Unused LANGUAGE pragma
Found:
  {-# LANGUAGE ViewPatterns #-}
Perhaps you should remove it.

plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:88:12: Suggestion: Redundant $
Found:
  return $ (diagnostics file ideas, Just ())
Perhaps:
  return (diagnostics file ideas, Just ())

plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:206:47-83: Suggestion: Redundant bracket
Found:
Perhaps:
  Right . LSP.List . map CACodeAction <$> hlintActions

plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:308:29-43: Suggestion: Redundant bracket
Found:
  Right <$> (return wsEdit)
Perhaps:
  Right <$> return wsEdit

6 hints

Hlint.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE ViewPatterns      #-}

module Ide.Plugin.Hlint
  (
    descriptor
  --, provider
  ) where
import Refact.Apply
import Control.Arrow ((&&&))
import Control.DeepSeq
import Control.Exception
import Control.Lens ((^.))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..))
import Data.Binary
import qualified Data.HashSet as HashSet
import Data.Hashable
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Development.IDE.Core.OfInterest
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake
import Development.IDE.Types.Diagnostics as D
import Development.IDE.Types.Location
import Development.Shake
-- import Development.Shake hiding ( Diagnostic )
import GHC hiding (DynFlags(..))

#ifndef GHC_LIB
import GHC (DynFlags(..))
import HscTypes (hsc_dflags)
#else
import RealGHC (DynFlags(..))
import RealGHC.HscTypes (hsc_dflags)
import qualified RealGHC.EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
#endif

import Ide.Logger
import Ide.Types
import Ide.Plugin
import Ide.PluginUtils
import Language.Haskell.HLint as Hlint
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types      as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Text.Regex.TDFA.Text()
import GHC.Generics (Generic)

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

descriptor :: PluginId -> PluginDescriptor
descriptor plId = (defaultPluginDescriptor plId)
  { pluginRules = rules
  , pluginCommands =
      [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
      , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
      ]
    , pluginCodeActionProvider = Just codeActionProvider
  }

data GetHlintDiagnostics = GetHlintDiagnostics
    deriving (Eq, Show, Typeable, Generic)
instance Hashable GetHlintDiagnostics
instance NFData   GetHlintDiagnostics
instance Binary   GetHlintDiagnostics

type instance RuleResult GetHlintDiagnostics = ()

rules :: Rules ()
rules = do
  define $ \GetHlintDiagnostics file -> do
    ideas <- getIdeas file
    return $ (diagnostics file ideas, Just ())

  getHlintSettingsRule (HlintEnabled [])

  action $ do
    files <- getFilesOfInterest
    void $ uses GetHlintDiagnostics $ HashSet.toList files

  where

      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
      diagnostics file (Right ideas) =
        [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore]
      diagnostics file (Left parseErr) =
        [(file, ShowDiag, parseErrorToDiagnostic parseErr)]

      ideaToDiagnostic :: Idea -> Diagnostic
      ideaToDiagnostic idea =
        LSP.Diagnostic {
            _range    = srcSpanToRange $ ideaSpan idea
          , _severity = Just LSP.DsInfo
          , _code     = Just (LSP.StringValue $ T.pack $ ideaHint idea)
          , _source   = Just "hlint"
          , _message  = T.pack $ show idea
          , _relatedInformation = Nothing
          , _tags     = Nothing
        }

      parseErrorToDiagnostic :: ParseError -> Diagnostic
      parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
        LSP.Diagnostic {
            _range    = srcSpanToRange l
          , _severity = Just LSP.DsInfo
          , _code     = Just (LSP.StringValue "parser")
          , _source   = Just "hlint"
          , _message  = T.unlines [T.pack msg,T.pack contents]
          , _relatedInformation = Nothing
          , _tags     = Nothing
        }
      -- This one is defined in Development.IDE.GHC.Error but here
      -- the types could come from ghc-lib or ghc
      srcSpanToRange :: SrcSpan -> LSP.Range
      srcSpanToRange (RealSrcSpan span) = Range {
          _start = LSP.Position {
                _line = srcSpanStartLine span - 1
              , _character  = srcSpanStartCol span - 1}
        , _end   = LSP.Position {
                _line = srcSpanEndLine span - 1
             , _character = srcSpanEndCol span - 1}
        }
      srcSpanToRange (UnhelpfulSpan _) = noRange

getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas nfp = do
  logm $ "getIdeas:file:" ++ show nfp
  (flags, classify, hint) <- useNoFile_ GetHlintSettings

  let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx]
      applyHints' (Just (Left err)) = Left err
      applyHints' Nothing = Right []

  fmap applyHints' (moduleEx flags)

  where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
#ifndef GHC_LIB
        moduleEx _flags = do
          mbpm <- getParsedModule nfp
          case mbpm of
            Nothing -> return Nothing
            Just pm -> do
              let anns = pm_annotations pm
              let modu = pm_parsed_source pm
              return $ Just $ Right (createModuleEx anns modu)
#else
        moduleEx flags = do
          flags' <- setExtensions flags
          Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing)

        setExtensions flags = do
          hsc <- hscEnv <$> use_ GhcSession nfp
          let dflags = hsc_dflags hsc
          let hscExts = EnumSet.toList (extensionFlags dflags)
          logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts
          let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts
          logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts
          return $ flags { enabledExtensions = hlintExts }
#endif

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

data HlintUsage
  = HlintEnabled { cmdArgs :: [String] }
  | HlintDisabled
  deriving Show

data GetHlintSettings = GetHlintSettings
    deriving (Eq, Show, Typeable, Generic)
instance Hashable GetHlintSettings
instance NFData   GetHlintSettings
instance NFData Hint where rnf = rwhnf
instance NFData Classify where rnf = rwhnf
instance NFData ParseFlags where rnf = rwhnf
instance Show Hint where show = const "<hint>"
instance Show ParseFlags where show = const "<parseFlags>"
instance Binary GetHlintSettings

type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)

getHlintSettingsRule :: HlintUsage -> Rules ()
getHlintSettingsRule usage =
    defineNoFile $ \GetHlintSettings ->
      liftIO $ case usage of
          HlintEnabled cmdArgs -> argsSettings cmdArgs
          HlintDisabled -> fail "hlint configuration unspecified"

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

codeActionProvider :: CodeActionProvider
codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeAction) <$> hlintActions
  where

    hlintActions :: IO [LSP.CodeAction]
    hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)

    -- |Some hints do not have an associated refactoring
    validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) =
      code /= "Eta reduce"
    validCommand _ = False

    LSP.List diags = context ^. LSP.diagnostics

    mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction)
    mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _ _) =
      Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
     where
       codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
       title = "Apply hint:" <> head (T.lines m)
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
       args = [toJSON (AOP (docId ^. LSP.uri) start code)]
    mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing

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

applyAllCmd :: CommandFunction Uri
applyAllCmd _lf ide uri = do
  let file = maybe (error $ show uri ++ " is not a file.")
                    toNormalizedFilePath'
                   (uriToFilePath' uri)
  logm $ "applyAllCmd:file=" ++ show file
  res <- applyHint ide file Nothing
  logm $ "applyAllCmd:res=" ++ show res
  return $
    case res of
      Left err -> (Left (responseError (T.pack $ "applyAll: " ++ show err)), Nothing)
      Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs))

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

data ApplyOneParams = AOP
  { file      :: Uri
  , start_pos :: Position
  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
  , hintTitle :: HintTitle
  } deriving (Eq,Show,Generic,FromJSON,ToJSON)

type HintTitle = T.Text

data OneHint = OneHint
  { oneHintPos :: Position
  , oneHintTitle :: HintTitle
  } deriving (Eq, Show)

applyOneCmd :: CommandFunction ApplyOneParams
applyOneCmd _lf ide (AOP uri pos title) = do
  let oneHint = OneHint pos title
  let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath'
                   (uriToFilePath' uri)
  res <- applyHint ide file (Just oneHint)
  logm $ "applyOneCmd:file=" ++ show file
  logm $ "applyOneCmd:res=" ++ show res
  return $
    case res of
      Left err -> (Left (responseError (T.pack $ "applyOne: " ++ show err)), Nothing)
      Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs))

applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
applyHint ide nfp mhint =
  runExceptT $ do
    ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp
    let ideas' = maybe ideas (`filterIdeas` ideas) mhint
    let commands = map (show &&& ideaRefactoring) ideas'
    liftIO $ logm $ "applyHint:apply=" ++ show commands
    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint point to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    -- Example:
    -- Given an expression "hlintTest = reid $ (myid ())"
    -- Hlint returns an idea at the position (1,13)
    -- That contains "Redundant brackets" refactoring at position (1,20):
    --
    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
    --
    -- If we provide "applyRefactorings" with "Just (1,13)" then
    -- the "Redundant bracket" hint will never be executed
    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
    let fp = fromNormalizedFilePath nfp
    res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
              [ Handler $ \e -> return (Left (show (e :: IOException)))
              , Handler $ \e -> return (Left (show (e :: ErrorCall)))
              ]
    case res of
      Right appliedFile -> do
        let uri = fromNormalizedUri (filePathToUri' nfp)
        oldContent <- liftIO $ T.readFile fp
        liftIO $ logm $ "applyHint:oldContent=" ++ show oldContent
        liftIO $ logm $ "applyHint:appliedFile=" ++ show (T.pack appliedFile)
        let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions
        liftIO $ logm $ "applyHint:diff=" ++ show wsEdit
        ExceptT $ Right <$> (return wsEdit)
      Left err ->
        throwE (show err)
    where
          -- | If we are only interested in applying a particular hint then
          -- let's filter out all the irrelevant ideas
          filterIdeas :: OneHint -> [Idea] -> [Idea]
          filterIdeas (OneHint (Position l c) title) ideas =
            let title' = T.unpack title
                ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan
            in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas

          toRealSrcSpan (RealSrcSpan real) = real
          toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x

          showParseError :: Hlint.ParseError -> String
          showParseError (Hlint.ParseError location message content) =
            unlines [show location, message, content]

-- | Map over both failure and success.
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
  h (Left e)  = Left (f e)
  h (Right a) = Right (g a)
{-# INLINE bimapExceptT #-}
-- ---------------------------------------------------------------------
{-
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}
-- | apply-refact applies refactorings specified by the refact package. It is
-- currently integrated into hlint to enable the automatic application of
-- suggestions.
module Haskell.Ide.Engine.Plugin.ApplyRefact where

import           Control.Arrow
import           Control.Exception              ( IOException
                                                , ErrorCall
                                                , Handler(..)
                                                , catches
                                                , try
                                                )
import           Control.Lens            hiding ( List )
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except
import           Data.Aeson                        hiding (Error)
import           Data.Maybe

#if __GLASGOW_HASKELL__ < 808
import           Data.Monoid                       ((<>))
#endif

import qualified Data.Text                         as T
import           GHC.Generics
import           Haskell.Ide.Engine.MonadFunctions
import           Haskell.Ide.Engine.MonadTypes
import           Haskell.Ide.Engine.PluginUtils
import           Language.Haskell.Exts.SrcLoc
import           Language.Haskell.Exts.Parser
import           Language.Haskell.Exts.Extension
import           Language.Haskell.HLint4           as Hlint
import qualified Language.Haskell.LSP.Types        as LSP
import qualified Language.Haskell.LSP.Types.Lens   as LSP
import           Refact.Apply

-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}
{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------

type HintTitle = T.Text

applyRefactDescriptor :: PluginId -> PluginDescriptor
applyRefactDescriptor plId = PluginDescriptor
  { pluginId = plId
  , pluginName = "ApplyRefact"
  , pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
  , pluginCommands =
      [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
      , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
      ]
  , pluginCodeActionProvider = Just codeActionProvider
  , pluginDiagnosticProvider = Nothing
  , pluginHoverProvider = Nothing
  , pluginSymbolProvider = Nothing
  , pluginFormattingProvider = Nothing
  }

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

data ApplyOneParams = AOP
  { file      :: Uri
  , start_pos :: Position
  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
  , hintTitle :: HintTitle
  } deriving (Eq,Show,Generic,FromJSON,ToJSON)

data OneHint = OneHint
  { oneHintPos :: Position
  , oneHintTitle :: HintTitle
  } deriving (Eq, Show)

applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
  let oneHint = OneHint pos title
  revMapp <- reverseFileMap
  let defaultResult = do
        debugm "applyOne: no access to the persisted file."
        return $ IdeResultOk mempty
  withMappedFile fp defaultResult $ \file' -> do
    res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
    logm $ "applyOneCmd:file=" ++ show fp
    logm $ "applyOneCmd:res=" ++ show res
    case res of
      Left err -> return $ IdeResultFail
        (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
      Right fs -> return (IdeResultOk fs)


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

applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
  let defaultResult = do
        debugm "applyAll: no access to the persisted file."
        return $ IdeResultOk mempty
  revMapp <- reverseFileMap
  withMappedFile fp defaultResult $ \file' -> do
    res <- liftToGhc $ applyHint file' Nothing revMapp
    logm $ "applyAllCmd:res=" ++ show res
    case res of
      Left err -> return $ IdeResultFail (IdeError PluginError
                    (T.pack $ "applyAll: " ++ show err) Null)
      Right fs -> return (IdeResultOk fs)

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

-- AZ:TODO: Why is this in IdeGhcM?
lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lint uri = pluginGetFile "lint: " uri $ \fp -> do
  let
    defaultResult = do
      debugm "lint: no access to the persisted file."
      return
        $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
  withMappedFile fp defaultResult $ \file' -> do
    eitherErrorResult <- liftIO
      (try $ runExceptT $ runLint file' [] :: IO
          (Either IOException (Either [Diagnostic] [Idea]))
      )
    case eitherErrorResult of
      Left err -> return $ IdeResultFail
        (IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
      Right res -> case res of
        Left diags ->
          return
            (IdeResultOk
              (PublishDiagnosticsParams (filePathToUri fp) $ List diags)
            )
        Right fs ->
          return
            $ IdeResultOk
            $ PublishDiagnosticsParams (filePathToUri fp)
            $ List (map hintToDiagnostic $ stripIgnores fs)

runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLint fp args = do
  (flags,classify,hint) <- liftIO $ argsSettings args
  let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
  res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
  pure $ applyHints classify hint [res]

parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
  [Diagnostic
      { _range    = srcLoc2Range l
      , _severity = Just DsInfo -- Not displayed
      , _code     = Just (LSP.StringValue "parser")
      , _source   = Just "hlint"
      , _message  = T.unlines [T.pack msg,T.pack contents]
      , _relatedInformation = Nothing
      }]

{-
-- | An idea suggest by a 'Hint'.
data Idea = Idea
    {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
    ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
    ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
    ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
    ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
    ,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
    ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
    ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
    ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
    }
    deriving (Eq,Ord)

-}

-- | Map over both failure and success.
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
  h (Left e)  = Left (f e)
  h (Right a) = Right (g a)
{-# INLINE bimapExceptT #-}

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

stripIgnores :: [Idea] -> [Idea]
stripIgnores ideas = filter notIgnored ideas
  where
    notIgnored idea = ideaSeverity idea /= Ignore

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

hintToDiagnostic :: Idea -> Diagnostic
hintToDiagnostic idea
  = Diagnostic
      { _range    = ss2Range (ideaSpan idea)
      , _severity = Just (hintSeverityMap $ ideaSeverity idea)
      , _code     = Just (LSP.StringValue $ T.pack $ ideaHint idea)
      , _source   = Just "hlint"
      , _message  = idea2Message idea
      , _relatedInformation = Nothing
      }

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

idea2Message :: Idea -> T.Text
idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", "  " <> T.pack (ideaFrom idea)]
                               <> toIdea <> map (T.pack . show) (ideaNote idea)
  where
    toIdea :: [T.Text]
    toIdea = case ideaTo idea of
      Nothing -> []
      Just i  -> [T.pack "Why not:", T.pack $ "  " ++ i]

-- ---------------------------------------------------------------------
-- | Maps hlint severities to LSP severities
-- | We want to lower the severities so HLint errors and warnings
-- | don't mix with GHC errors and warnings:
-- | as per https://github.com/haskell/haskell-ide-engine/issues/375
hintSeverityMap :: Severity -> DiagnosticSeverity
hintSeverityMap Ignore     = DsInfo -- cannot really happen after stripIgnores
hintSeverityMap Suggestion = DsHint
hintSeverityMap Warning    = DsInfo
hintSeverityMap Error      = DsInfo

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

srcLoc2Range :: SrcLoc -> Range
srcLoc2Range (SrcLoc _ l c) = Range ps pe
  where
    ps = Position (l-1) (c-1)
    pe = Position (l-1) 100000

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

ss2Range :: SrcSpan -> Range
ss2Range ss = Range ps pe
  where
    ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)
    pe = Position (srcSpanEndLine ss - 1)   (srcSpanEndColumn ss - 1)

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

applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)
applyHint fp mhint fileMap = do
  runExceptT $ do
    ideas <- getIdeas fp mhint
    let commands = map (show &&& ideaRefactoring) ideas
    liftIO $ logm $ "applyHint:apply=" ++ show commands
    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint pont to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    -- Example:
    -- Given an expression "hlintTest = reid $ (myid ())"
    -- Hlint returns an idea at the position (1,13)
    -- That contains "Redundant brackets" refactoring at position (1,20):
    --
    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
    --
    -- If we provide "applyRefactorings" with "Just (1,13)" then
    -- the "Redundant bracket" hint will never be executed
    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
    res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
              [ Handler $ \e -> return (Left (show (e :: IOException)))
              , Handler $ \e -> return (Left (show (e :: ErrorCall)))
              ]
    case res of
      Right appliedFile -> do
        diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
        liftIO $ logm $ "applyHint:diff=" ++ show diff
        return diff
      Left err ->
        throwE (show err)

-- | Gets HLint ideas for
getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]
getIdeas lintFile mhint = do
  let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
  ideas <- runHlint lintFile hOpts
  pure $ maybe ideas (`filterIdeas` ideas) mhint

-- | If we are only interested in applying a particular hint then
-- let's filter out all the irrelevant ideas
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position l c) title) ideas =
  let
    title' = T.unpack title
    ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan
  in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas

hlintOpts :: FilePath -> Maybe Position -> [String]
hlintOpts lintFile mpos =
  let
    posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
    opts = maybe "" posOpt mpos
  in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]

runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]
runHlint fp args =
  do (flags,classify,hint) <- liftIO $ argsSettings args
     let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
     res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing
     pure $ applyHints classify hint [res]

showParseError :: Hlint.ParseError -> String
showParseError (Hlint.ParseError location message content) =
  unlines [show location, message, content]

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

codeActionProvider :: CodeActionProvider
codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions
  where

    hlintActions :: IdeM [LSP.CodeAction]
    hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)

    -- |Some hints do not have an associated refactoring
    validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =
      case code of
        "Eta reduce" -> False
        _            -> True
    validCommand _ = False

    LSP.List diags = context ^. LSP.diagnostics

    mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)
    mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =
      Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
     where
       codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
       title = "Apply hint:" <> head (T.lines m)
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
       args = [toJSON (AOP (docId ^. LSP.uri) start code)]
    mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing
-}

Hlint.refactored.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}


{-# LANGUAGE TypeFamilies      #-}

{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}


{-# LANGUAGE TypeFamilies      #-}
modulemoduleIde.Plugin.HlintIde.Plugin.Hlint
  ((
    descriptor
  --, provider
  --, provider
))wherewhere
importimport Refact.ApplyRefact.Apply
importimport Control.ArrowControl.Arrow ((((&&&&&&))))
importimport Control.DeepSeqControl.DeepSeq
importimport Control.ExceptionControl.Exception
importimport Control.LensControl.Lens ((((^.^.))))
importimport Control.MonadControl.Monad
importimport Control.Monad.IO.ClassControl.Monad.IO.Class
importimport Control.Monad.Trans.ExceptControl.Monad.Trans.Except
importimport Data.Aeson.TypesData.Aeson.Types ((ToJSONToJSON((....)),, FromJSONFromJSON((....)),, ValueValue((....))))
importimport Data.BinaryData.Binary
importimportqualifiedqualified Data.HashSetData.HashSetasas HashSetHashSet
importimport Data.HashableData.Hashable
importimport Data.MaybeData.Maybe
importimportqualifiedqualified Data.TextData.Textasas TT
importimportqualifiedqualified Data.Text.IOData.Text.IOasas TT
importimport Data.TypeableData.Typeable
importimport Development.IDE.Core.OfInterestDevelopment.IDE.Core.OfInterest
importimport Development.IDE.Core.RulesDevelopment.IDE.Core.Rules
importimport Development.IDE.Core.ShakeDevelopment.IDE.Core.Shake
importimport Development.IDE.Types.DiagnosticsDevelopment.IDE.Types.Diagnosticsasas DD
importimport Development.IDE.Types.LocationDevelopment.IDE.Types.Location
importimport Development.Shake
-- import Development.Shake hiding ( Diagnostic )
-- import Development.Shake hiding ( Diagnostic )

importimport GHCGHC hidinghiding((DynFlagsDynFlags((....))))

#ifndef GHC_LIB

importimport GHCGHC ((DynFlagsDynFlags((....))))
importimport HscTypesHscTypes ((hsc_dflagshsc_dflags))
#else

import RealGHC (DynFlags(..))
import RealGHC.HscTypes (hsc_dflags)
import qualified RealGHC.EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
#endif


importimport Ide.LoggerIde.Logger
importimport Ide.TypesIde.Types
importimport Ide.PluginIde.Plugin
importimport Ide.PluginUtilsIde.PluginUtils
importimport Language.Haskell.HLintLanguage.Haskell.HLintasas HlintHlint
importimport Language.Haskell.LSP.TypesLanguage.Haskell.LSP.Types
importimportqualifiedqualified Language.Haskell.LSP.TypesLanguage.Haskell.LSP.Typesasas LSPLSP
importimportqualifiedqualified Language.Haskell.LSP.Types.LensLanguage.Haskell.LSP.Types.Lensasas LSPLSP
importimport Text.Regex.TDFA.TextText.Regex.TDFA.Text(())
importimport GHC.GenericsGHC.Generics ((GenericGeneric)

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

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


descriptordescriptor:::: PluginIdPluginId->-> PluginDescriptorPluginDescriptor
descriptordescriptor plIdplId== ((defaultPluginDescriptordefaultPluginDescriptor plIdplId))
  {{ pluginRulespluginRules== rulesrules
  ,, pluginCommandspluginCommands==
      [[ PluginCommandPluginCommand "applyOne""applyOne" "Apply a single hint""Apply a single hint" applyOneCmdapplyOneCmd
      ,, PluginCommandPluginCommand "applyAll""applyAll" "Apply all hints to the file""Apply all hints to the file" applyAllCmdapplyAllCmd
      ]]
    ,, pluginCodeActionProviderpluginCodeActionProvider== JustJust codeActionProvidercodeActionProvider
  }}

datadata GetHlintDiagnosticsGetHlintDiagnostics== GetHlintDiagnosticsGetHlintDiagnostics
    derivingderiving ((EqEq,, ShowShow,, TypeableTypeable,, GenericGeneric))
instanceinstance HashableHashable GetHlintDiagnosticsGetHlintDiagnostics
instanceinstance NFDataNFData   GetHlintDiagnosticsGetHlintDiagnostics
instanceinstance BinaryBinary   GetHlintDiagnosticsGetHlintDiagnostics

typetypeinstanceinstance RuleResultRuleResult GetHlintDiagnosticsGetHlintDiagnostics== (())

rulesrules:::: RulesRules (())
rulesrules== dodo
  definedefine $$ \\GetHlintDiagnosticsGetHlintDiagnostics filefile->-> dodo
    ideasideas<-<- getIdeasgetIdeas filefile
    returnreturn $$ ((diagnosticsdiagnostics filefile ideasideas,, JustJust (())))

  getHlintSettingsRulegetHlintSettingsRule ((HlintEnabledHlintEnabled [[]]))

  actionaction $$ dodo
    filesfiles<-<- getFilesOfInterestgetFilesOfInterest
    voidvoid $$ usesuses GetHlintDiagnosticsGetHlintDiagnostics $$ HashSet.toListHashSet.toList filesfiles

  wherewhere

      diagnosticsdiagnostics:::: NormalizedFilePathNormalizedFilePath->-> EitherEither ParseErrorParseError [[IdeaIdea]]->-> [[FileDiagnosticFileDiagnostic]]
      diagnosticsdiagnostics filefile ((RightRight ideasideas))==
        [[((filefile,, ShowDiagShowDiag,, ideaToDiagnosticideaToDiagnostic ii))|| ii<-<- ideasideas,, ideaSeverityideaSeverity ii /=/= IgnoreIgnore]]
      diagnosticsdiagnostics filefile ((LeftLeft parseErrparseErr))==
        [[((filefile,, ShowDiagShowDiag,, parseErrorToDiagnosticparseErrorToDiagnostic parseErrparseErr))]]

      ideaToDiagnosticideaToDiagnostic:::: IdeaIdea->-> DiagnosticDiagnostic
      ideaToDiagnosticideaToDiagnostic ideaidea==
        LSP.DiagnosticLSP.Diagnostic{{
            _range_range== srcSpanToRangesrcSpanToRange $$ ideaSpanideaSpan ideaidea
          ,, _severity_severity== JustJust LSP.DsInfoLSP.DsInfo
          ,, _code_code== JustJust ((LSP.StringValueLSP.StringValue $$ T.packT.pack $$ ideaHintideaHint ideaidea))
          ,, _source_source== JustJust "hlint""hlint"
          ,, _message_message== T.packT.pack $$ showshow ideaidea
          ,, _relatedInformation_relatedInformation== NothingNothing
          ,, _tags_tags== NothingNothing
        }}

      parseErrorToDiagnosticparseErrorToDiagnostic:::: ParseErrorParseError->-> DiagnosticDiagnostic
      parseErrorToDiagnosticparseErrorToDiagnostic ((Hlint.ParseErrorHlint.ParseError ll msgmsg contentscontents))==
        LSP.DiagnosticLSP.Diagnostic{{
            _range_range== srcSpanToRangesrcSpanToRange ll
          ,, _severity_severity== JustJust LSP.DsInfoLSP.DsInfo
          ,, _code_code== JustJust ((LSP.StringValueLSP.StringValue "parser""parser"))
          ,, _source_source== JustJust "hlint""hlint"
          ,, _message_message== T.unlinesT.unlines [[T.packT.pack msgmsg,,T.packT.pack contentscontents]]
          ,, _relatedInformation_relatedInformation== NothingNothing
          ,, _tags_tags== NothingNothing
        }
      -- This one is defined in Development.IDE.GHC.Error but here
      -- the types could come from ghc-lib or ghc
      -- This one is defined in Development.IDE.GHC.Error but here

      -- the types could come from ghc-lib or ghc

      srcSpanToRangesrcSpanToRange:::: SrcSpanSrcSpan->-> LSP.RangeLSP.Range
      srcSpanToRangesrcSpanToRange ((RealSrcSpanRealSrcSpan spanspan))== RangeRange{{
          _start_start== LSP.PositionLSP.Position{{
                _line_line== srcSpanStartLinesrcSpanStartLine spanspan -- 11
              ,, _character_character== srcSpanStartColsrcSpanStartCol spanspan -- 11}}
        ,, _end_end== LSP.PositionLSP.Position{{
                _line_line== srcSpanEndLinesrcSpanEndLine spanspan -- 11
             ,, _character_character== srcSpanEndColsrcSpanEndCol spanspan -- 11}}
        }}
      srcSpanToRangesrcSpanToRange ((UnhelpfulSpanUnhelpfulSpan __))== noRangenoRange

getIdeasgetIdeas:::: NormalizedFilePathNormalizedFilePath->-> ActionAction ((EitherEither ParseErrorParseError [[IdeaIdea]]))
getIdeasgetIdeas nfpnfp== dodo
  logmlogm $$ "getIdeas:file:""getIdeas:file:" ++++ showshow nfpnfp
  ((flagsflags,, classifyclassify,, hinthint))<-<- useNoFile_useNoFile_ GetHlintSettingsGetHlintSettings

  letlet applyHints'applyHints' ((JustJust ((RightRight modExmodEx))))== RightRight $$ applyHintsapplyHints classifyclassify hinthint [[modExmodEx]]
         applyHints'applyHints' ((JustJust ((LeftLeft errerr))))== LeftLeft errerr
         applyHints'applyHints' NothingNothing== RightRight [[]]

  fmapfmap applyHints'applyHints' ((moduleExmoduleEx flagsflags))

  wherewhere moduleExmoduleEx:::: ParseFlagsParseFlags->-> ActionAction ((MaybeMaybe ((EitherEither ParseErrorParseError ModuleExModuleEx))))
     #ifndef GHC_LIB

             moduleExmoduleEx _flags_flags== dodo
               mbpmmbpm<-<- getParsedModulegetParsedModule nfpnfp
               casecase mbpmmbpmofof
                 NothingNothing ->-> returnreturn NothingNothing
                 JustJust pmpm ->-> dodo
                   letlet annsanns== pm_annotationspm_annotations pmpm
                   letlet modumodu== pm_parsed_sourcepm_parsed_source pmpm
                   returnreturn $$ JustJust $$ RightRight ((createModuleExcreateModuleEx annsanns modumodu)















-- ---------------------------------------------------------------------
#else

        moduleEx flags = do
          flags' <- setExtensions flags
          Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing)

        setExtensions flags = do
          hsc <- hscEnv <$> use_ GhcSession nfp
          let dflags = hsc_dflags hsc
          let hscExts = EnumSet.toList (extensionFlags dflags)
          logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts
          let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts
          logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts
          return $ flags { enabledExtensions = hlintExts }
#endif


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


datadata HlintUsageHlintUsage
  == HlintEnabledHlintEnabled {{ cmdArgscmdArgs:::: [[StringString]]}}
   || HlintDisabledHlintDisabled
  derivingderiving ShowShow

datadata GetHlintSettingsGetHlintSettings== GetHlintSettingsGetHlintSettings
    derivingderiving ((EqEq,, ShowShow,, TypeableTypeable,, GenericGeneric))
instanceinstance HashableHashable GetHlintSettingsGetHlintSettings
instanceinstance NFDataNFData   GetHlintSettingsGetHlintSettings
instanceinstance NFDataNFData HintHintwherewhere rnfrnf== rwhnfrwhnf
instanceinstance NFDataNFData ClassifyClassifywherewhere rnfrnf== rwhnfrwhnf
instanceinstance NFDataNFData ParseFlagsParseFlagswherewhere rnfrnf== rwhnfrwhnf
instanceinstance ShowShow HintHintwherewhere showshow== constconst "<hint>""<hint>"
instanceinstance ShowShow ParseFlagsParseFlagswherewhere showshow== constconst "<parseFlags>""<parseFlags>"
instanceinstance BinaryBinary GetHlintSettingsGetHlintSettings

typetypeinstanceinstance RuleResultRuleResult GetHlintSettingsGetHlintSettings== ((ParseFlagsParseFlags,, [[ClassifyClassify]],, HintHint))

getHlintSettingsRulegetHlintSettingsRule:::: HlintUsageHlintUsage->-> RulesRules (())
getHlintSettingsRulegetHlintSettingsRule usageusage==
    defineNoFiledefineNoFile $$ \\GetHlintSettingsGetHlintSettings->->
      liftIOliftIO $$ casecase usageusageofof
                 HlintEnabledHlintEnabled cmdArgscmdArgs ->-> argsSettingsargsSettings cmdArgscmdArgs
                 HlintDisabledHlintDisabled ->-> failfail "hlint configuration unspecified"

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

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


codeActionProvidercodeActionProvider:::: CodeActionProviderCodeActionProvider
codeActionProvidercodeActionProvider __ __ plIdplId docIddocId __ contextcontext== ((RightRight .. LSP.ListLSP.List .. mapmap CACodeActionCACodeAction)) <$><$> hlintActionshlintActions
  wherewhere

    hlintActionshlintActions:::: IOIO [[LSP.CodeActionLSP.CodeAction]]
    hlintActionshlintActions== catMaybescatMaybes <$><$> mapMmapM mkHlintActionmkHlintAction ((filterfilter validCommandvalidCommand diagsdiags)

    -- |Some hints do not have an associated refactoring

    -- |Some hints do not have an associated refactoring

    validCommandvalidCommand ((LSP.DiagnosticLSP.Diagnostic __ __ ((JustJust ((LSP.StringValueLSP.StringValue codecode)))) ((JustJust "hlint""hlint")) __ __ __))==
      codecode /=/= "Eta reduce""Eta reduce"
    validCommandvalidCommand __== FalseFalse

    LSP.ListLSP.List diagsdiags== contextcontext ^.^. LSP.diagnosticsLSP.diagnostics

    mkHlintActionmkHlintAction:::: LSP.DiagnosticLSP.Diagnostic->-> IOIO ((MaybeMaybe LSP.CodeActionLSP.CodeAction))
    mkHlintActionmkHlintAction diagdiag@@((LSP.DiagnosticLSP.Diagnostic ((LSP.RangeLSP.Range startstart __)) _s_s ((JustJust ((LSP.StringValueLSP.StringValue codecode)))) ((JustJust "hlint""hlint")) mm __ __))==
      JustJust .. codeActioncodeAction <$><$> mkLspCommandmkLspCommand plIdplId "applyOne""applyOne" titletitle ((JustJust argsargs))
     wherewhere
       codeActioncodeAction cmdcmd== LSP.CodeActionLSP.CodeAction titletitle ((JustJust LSP.CodeActionQuickFixLSP.CodeActionQuickFix)) ((JustJust ((LSP.ListLSP.List [[diagdiag]])))) NothingNothing ((JustJust cmdcmd))
       titletitle== "Apply hint:""Apply hint:" <><> headhead ((T.linesT.lines mm)
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)

       argsargs== [[toJSONtoJSON ((AOPAOP ((docIddocId ^.^. LSP.uriLSP.uri)) startstart codecode))]]
    mkHlintActionmkHlintAction ((LSP.DiagnosticLSP.Diagnostic _r_r _s_s _c_c _source_source _m_m __ __))== returnreturn Nothing

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

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


applyAllCmdapplyAllCmd:::: CommandFunctionCommandFunction UriUri
applyAllCmdapplyAllCmd _lf_lf ideide uriuri== dodo
  letlet filefile== maybemaybe ((errorerror $$ showshow uriuri ++++ " is not a file."" is not a file."))
                       toNormalizedFilePath'toNormalizedFilePath'
                      ((uriToFilePath'uriToFilePath' uriuri))
  logmlogm $$ "applyAllCmd:file=""applyAllCmd:file=" ++++ showshow filefile
  resres<-<- applyHintapplyHint ideide filefile NothingNothing
  logmlogm $$ "applyAllCmd:res=""applyAllCmd:res=" ++++ showshow resres
  returnreturn $$
    casecase resresofof
      LeftLeft errerr ->-> ((LeftLeft ((responseErrorresponseError ((T.packT.pack $$ "applyAll: ""applyAll: " ++++ showshow errerr)))),, NothingNothing))
      RightRight fsfs ->-> ((RightRight NullNull,, JustJust ((WorkspaceApplyEditWorkspaceApplyEdit,, ApplyWorkspaceEditParamsApplyWorkspaceEditParams fsfs)))

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

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


datadata ApplyOneParamsApplyOneParams== AOPAOP
                    {{ filefile  :::: UriUri
                    ,, start_posstart_pos:::: Position
                    -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
                    -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
,, hintTitlehintTitle:::: HintTitleHintTitle
                    }} derivingderiving ((EqEq,,ShowShow,,GenericGeneric,,FromJSONFromJSON,,ToJSONToJSON))

typetype HintTitleHintTitle== T.TextT.Text

datadata OneHintOneHint== OneHintOneHint
             {{ oneHintPosoneHintPos:::: PositionPosition
             ,, oneHintTitleoneHintTitle:::: HintTitleHintTitle
             }} derivingderiving ((EqEq,, ShowShow))

applyOneCmdapplyOneCmd:::: CommandFunctionCommandFunction ApplyOneParamsApplyOneParams
applyOneCmdapplyOneCmd _lf_lf ideide ((AOPAOP uriuri pospos titletitle))== dodo
  letlet oneHintoneHint== OneHintOneHint pospos titletitle
  letlet filefile== maybemaybe ((errorerror $$ showshow uriuri ++++ " is not a file."" is not a file.")) toNormalizedFilePath'toNormalizedFilePath'
                      ((uriToFilePath'uriToFilePath' uriuri))
  resres<-<- applyHintapplyHint ideide filefile ((JustJust oneHintoneHint))
  logmlogm $$ "applyOneCmd:file=""applyOneCmd:file=" ++++ showshow filefile
  logmlogm $$ "applyOneCmd:res=""applyOneCmd:res=" ++++ showshow resres
  returnreturn $$
    casecase resresofof
      LeftLeft errerr ->-> ((LeftLeft ((responseErrorresponseError ((T.packT.pack $$ "applyOne: ""applyOne: " ++++ showshow errerr)))),, NothingNothing))
      RightRight fsfs ->-> ((RightRight NullNull,, JustJust ((WorkspaceApplyEditWorkspaceApplyEdit,, ApplyWorkspaceEditParamsApplyWorkspaceEditParams fsfs))))

applyHintapplyHint:::: IdeStateIdeState->-> NormalizedFilePathNormalizedFilePath->-> MaybeMaybe OneHintOneHint->-> IOIO ((EitherEither StringString WorkspaceEditWorkspaceEdit))
applyHintapplyHint ideide nfpnfp mhintmhint==
  runExceptTrunExceptT $$ dodo
    ideasideas<-<- bimapExceptTbimapExceptT showParseErrorshowParseError idid $$ ExceptTExceptT $$ liftIOliftIO $$ runActionrunAction "applyHint""applyHint" ideide $$ getIdeasgetIdeas nfpnfp
    letlet ideas'ideas'== maybemaybe ideasideas ((``filterIdeasfilterIdeas`` ideasideas)) mhintmhint
    letlet commandscommands== mapmap ((showshow &&&&&& ideaRefactoringideaRefactoring)) ideas'ideas'
    liftIOliftIO $$ logmlogm $$ "applyHint:apply=""applyHint:apply=" ++++ showshow commands
    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint point to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    -- Example:
    -- Given an expression "hlintTest = reid $ (myid ())"
    -- Hlint returns an idea at the position (1,13)
    -- That contains "Redundant brackets" refactoring at position (1,20):
    --
    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
    --
    -- If we provide "applyRefactorings" with "Just (1,13)" then
    -- the "Redundant bracket" hint will never be executed
    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
    -- set Nothing as "position" for "applyRefactorings" because

    -- applyRefactorings expects the provided position to be _within_ the scope

    -- of each refactoring it will apply.

    -- But "Idea"s returned by HLint point to starting position of the expressions

    -- that contain refactorings, so they are often outside the refactorings' boundaries.

    -- Example:

    -- Given an expression "hlintTest = reid $ (myid ())"

    -- Hlint returns an idea at the position (1,13)

    -- That contains "Redundant brackets" refactoring at position (1,20):

    --

    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]

    --

    -- If we provide "applyRefactorings" with "Just (1,13)" then

    -- the "Redundant bracket" hint will never be executed

    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).

    letlet fpfp== fromNormalizedFilePathfromNormalizedFilePath nfpnfp
    resres<-<- liftIOliftIO $$ ((RightRight <$><$> applyRefactoringsapplyRefactorings NothingNothing commandscommands fpfp)) ``catchescatches``
              [[ HandlerHandler $$ \\ee->-> returnreturn ((LeftLeft ((showshow ((ee:::: IOExceptionIOException))))))
              ,, HandlerHandler $$ \\ee->-> returnreturn ((LeftLeft ((showshow ((ee:::: ErrorCallErrorCall))))))
              ]]
    casecase resresofof
      RightRight appliedFileappliedFile ->-> dodo
        letlet uriuri== fromNormalizedUrifromNormalizedUri ((filePathToUri'filePathToUri' nfpnfp))
        oldContentoldContent<-<- liftIOliftIO $$ T.readFileT.readFile fpfp
        liftIOliftIO $$ logmlogm $$ "applyHint:oldContent=""applyHint:oldContent=" ++++ showshow oldContentoldContent
        liftIOliftIO $$ logmlogm $$ "applyHint:appliedFile=""applyHint:appliedFile=" ++++ showshow ((T.packT.pack appliedFileappliedFile))
        letlet wsEditwsEdit== diffText'diffText' TrueTrue ((uriuri,, oldContentoldContent)) ((T.packT.pack appliedFileappliedFile)) IncludeDeletionsIncludeDeletions
        liftIOliftIO $$ logmlogm $$ "applyHint:diff=""applyHint:diff=" ++++ showshow wsEditwsEdit
        ExceptTExceptT $$ RightRight <$><$> ((returnreturn wsEditwsEdit))
      LeftLeft errerr ->->
        throwEthrowE ((showshow errerr))
    where
          -- | If we are only interested in applying a particular hint then
          -- let's filter out all the irrelevant ideas
          -- | If we are only interested in applying a particular hint then

          -- let's filter out all the irrelevant ideas

          filterIdeasfilterIdeas:::: OneHintOneHint->-> [[IdeaIdea]]->-> [[IdeaIdea]]
          filterIdeasfilterIdeas ((OneHintOneHint ((PositionPosition ll cc)) titletitle)) ideasideas==
            letlet title'title'== T.unpackT.unpack titletitle
                   ideaPosideaPos== ((srcSpanStartLinesrcSpanStartLine &&&&&& srcSpanStartColsrcSpanStartCol)) .. toRealSrcSpantoRealSrcSpan .. ideaSpanideaSpan
            inin filterfilter ((\\ii->-> ideaHintideaHint ii ==== title'title' &&&& ideaPosideaPos ii ==== ((ll++11,, cc++11)))) ideasideas

          toRealSrcSpantoRealSrcSpan ((RealSrcSpanRealSrcSpan realreal))== realreal
          toRealSrcSpantoRealSrcSpan ((UnhelpfulSpanUnhelpfulSpan xx))== errorerror $$ "No real source span: ""No real source span: " ++++ showshow xx

          showParseErrorshowParseError:::: Hlint.ParseErrorHlint.ParseError->-> StringString
          showParseErrorshowParseError ((Hlint.ParseErrorHlint.ParseError locationlocation messagemessage contentcontent))==
            unlinesunlines [[showshow locationlocation,, messagemessage,, contentcontent]

-- | Map over both failure and success.

-- | Map over both failure and success.

bimapExceptTbimapExceptT:::: FunctorFunctor mm=>=> ((ee->-> ff))->-> ((aa->-> bb))->-> ExceptTExceptT ee mm aa->-> ExceptTExceptT ff mm bb
bimapExceptTbimapExceptT ff gg ((ExceptTExceptT mm))== ExceptTExceptT ((fmapfmap hh mm))wherewhere
  hh ((LeftLeft ee)) == LeftLeft ((ff ee))
  hh ((RightRight aa))== RightRight ((gg aa))
{-# INLINE{-# INLINE bimapExceptTbimapExceptT#-}
-- ---------------------------------------------------------------------
{-
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}
-- | apply-refact applies refactorings specified by the refact package. It is
-- currently integrated into hlint to enable the automatic application of
-- suggestions.
module Haskell.Ide.Engine.Plugin.ApplyRefact where

import           Control.Arrow
import           Control.Exception              ( IOException
                                                , ErrorCall
                                                , Handler(..)
                                                , catches
                                                , try
                                                )
import           Control.Lens            hiding ( List )
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except
import           Data.Aeson                        hiding (Error)
import           Data.Maybe





import qualified Data.Text                         as T
import           GHC.Generics
import           Haskell.Ide.Engine.MonadFunctions
import           Haskell.Ide.Engine.MonadTypes
import           Haskell.Ide.Engine.PluginUtils
import           Language.Haskell.Exts.SrcLoc
import           Language.Haskell.Exts.Parser
import           Language.Haskell.Exts.Extension
import           Language.Haskell.HLint4           as Hlint
import qualified Language.Haskell.LSP.Types        as LSP
import qualified Language.Haskell.LSP.Types.Lens   as LSP
import           Refact.Apply

-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}
{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------

type HintTitle = T.Text

applyRefactDescriptor :: PluginId -> PluginDescriptor
applyRefactDescriptor plId = PluginDescriptor
  { pluginId = plId
  , pluginName = "ApplyRefact"
  , pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
  , pluginCommands =
      [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
      , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
      ]
  , pluginCodeActionProvider = Just codeActionProvider
  , pluginDiagnosticProvider = Nothing
  , pluginHoverProvider = Nothing
  , pluginSymbolProvider = Nothing
  , pluginFormattingProvider = Nothing
  }

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

data ApplyOneParams = AOP
  { file      :: Uri
  , start_pos :: Position
  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
  , hintTitle :: HintTitle
  } deriving (Eq,Show,Generic,FromJSON,ToJSON)

data OneHint = OneHint
  { oneHintPos :: Position
  , oneHintTitle :: HintTitle
  } deriving (Eq, Show)

applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
  let oneHint = OneHint pos title
  revMapp <- reverseFileMap
  let defaultResult = do
        debugm "applyOne: no access to the persisted file."
        return $ IdeResultOk mempty
  withMappedFile fp defaultResult $ \file' -> do
    res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
    logm $ "applyOneCmd:file=" ++ show fp
    logm $ "applyOneCmd:res=" ++ show res
    case res of
      Left err -> return $ IdeResultFail
        (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
      Right fs -> return (IdeResultOk fs)


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

applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
  let defaultResult = do
        debugm "applyAll: no access to the persisted file."
        return $ IdeResultOk mempty
  revMapp <- reverseFileMap
  withMappedFile fp defaultResult $ \file' -> do
    res <- liftToGhc $ applyHint file' Nothing revMapp
    logm $ "applyAllCmd:res=" ++ show res
    case res of
      Left err -> return $ IdeResultFail (IdeError PluginError
                    (T.pack $ "applyAll: " ++ show err) Null)
      Right fs -> return (IdeResultOk fs)

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

-- AZ:TODO: Why is this in IdeGhcM?
lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lint uri = pluginGetFile "lint: " uri $ \fp -> do
  let
    defaultResult = do
      debugm "lint: no access to the persisted file."
      return
        $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
  withMappedFile fp defaultResult $ \file' -> do
    eitherErrorResult <- liftIO
      (try $ runExceptT $ runLint file' [] :: IO
          (Either IOException (Either [Diagnostic] [Idea]))
      )
    case eitherErrorResult of
      Left err -> return $ IdeResultFail
        (IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
      Right res -> case res of
        Left diags ->
          return
            (IdeResultOk
              (PublishDiagnosticsParams (filePathToUri fp) $ List diags)
            )
        Right fs ->
          return
            $ IdeResultOk
            $ PublishDiagnosticsParams (filePathToUri fp)
            $ List (map hintToDiagnostic $ stripIgnores fs)

runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLint fp args = do
  (flags,classify,hint) <- liftIO $ argsSettings args
  let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
  res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
  pure $ applyHints classify hint [res]

parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
  [Diagnostic
      { _range    = srcLoc2Range l
      , _severity = Just DsInfo -- Not displayed
      , _code     = Just (LSP.StringValue "parser")
      , _source   = Just "hlint"
      , _message  = T.unlines [T.pack msg,T.pack contents]
      , _relatedInformation = Nothing
      }]

{-
-- | An idea suggest by a 'Hint'.
data Idea = Idea
    {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
    ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
    ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
    ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
    ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
    ,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
    ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
    ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
    ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
    }
    deriving (Eq,Ord)

-}

-- | Map over both failure and success.
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
  h (Left e)  = Left (f e)
  h (Right a) = Right (g a)
{-# INLINE bimapExceptT #-}

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

stripIgnores :: [Idea] -> [Idea]
stripIgnores ideas = filter notIgnored ideas
  where
    notIgnored idea = ideaSeverity idea /= Ignore

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

hintToDiagnostic :: Idea -> Diagnostic
hintToDiagnostic idea
  = Diagnostic
      { _range    = ss2Range (ideaSpan idea)
      , _severity = Just (hintSeverityMap $ ideaSeverity idea)
      , _code     = Just (LSP.StringValue $ T.pack $ ideaHint idea)
      , _source   = Just "hlint"
      , _message  = idea2Message idea
      , _relatedInformation = Nothing
      }

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

idea2Message :: Idea -> T.Text
idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", "  " <> T.pack (ideaFrom idea)]
                               <> toIdea <> map (T.pack . show) (ideaNote idea)
  where
    toIdea :: [T.Text]
    toIdea = case ideaTo idea of
      Nothing -> []
      Just i  -> [T.pack "Why not:", T.pack $ "  " ++ i]

-- ---------------------------------------------------------------------
-- | Maps hlint severities to LSP severities
-- | We want to lower the severities so HLint errors and warnings
-- | don't mix with GHC errors and warnings:
-- | as per https://github.com/haskell/haskell-ide-engine/issues/375
hintSeverityMap :: Severity -> DiagnosticSeverity
hintSeverityMap Ignore     = DsInfo -- cannot really happen after stripIgnores
hintSeverityMap Suggestion = DsHint
hintSeverityMap Warning    = DsInfo
hintSeverityMap Error      = DsInfo

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

srcLoc2Range :: SrcLoc -> Range
srcLoc2Range (SrcLoc _ l c) = Range ps pe
  where
    ps = Position (l-1) (c-1)
    pe = Position (l-1) 100000

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

ss2Range :: SrcSpan -> Range
ss2Range ss = Range ps pe
  where
    ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)
    pe = Position (srcSpanEndLine ss - 1)   (srcSpanEndColumn ss - 1)

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

applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)
applyHint fp mhint fileMap = do
  runExceptT $ do
    ideas <- getIdeas fp mhint
    let commands = map (show &&& ideaRefactoring) ideas
    liftIO $ logm $ "applyHint:apply=" ++ show commands
    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint pont to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    -- Example:
    -- Given an expression "hlintTest = reid $ (myid ())"
    -- Hlint returns an idea at the position (1,13)
    -- That contains "Redundant brackets" refactoring at position (1,20):
    --
    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
    --
    -- If we provide "applyRefactorings" with "Just (1,13)" then
    -- the "Redundant bracket" hint will never be executed
    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
    res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
              [ Handler $ \e -> return (Left (show (e :: IOException)))
              , Handler $ \e -> return (Left (show (e :: ErrorCall)))
              ]
    case res of
      Right appliedFile -> do
        diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
        liftIO $ logm $ "applyHint:diff=" ++ show diff
        return diff
      Left err ->
        throwE (show err)

-- | Gets HLint ideas for
getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]
getIdeas lintFile mhint = do
  let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
  ideas <- runHlint lintFile hOpts
  pure $ maybe ideas (`filterIdeas` ideas) mhint

-- | If we are only interested in applying a particular hint then
-- let's filter out all the irrelevant ideas
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position l c) title) ideas =
  let
    title' = T.unpack title
    ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan
  in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas

hlintOpts :: FilePath -> Maybe Position -> [String]
hlintOpts lintFile mpos =
  let
    posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
    opts = maybe "" posOpt mpos
  in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]

runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]
runHlint fp args =
  do (flags,classify,hint) <- liftIO $ argsSettings args
     let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
     res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing
     pure $ applyHints classify hint [res]

showParseError :: Hlint.ParseError -> String
showParseError (Hlint.ParseError location message content) =
  unlines [show location, message, content]

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

codeActionProvider :: CodeActionProvider
codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions
  where

    hlintActions :: IdeM [LSP.CodeAction]
    hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)

    -- |Some hints do not have an associated refactoring
    validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =
      case code of
        "Eta reduce" -> False
        _            -> True
    validCommand _ = False

    LSP.List diags = context ^. LSP.diagnostics

    mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)
    mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =
      Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
     where
       codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
       title = "Apply hint:" <> head (T.lines m)
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
       args = [toJSON (AOP (docId ^. LSP.uri) start code)]
    mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing
-}
-- ---------------------------------------------------------------------

{-

{-# LANGUAGE CPP #-}

{-# LANGUAGE DeriveAnyClass        #-}

{-# LANGUAGE DeriveGeneric         #-}

{-# LANGUAGE DuplicateRecordFields #-}

{-# LANGUAGE OverloadedStrings     #-}

-- | apply-refact applies refactorings specified by the refact package. It is

-- currently integrated into hlint to enable the automatic application of

-- suggestions.

module Haskell.Ide.Engine.Plugin.ApplyRefact where



import           Control.Arrow

import           Control.Exception              ( IOException

                                                , ErrorCall

                                                , Handler(..)

                                                , catches

                                                , try

                                                )

import           Control.Lens            hiding ( List )

import           Control.Monad.IO.Class

import           Control.Monad.Trans.Except

import           Data.Aeson                        hiding (Error)

import           Data.Maybe




import           Data.Monoid                       ((<>))




import qualified Data.Text                         as T

import           GHC.Generics

import           Haskell.Ide.Engine.MonadFunctions

import           Haskell.Ide.Engine.MonadTypes

import           Haskell.Ide.Engine.PluginUtils

import           Language.Haskell.Exts.SrcLoc

import           Language.Haskell.Exts.Parser

import           Language.Haskell.Exts.Extension

import           Language.Haskell.HLint4           as Hlint

import qualified Language.Haskell.LSP.Types        as LSP

import qualified Language.Haskell.LSP.Types.Lens   as LSP

import           Refact.Apply



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

{-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}

{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

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



type HintTitle = T.Text



applyRefactDescriptor :: PluginId -> PluginDescriptor

applyRefactDescriptor plId = PluginDescriptor

  { pluginId = plId

  , pluginName = "ApplyRefact"

  , pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."

  , pluginCommands =

      [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd

      , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd

      ]

  , pluginCodeActionProvider = Just codeActionProvider

  , pluginDiagnosticProvider = Nothing

  , pluginHoverProvider = Nothing

  , pluginSymbolProvider = Nothing

  , pluginFormattingProvider = Nothing

  }



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



data ApplyOneParams = AOP

  { file      :: Uri

  , start_pos :: Position

  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.

  , hintTitle :: HintTitle

  } deriving (Eq,Show,Generic,FromJSON,ToJSON)



data OneHint = OneHint

  { oneHintPos :: Position

  , oneHintTitle :: HintTitle

  } deriving (Eq, Show)



applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)

applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do

  let oneHint = OneHint pos title

  revMapp <- reverseFileMap

  let defaultResult = do

        debugm "applyOne: no access to the persisted file."

        return $ IdeResultOk mempty

  withMappedFile fp defaultResult $ \file' -> do

    res <- liftToGhc $ applyHint file' (Just oneHint) revMapp

    logm $ "applyOneCmd:file=" ++ show fp

    logm $ "applyOneCmd:res=" ++ show res

    case res of

      Left err -> return $ IdeResultFail

        (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)

      Right fs -> return (IdeResultOk fs)





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



applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)

applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do

  let defaultResult = do

        debugm "applyAll: no access to the persisted file."

        return $ IdeResultOk mempty

  revMapp <- reverseFileMap

  withMappedFile fp defaultResult $ \file' -> do

    res <- liftToGhc $ applyHint file' Nothing revMapp

    logm $ "applyAllCmd:res=" ++ show res

    case res of

      Left err -> return $ IdeResultFail (IdeError PluginError

                    (T.pack $ "applyAll: " ++ show err) Null)

      Right fs -> return (IdeResultOk fs)



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



-- AZ:TODO: Why is this in IdeGhcM?

lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)

lint uri = pluginGetFile "lint: " uri $ \fp -> do

  let

    defaultResult = do

      debugm "lint: no access to the persisted file."

      return

        $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])

  withMappedFile fp defaultResult $ \file' -> do

    eitherErrorResult <- liftIO

      (try $ runExceptT $ runLint file' [] :: IO

          (Either IOException (Either [Diagnostic] [Idea]))

      )

    case eitherErrorResult of

      Left err -> return $ IdeResultFail

        (IdeError PluginError (T.pack $ "lint: " ++ show err) Null)

      Right res -> case res of

        Left diags ->

          return

            (IdeResultOk

              (PublishDiagnosticsParams (filePathToUri fp) $ List diags)

            )

        Right fs ->

          return

            $ IdeResultOk

            $ PublishDiagnosticsParams (filePathToUri fp)

            $ List (map hintToDiagnostic $ stripIgnores fs)



runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]

runLint fp args = do

  (flags,classify,hint) <- liftIO $ argsSettings args

  let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}

  res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing

  pure $ applyHints classify hint [res]



parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]

parseErrorToDiagnostic (Hlint.ParseError l msg contents) =

  [Diagnostic

      { _range    = srcLoc2Range l

      , _severity = Just DsInfo -- Not displayed

      , _code     = Just (LSP.StringValue "parser")

      , _source   = Just "hlint"

      , _message  = T.unlines [T.pack msg,T.pack contents]

      , _relatedInformation = Nothing

      }]



{-

-- | An idea suggest by a 'Hint'.

data Idea = Idea

    {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.

    ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.

    ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.

    ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.

    ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.

    ,ideaFrom :: String -- ^ The contents of the source code the idea relates to.

    ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).

    ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.

    ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea

    }

    deriving (Eq,Ord)



-}



-- | Map over both failure and success.

bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b

bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where

  h (Left e)  = Left (f e)

  h (Right a) = Right (g a)

{-# INLINE bimapExceptT #-}



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



stripIgnores :: [Idea] -> [Idea]

stripIgnores ideas = filter notIgnored ideas

  where

    notIgnored idea = ideaSeverity idea /= Ignore



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



hintToDiagnostic :: Idea -> Diagnostic

hintToDiagnostic idea

  = Diagnostic

      { _range    = ss2Range (ideaSpan idea)

      , _severity = Just (hintSeverityMap $ ideaSeverity idea)

      , _code     = Just (LSP.StringValue $ T.pack $ ideaHint idea)

      , _source   = Just "hlint"

      , _message  = idea2Message idea

      , _relatedInformation = Nothing

      }



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



idea2Message :: Idea -> T.Text

idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", "  " <> T.pack (ideaFrom idea)]

                               <> toIdea <> map (T.pack . show) (ideaNote idea)

  where

    toIdea :: [T.Text]

    toIdea = case ideaTo idea of

      Nothing -> []

      Just i  -> [T.pack "Why not:", T.pack $ "  " ++ i]



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

-- | Maps hlint severities to LSP severities

-- | We want to lower the severities so HLint errors and warnings

-- | don't mix with GHC errors and warnings:

-- | as per https://github.com/haskell/haskell-ide-engine/issues/375

hintSeverityMap :: Severity -> DiagnosticSeverity

hintSeverityMap Ignore     = DsInfo -- cannot really happen after stripIgnores

hintSeverityMap Suggestion = DsHint

hintSeverityMap Warning    = DsInfo

hintSeverityMap Error      = DsInfo



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



srcLoc2Range :: SrcLoc -> Range

srcLoc2Range (SrcLoc _ l c) = Range ps pe

  where

    ps = Position (l-1) (c-1)

    pe = Position (l-1) 100000



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



ss2Range :: SrcSpan -> Range

ss2Range ss = Range ps pe

  where

    ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)

    pe = Position (srcSpanEndLine ss - 1)   (srcSpanEndColumn ss - 1)



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



applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)

applyHint fp mhint fileMap = do

  runExceptT $ do

    ideas <- getIdeas fp mhint

    let commands = map (show &&& ideaRefactoring) ideas

    liftIO $ logm $ "applyHint:apply=" ++ show commands

    -- set Nothing as "position" for "applyRefactorings" because

    -- applyRefactorings expects the provided position to be _within_ the scope

    -- of each refactoring it will apply.

    -- But "Idea"s returned by HLint pont to starting position of the expressions

    -- that contain refactorings, so they are often outside the refactorings' boundaries.

    -- Example:

    -- Given an expression "hlintTest = reid $ (myid ())"

    -- Hlint returns an idea at the position (1,13)

    -- That contains "Redundant brackets" refactoring at position (1,20):

    --

    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]

    --

    -- If we provide "applyRefactorings" with "Just (1,13)" then

    -- the "Redundant bracket" hint will never be executed

    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).

    res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`

              [ Handler $ \e -> return (Left (show (e :: IOException)))

              , Handler $ \e -> return (Left (show (e :: ErrorCall)))

              ]

    case res of

      Right appliedFile -> do

        diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap

        liftIO $ logm $ "applyHint:diff=" ++ show diff

        return diff

      Left err ->

        throwE (show err)



-- | Gets HLint ideas for

getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]

getIdeas lintFile mhint = do

  let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)

  ideas <- runHlint lintFile hOpts

  pure $ maybe ideas (`filterIdeas` ideas) mhint



-- | If we are only interested in applying a particular hint then

-- let's filter out all the irrelevant ideas

filterIdeas :: OneHint -> [Idea] -> [Idea]

filterIdeas (OneHint (Position l c) title) ideas =

  let

    title' = T.unpack title

    ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan

  in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas



hlintOpts :: FilePath -> Maybe Position -> [String]

hlintOpts lintFile mpos =

  let

    posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)

    opts = maybe "" posOpt mpos

  in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]



runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]

runHlint fp args =

  do (flags,classify,hint) <- liftIO $ argsSettings args

     let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}

     res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing

     pure $ applyHints classify hint [res]



showParseError :: Hlint.ParseError -> String

showParseError (Hlint.ParseError location message content) =

  unlines [show location, message, content]



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



codeActionProvider :: CodeActionProvider

codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions

  where



    hlintActions :: IdeM [LSP.CodeAction]

    hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)



    -- |Some hints do not have an associated refactoring

    validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =

      case code of

        "Eta reduce" -> False

        _            -> True

    validCommand _ = False



    LSP.List diags = context ^. LSP.diagnostics



    mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)

    mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =

      Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)

     where

       codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)

       title = "Apply hint:" <> head (T.lines m)

       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)

       args = [toJSON (AOP (docId ^. LSP.uri) start code)]

    mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing

-}

#endif