{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Ide.Plugin.CodeRange (
    descriptor
    , Log

    -- * Internal
    , findPosition
    ) where

import           Control.Monad.Except                 (ExceptT (ExceptT),
                                                       runExceptT)
import           Control.Monad.IO.Class               (liftIO)
import           Control.Monad.Trans.Maybe            (MaybeT (MaybeT),
                                                       maybeToExceptT)
import           Data.Either.Extra                    (maybeToEither)
import           Data.Maybe                           (fromMaybe)
import           Data.Vector                          (Vector)
import qualified Data.Vector                          as V
import           Development.IDE                      (IdeAction,
                                                       IdeState (shakeExtras),
                                                       Range (Range), Recorder,
                                                       WithPriority,
                                                       cmapWithPrio,
                                                       runIdeAction,
                                                       toNormalizedFilePath',
                                                       uriToFilePath')
import           Development.IDE.Core.Actions         (useE)
import           Development.IDE.Core.PositionMapping (PositionMapping,
                                                       fromCurrentPosition,
                                                       toCurrentRange)
import           Development.IDE.Types.Logger         (Pretty (..))
import           Ide.Plugin.CodeRange.Rules           (CodeRange (..),
                                                       GetCodeRange (..),
                                                       codeRangeRule)
import qualified Ide.Plugin.CodeRange.Rules           as Rules (Log)
import           Ide.PluginUtils                      (pluginResponse,
                                                       positionInRange)
import           Ide.Types                            (PluginDescriptor (pluginHandlers, pluginRules),
                                                       PluginId,
                                                       defaultPluginDescriptor,
                                                       mkPluginHandler)
import           Language.LSP.Server                  (LspM)
import           Language.LSP.Types                   (List (List),
                                                       NormalizedFilePath,
                                                       Position (..),
                                                       Range (_start),
                                                       ResponseError,
                                                       SMethod (STextDocumentSelectionRange),
                                                       SelectionRange (..),
                                                       SelectionRangeParams (..),
                                                       TextDocumentIdentifier (TextDocumentIdentifier),
                                                       Uri)
import           Prelude                              hiding (log, span)

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentSelectionRange
STextDocumentSelectionRange forall c.
IdeState
-> PluginId
-> SelectionRangeParams
-> LspM c (Either ResponseError (List SelectionRange))
selectionRangeHandler
    -- TODO @sloorush add folding range
    -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler
    , pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
codeRangeRule (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogRules Recorder (WithPriority Log)
recorder)
    }

data Log = LogRules Rules.Log

instance Pretty Log where
    pretty :: forall ann. Log -> Doc ann
pretty Log
log = case Log
log of
        LogRules Log
codeRangeLog -> forall a ann. Pretty a => a -> Doc ann
pretty Log
codeRangeLog

selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange))
selectionRangeHandler :: forall c.
IdeState
-> PluginId
-> SelectionRangeParams
-> LspM c (Either ResponseError (List SelectionRange))
selectionRangeHandler IdeState
ide PluginId
_ SelectionRangeParams{Maybe ProgressToken
List Position
TextDocumentIdentifier
$sel:_workDoneToken:SelectionRangeParams :: SelectionRangeParams -> Maybe ProgressToken
$sel:_partialResultToken:SelectionRangeParams :: SelectionRangeParams -> Maybe ProgressToken
$sel:_textDocument:SelectionRangeParams :: SelectionRangeParams -> TextDocumentIdentifier
$sel:_positions:SelectionRangeParams :: SelectionRangeParams -> List Position
_positions :: List Position
_textDocument :: TextDocumentIdentifier
_partialResultToken :: Maybe ProgressToken
_workDoneToken :: Maybe ProgressToken
..} = do
    forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
        NormalizedFilePath
filePath <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Maybe b -> Either a b
maybeToEither String
"fail to convert uri to file path" forall a b. (a -> b) -> a -> b
$
                String -> NormalizedFilePath
toNormalizedFilePath' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe String
uriToFilePath' Uri
uri
        [SelectionRange]
selectionRanges <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"SelectionRange" (IdeState -> ShakeExtras
shakeExtras IdeState
ide) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
            NormalizedFilePath
-> [Position] -> ExceptT String IdeAction [SelectionRange]
getSelectionRanges NormalizedFilePath
filePath [Position]
positions
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ [SelectionRange]
selectionRanges
  where
    uri :: Uri
    TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
_textDocument

    positions :: [Position]
    List [Position]
positions = List Position
_positions

getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange]
getSelectionRanges :: NormalizedFilePath
-> [Position] -> ExceptT String IdeAction [SelectionRange]
getSelectionRanges NormalizedFilePath
file [Position]
positions = do
    (CodeRange
codeRange, PositionMapping
positionMapping) <- forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT String
"fail to get code range" forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useE GetCodeRange
GetCodeRange NormalizedFilePath
file
    -- 'positionMapping' should be appied to the input before using them
    [Position]
