AlternateNumberFormat.hs

{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns  #-}
module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where

import           Control.Lens                    ((^.))
import           Control.Monad.Except            (ExceptT, MonadIO, liftIO)
import qualified Data.HashMap.Strict             as HashMap
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Development.IDE                 (GetParsedModule (GetParsedModule),
                                                  GhcSession (GhcSession),
                                                  IdeState, RuleResult, Rules,
                                                  define, getFileContents,
                                                  hscEnv, ideLogger,
                                                  realSrcSpanToRange, runAction,
                                                  use, useWithStale)
import qualified Development.IDE.Core.Shake      as Shake
import           Development.IDE.GHC.Compat      hiding (getSrcSpan)
import           Development.IDE.GHC.Compat.Util (toList)
import           Development.IDE.Graph.Classes   (Hashable, NFData, rnf)
import           Development.IDE.Spans.Pragmas   (NextPragmaInfo,
                                                  getNextPragmaInfo,
                                                  insertNewPragma)
import           Development.IDE.Types.Logger    as Logger
import           GHC.Generics                    (Generic)
import           GHC.LanguageExtensions.Type     (Extension)
import           Ide.Plugin.Conversion           (AlternateFormat,
                                                  ExtensionNeeded (NeedsExtension, NoExtension),
                                                  alternateFormat)
import           Ide.Plugin.Literals
import           Ide.PluginUtils                 (handleMaybe, handleMaybeM,
                                                  response)
import           Ide.Types
import           Language.LSP.Types
import           Language.LSP.Types.Lens         (uri)

newtype Log = LogShake Shake.Log deriving Show

instance Pretty Log where
  pretty = \case
    LogShake log -> pretty log

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor recorder plId = (defaultPluginDescriptor plId)
    { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler
    , pluginRules = collectLiteralsRule recorder
    }

data CollectLiterals = CollectLiterals
                     deriving (Show, Eq, Generic)

instance Hashable CollectLiterals
instance NFData CollectLiterals

type instance RuleResult CollectLiterals = CollectLiteralsResult

data CollectLiteralsResult = CLR
    { literals          :: [Literal]
    , enabledExtensions :: [GhcExtension]
    } deriving (Generic)

newtype GhcExtension = GhcExtension { unExt :: Extension }

instance NFData GhcExtension where
    rnf x = x `seq` ()

instance Show CollectLiteralsResult where
    show _ = "<CollectLiteralResult>"

instance NFData CollectLiteralsResult

collectLiteralsRule :: Recorder (WithPriority Log) -> Rules ()
collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do
    pm <- use GetParsedModule nfp
    -- get the current extensions active and transform them into FormatTypes
    let exts = getExtensions <$> pm
        -- collect all the literals for a file
        lits = collectLiterals . pm_parsed_source <$> pm
    pure ([], CLR <$> lits <*> exts)
    where
        getExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary

codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler state _ (CodeActionParams _ _ docId currRange _) = response $ do
    nfp <- getNormalizedFilePath docId
    CLR{..} <- requestLiterals state nfp
    pragma <- getFirstPragma state nfp
        -- remove any invalid literals (see validTarget comment)
    let litsInRange = filter inCurrentRange literals
        -- generate alternateFormats and zip with the literal that generated the alternates
        literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange
        -- make a code action for every literal and its' alternates (then flatten the result)
        actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs

    pure $ List actions
    where
        inCurrentRange :: Literal -> Bool
        inCurrentRange lit = let srcSpan = getSrcSpan lit
                              in currRange `contains` srcSpan

        mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction
        mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction {
            _title = mkCodeActionTitle lit af enabled
            , _kind = Just $ CodeActionUnknown "quickfix.literals.style"
            , _diagnostics = Nothing
            , _isPreferred = Nothing
            , _disabled = Nothing
            , _edit = Just $ mkWorkspaceEdit nfp edits
            , _command = Nothing
            , _xdata = Nothing
            }
            where
                edits =  [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit
                pragmaEdit = case ext of
                    NeedsExtension ext' -> [insertNewPragma npi ext' | needsExtension ext' enabled]
                    NoExtension         -> []

        mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
        mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing
            where
                changes = Just $ HashMap.fromList [(filePathToUri $ fromNormalizedFilePath nfp, List edits)]

mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text
mkCodeActionTitle lit (alt, ext) ghcExts
    | (NeedsExtension ext') <- ext
    , needsExtension ext' ghcExts = title <> " (needs extension: " <> T.pack (show ext') <> ")"
    | otherwise = title
    where
        title = "Convert " <> getSrcText lit <> " into " <> alt


-- | Checks whether the extension given is already enabled
needsExtension :: Extension -> [GhcExtension] -> Bool
needsExtension ext ghcExts = ext `notElem` map unExt ghcExts

-- from HaddockComments.hs
contains :: Range -> RealSrcSpan -> Bool
contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSrcSpan _end x

isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool
p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep

getFirstPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
getFirstPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do
      ghcSession <- liftIO $ runAction "AlternateNumberFormat.GhcSession" state $ useWithStale GhcSession nfp
      (_, fileContents) <- liftIO $ runAction "AlternateNumberFormat.GetFileContents" state $ getFileContents nfp
      case ghcSession of
        Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
        Nothing -> pure Nothing


getNormalizedFilePath :: Monad m => TextDocumentIdentifier -> ExceptT String m NormalizedFilePath
getNormalizedFilePath docId = handleMaybe "Error: converting to NormalizedFilePath"
        $ uriToNormalizedFilePath
        $ toNormalizedUri (docId ^. uri)

requestLiterals :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
requestLiterals state = handleMaybeM "Error: Could not Collect Literals"
                . liftIO
                . runAction "AlternateNumberFormat.CollectLiterals" state
                . use CollectLiterals