positions' <- forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT String
"fail to apply position mapping to input positions" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PositionMapping -> Position -> Maybe Position
fromCurrentPosition PositionMapping
positionMapping) [Position]
positions

    let selectionRanges :: [SelectionRange]
selectionRanges = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Position]
positions' forall a b. (a -> b) -> a -> b
$ \Position
pos ->
            -- We need a default selection range if the lookup fails, so that other positions can still have valid results.
            let defaultSelectionRange :: SelectionRange
defaultSelectionRange = Range -> Maybe SelectionRange -> SelectionRange
SelectionRange (Position -> Position -> Range
Range Position
pos Position
pos) forall a. Maybe a
Nothing
             in forall a. a -> Maybe a -> a
fromMaybe SelectionRange
defaultSelectionRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> CodeRange -> Maybe SelectionRange
findPosition Position
pos forall a b. (a -> b) -> a -> b
$ CodeRange
codeRange

    -- 'positionMapping' should be applied to the output ranges before returning them
    forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT String
"fail to apply position mapping to output positions" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
         forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PositionMapping -> SelectionRange -> Maybe SelectionRange
toCurrentSelectionRange PositionMapping
positionMapping) [SelectionRange]
selectionRanges

-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'.
findPosition :: Position -> CodeRange -> Maybe SelectionRange
findPosition :: Position -> CodeRange -> Maybe SelectionRange
findPosition Position
pos CodeRange
root = Maybe SelectionRange -> CodeRange -> Maybe SelectionRange
go forall a. Maybe a
Nothing CodeRange
root
  where
    -- Helper function for recursion. The range list is built top-down
    go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange
    go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange
go Maybe SelectionRange
acc CodeRange
node =
        if Position -> Range -> Bool
positionInRange Position
pos Range
range
        then forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe SelectionRange
acc' (Maybe SelectionRange -> CodeRange -> Maybe SelectionRange
go Maybe SelectionRange
acc') (Vector CodeRange -> Maybe CodeRange
binarySearchPos Vector CodeRange
children)
        -- If all children doesn't contain pos, acc' will be returned.
        -- acc' will be Nothing only if we are in the root level.
        else forall a. Maybe a
Nothing
      where
        range :: Range
range = CodeRange -> Range
_codeRange_range CodeRange
node
        children :: Vector CodeRange
children = CodeRange -> Vector CodeRange
_codeRange_children CodeRange
node
        acc' :: Maybe SelectionRange
acc' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Range -> Maybe SelectionRange -> SelectionRange
SelectionRange Range
range forall a. Maybe a
Nothing) (Range -> Maybe SelectionRange -> SelectionRange
SelectionRange Range
range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe SelectionRange
acc

    binarySearchPos :: Vector CodeRange -> Maybe CodeRange
    binarySearchPos :: Vector CodeRange -> Maybe CodeRange
binarySearchPos Vector CodeRange
v
        | forall a. Vector a -> Bool
V.null Vector CodeRange
v = forall a. Maybe a
Nothing
        | forall a. Vector a -> Int
V.length Vector CodeRange
v forall a. Eq a => a -> a -> Bool
== Int
1,
            Just CodeRange
r <- forall (m :: * -> *) a. Monad m => Vector a -> m a
V.headM Vector CodeRange
v = if Position -> Range -> Bool
positionInRange Position
pos (CodeRange -> Range
_codeRange_range CodeRange
r) then forall a. a -> Maybe a
Just CodeRange
r else forall a. Maybe a
Nothing
        | Bool
otherwise = do
            let (Vector CodeRange
left, Vector CodeRange
right) = forall a. Int -> Vector a -> (Vector a, Vector a)
V.splitAt (forall a. Vector a -> Int
V.length Vector CodeRange
v forall a. Integral a => a -> a -> a
`div` Int
2) Vector CodeRange
v
            Position
startOfRight <- Range -> Position
_start forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeRange -> Range
_codeRange_range forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Vector a -> m a
V.headM Vector CodeRange
right
            if Position
pos forall a. Ord a => a -> a -> Bool
< Position
startOfRight then Vector CodeRange -> Maybe CodeRange
binarySearchPos Vector CodeRange
left else Vector CodeRange -> Maybe CodeRange
binarySearchPos Vector CodeRange
right

-- | Likes 'toCurrentPosition', but works on 'SelectionRange'
toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange
toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange
toCurrentSelectionRange PositionMapping
positionMapping SelectionRange{Maybe SelectionRange
Range
$sel:_range:SelectionRange :: SelectionRange -> Range
$sel:_parent:SelectionRange :: SelectionRange -> Maybe SelectionRange
_parent :: Maybe SelectionRange
_range :: Range
..} = do
    Range
newRange <- PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
positionMapping Range
_range
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SelectionRange {
        $sel:_range:SelectionRange :: Range
_range = Range
newRange,
        $sel:_parent:SelectionRange :: Maybe SelectionRange
_parent = Maybe SelectionRange
_parent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PositionMapping -> SelectionRange -> Maybe SelectionRange
toCurrentSelectionRange PositionMapping
positionMapping
    }