{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE LambdaCase #-}

module Futhark.LSP.CodeLens (evalLensesFor, execute, resolve) where

import Control.Arrow ((>>>))
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (AllocationLimitExceeded (AllocationLimitExceeded), handle)
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.Except (Except, MonadError (throwError), runExceptT)
import Control.Monad.Trans (MonadIO (liftIO), lift)
import Data.Aeson (FromJSON (parseJSON))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types qualified as Aeson
import Data.Foldable (toList)
import Data.Function ((&))
import Data.IORef (IORef, newIORef, readIORef)
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Sequence (Seq ((:|>)))
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Mixed.Rope qualified as R
import Futhark.Compiler.Program (VFS)
import Futhark.Eval (EvalConfig (evalFile, evalPrintWarnings), Evaluation (abort), evalConfig, newInterpreterState, runEvalRecordRef, runExpr)
import Futhark.LSP.CommandType qualified as CommandType
import Futhark.LSP.Tool (Execute, transformVFS)
import Futhark.Util (showText)
import Futhark.Util.Pretty (docText, plural, pretty, vcat)
import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit))
import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), CodeLens (..), Command (..), ErrorCodes (ErrorCodes_InvalidParams), Position (..), Range (..), TextEdit (..), UInt, Uri, WorkspaceEdit (..), fromNormalizedFilePath, toNormalizedUri, uriToNormalizedFilePath, type (|?) (..))
import Language.LSP.Server (LspT, getVirtualFile, getVirtualFiles, sendRequest)
import Language.LSP.VFS (file_text)
import Prettyprinter (Doc)
import Prettyprinter.Render.Terminal (AnsiStyle)
import System.Mem (enableAllocationLimit, setAllocationCounter)
import System.Timeout (timeout)

-- | All the possible lenses
--
-- I tried some trickery with GADTs here for advanced type safety, but I
-- ultimately didn't succeed because I was unable to write/derive instances
newtype LensPayload
  = EvalLensPayload EvalLensData

instance Aeson.ToJSON LensPayload where
  -- it is necessary to make sure that this mirror with @FromJSON@
  toJSON :: LensPayload -> Aeson.Value
  toJSON :: LensPayload -> Value
toJSON (EvalLensPayload EvalLensData
payload) = Text -> EvalLensData -> Value
forall a. ToJSON a => Text -> a -> Value
payloadWithType Text
"EvalLens" EvalLensData
payload
    where
      payloadWithType :: (Aeson.ToJSON a) => Text -> a -> Aeson.Value
      payloadWithType :: forall a. ToJSON a => Text -> a -> Value
payloadWithType Text
typ a
load =
        Object -> Value
Aeson.Object (Object -> Value)
-> ([(Key, Value)] -> Object) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$
          [ (Key
"type", Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Text
typ),
            (Key
"payload", a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
load)
          ]

instance Aeson.FromJSON LensPayload where
  -- it is necessary to make sure that this mirror with @toJSON@
  parseJSON :: Aeson.Value -> Aeson.Parser LensPayload
  parseJSON :: Value -> Parser LensPayload
parseJSON = String
-> (Object -> Parser LensPayload) -> Value -> Parser LensPayload
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LensPayload" ((Object -> Parser LensPayload) -> Value -> Parser LensPayload)
-> (Object -> Parser LensPayload) -> Value -> Parser LensPayload
forall a b. (a -> b) -> a -> b
$ \Object
object -> do
    (typ :: Text) <- Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson.parseField Object
object Key
"type"
    case typ of
      Text
"EvalLens" -> EvalLensData -> LensPayload
EvalLensPayload (EvalLensData -> LensPayload)
-> Parser EvalLensData -> Parser LensPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Key -> Parser EvalLensData
forall a. FromJSON a => Object -> Key -> Parser a
Aeson.parseField Object
object Key
"payload"
      Text
_ -> String -> Parser LensPayload
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser LensPayload) -> String -> Parser LensPayload
forall a b. (a -> b) -> a -> b
$ String
"Unknown Lens Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
typ

-- which document, which line
-- this is valid as long as the document has an eval comment on that line
data EvalLensData = EvalLensData
  { EvalLensData -> Uri
eldTextDocument :: Uri,
    EvalLensData -> UInt
eldLine :: UInt
  }

instance Aeson.ToJSON EvalLensData where
  toJSON :: EvalLensData -> Aeson.Value
  toJSON :: EvalLensData -> Value
toJSON (EvalLensData Uri
textDoc UInt
line) = (Uri, UInt) -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Uri
textDoc, UInt
line)

instance Aeson.FromJSON EvalLensData where
  parseJSON :: Aeson.Value -> Aeson.Parser EvalLensData
  parseJSON :: Value -> Parser EvalLensData
parseJSON Value
o = do
    (textDoc, line) <- Value -> Parser (Uri, UInt)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
    pure $ EvalLensData textDoc line

evalLensPrefix :: T.Text
evalLensPrefix :: Text
evalLensPrefix = Text
"-- >>>"

evalLensesFor :: Uri -> LspT () IO (Either Text [CodeLens])
evalLensesFor :: Uri -> LspT () IO (Either Text [CodeLens])
evalLensesFor Uri
file_uri = ExceptT Text (LspT () IO) [CodeLens]
-> LspT () IO (Either Text [CodeLens])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (LspT () IO) [CodeLens]
 -> LspT () IO (Either Text [CodeLens]))
-> ExceptT Text (LspT () IO) [CodeLens]
-> LspT () IO (Either Text [CodeLens])
forall a b. (a -> b) -> a -> b
$ do
  vfile <-
    LspT () IO (Maybe VirtualFile)
-> ExceptT Text (LspT () IO) (Maybe VirtualFile)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Text m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NormalizedUri -> LspT () IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> LspT () IO (Maybe VirtualFile))
-> NormalizedUri -> LspT () IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
file_uri) ExceptT Text (LspT () IO) (Maybe VirtualFile)
-> (Maybe VirtualFile -> ExceptT Text (LspT () IO) VirtualFile)
-> ExceptT Text (LspT () IO) VirtualFile
forall a b.
ExceptT Text (LspT () IO) a
-> (a -> ExceptT Text (LspT () IO) b)
-> ExceptT Text (LspT () IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe VirtualFile
Nothing -> Text -> ExceptT Text (LspT () IO) VirtualFile
forall a. Text -> ExceptT Text (LspT () IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (LspT () IO) VirtualFile)
-> (String -> Text)
-> String
-> ExceptT Text (LspT () IO) VirtualFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ExceptT Text (LspT () IO) VirtualFile)
-> String -> ExceptT Text (LspT () IO) VirtualFile
forall a b. (a -> b) -> a -> b
$ String
"Could not find file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
file_uri
      Just VirtualFile
vfile -> VirtualFile -> ExceptT Text (LspT () IO) VirtualFile
forall a. a -> ExceptT Text (LspT () IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VirtualFile
vfile

  let commentLines =
        VirtualFile
vfile VirtualFile -> Getting Rope VirtualFile Rope -> Rope
forall s a. s -> Getting a s a -> a
^. Getting Rope VirtualFile Rope
forall s a. HasFile_text s a => Lens' s a
Lens' VirtualFile Rope
file_text
          Rope -> (Rope -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Rope -> [Text]
R.lines
          [Text] -> ([Text] -> [(UInt, Text)]) -> [(UInt, Text)]
forall a b. a -> (a -> b) -> b
& [UInt] -> [Text] -> [(UInt, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UInt
0 :: UInt ..]
          [(UInt, Text)] -> ([(UInt, Text)] -> [UInt]) -> [UInt]
forall a b. a -> (a -> b) -> b
& ((UInt, Text) -> Maybe UInt) -> [(UInt, Text)] -> [UInt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (UInt, Text) -> Maybe UInt
forall {a}. (a, Text) -> Maybe a
filterComment

  pure $
    commentLines
      & map evalLens
  where
    filterComment :: (a, Text) -> Maybe a
filterComment (a
i, Text
line) = a
i a -> Maybe Text -> Maybe a
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Text -> Maybe Text
T.stripPrefix Text
evalLensPrefix Text
line
    evalLens :: UInt -> CodeLens
evalLens UInt
i =
      CodeLens
        { _command :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing,
          _data_ :: Maybe Value
_data_ =
            Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> (EvalLensData -> Value) -> EvalLensData -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensPayload -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (LensPayload -> Value)
-> (EvalLensData -> LensPayload) -> EvalLensData -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalLensData -> LensPayload
EvalLensPayload (EvalLensData -> Maybe Value) -> EvalLensData -> Maybe Value
forall a b. (a -> b) -> a -> b
$
              EvalLensData
                { eldTextDocument :: Uri
eldTextDocument = Uri
file_uri,
                  eldLine :: UInt
eldLine = UInt
i
                },
          _range :: Range
_range =
            Range
              { _start :: Position
_start = Position {_line :: UInt
_line = UInt
i, _character :: UInt
_character = UInt
0},
                _end :: Position
_end = Position {_line :: UInt
_line = UInt
i, _character :: UInt
_character = UInt
forall a. Bounded a => a
maxBound}
              }
        }

resolve :: CodeLens -> Except Text CodeLens
resolve :: CodeLens -> Except Text CodeLens
resolve (CodeLens Range
_ (Just Command
_) Maybe Value
_) =
  Text -> Except Text CodeLens
forall a. Text -> ExceptT Text Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"CodeLens is already resolved"
resolve (CodeLens Range
_ Maybe Command
_ Maybe Value
Nothing) =
  Text -> Except Text CodeLens
forall a. Text -> ExceptT Text Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"CodeLens doesn't have data attached"
resolve (CodeLens Range
range Maybe Command
Nothing (Just Value
payload)) =
  case Value -> Result LensPayload
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
payload :: Aeson.Result LensPayload of
    Aeson.Error String
msg -> Text -> Except Text CodeLens
forall a. Text -> ExceptT Text Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Except Text CodeLens) -> Text -> Except Text CodeLens
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
    Aeson.Success LensPayload
_ ->
      CodeLens -> Except Text CodeLens
forall a. a -> ExceptT Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> Except Text CodeLens)
-> CodeLens -> Except Text CodeLens
forall a b. (a -> b) -> a -> b
$
        CodeLens
          { _range :: Range
_range = Range
range,
            _data_ :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing,
            _command :: Maybe Command
_command =
              Command -> Maybe Command
forall a. a -> Maybe a
Just
                Command
                  { _arguments :: Maybe [Value]
_arguments = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value
payload],
                    _title :: Text
_title = Text
"Evaluate",
                    _command :: Text
_command = CommandType -> Text
forall a. Show a => a -> Text
showText CommandType
CommandType.CodeLens
                  }
          }

-- | Decode the arguments
execute :: Maybe [Aeson.Value] -> Execute ()
execute :: Maybe [Value] -> Execute ()
execute (Just [Value
argument]) = case Value -> Result LensPayload
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
argument :: Aeson.Result LensPayload of
  Aeson.Success LensPayload
payload -> LensPayload -> Execute ()
executeLens LensPayload
payload
  Aeson.Error String
msg ->
    (Text, LSPErrorCodes |? ErrorCodes) -> Execute ()
forall a.
(Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ( Text
"Failed to decode CodeLens command argument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
msg,
        ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams
      )
execute Maybe [Value]
bad =
  (Text, LSPErrorCodes |? ErrorCodes) -> Execute ()
forall a.
(Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    ( Text
"Expected exactly one argument for the CodeLens Command, got: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe [Value] -> Text
forall a. Show a => a -> Text
showText Maybe [Value]
bad,
      ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams
    )

-- | Dispatch to the correct lens executor
--
-- (currently there's only one)
executeLens :: LensPayload -> Execute ()
executeLens :: LensPayload -> Execute ()
executeLens (EvalLensPayload EvalLensData
payloadData) = EvalLensData -> Execute ()
executeEvalLens EvalLensData
payloadData

-- | Execute a Evaluation Lens
executeEvalLens :: EvalLensData -> Execute ()
executeEvalLens :: EvalLensData -> Execute ()
executeEvalLens (EvalLensData Uri
docUri UInt
line) = do
  -- retrieve the file
  file <-
    LspT () IO (Maybe VirtualFile)
-> ExceptT
     (Text, LSPErrorCodes |? ErrorCodes)
     (LspT () IO)
     (Maybe VirtualFile)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Text, LSPErrorCodes |? ErrorCodes) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NormalizedUri -> LspT () IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> LspT () IO (Maybe VirtualFile))
-> NormalizedUri -> LspT () IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
docUri) ExceptT
  (Text, LSPErrorCodes |? ErrorCodes)
  (LspT () IO)
  (Maybe VirtualFile)
-> (Maybe VirtualFile
    -> ExceptT
         (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) VirtualFile)
-> ExceptT
     (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) VirtualFile
forall a b.
ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
-> (a
    -> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) b)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe VirtualFile
Nothing ->
        (Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT
     (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) VirtualFile
forall a.
(Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          ( Text
"Could not find document specified in Command: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uri -> Text
forall a. Show a => a -> Text
showText Uri
docUri,
            ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams
          )
      Just VirtualFile
file -> VirtualFile
-> ExceptT
     (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) VirtualFile
forall a.
a -> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VirtualFile
file

  -- check the line
  let lineText = Rope -> Text
R.toText (Rope -> Text) -> (Rope -> Rope) -> Rope -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Rope -> Rope
R.getLine (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
line) (Rope -> Text) -> Rope -> Text
forall a b. (a -> b) -> a -> b
$ VirtualFile
file VirtualFile -> Getting Rope VirtualFile Rope -> Rope
forall s a. s -> Getting a s a -> a
^. Getting Rope VirtualFile Rope
forall s a. HasFile_text s a => Lens' s a
Lens' VirtualFile Rope
file_text
  expressionText <- case T.stripPrefix evalLensPrefix lineText of
    Maybe Text
Nothing ->
      (Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) Text
forall a.
(Text, LSPErrorCodes |? ErrorCodes)
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        ( Text
"Specified line does not contain an evaluation comment",
          ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams
        )
    Just Text
expression -> Text
-> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) Text
forall a.
a -> ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
expression

  currentVFS <- lift $ transformVFS <$> getVirtualFiles
  result <- liftIO $ performEvaluation currentVFS expressionText

  publishResult result $ file ^. file_text

  pure ()
  where
    publishResult :: (Either (Doc ann) (Doc ann), Seq (Doc ann)) -> Rope -> t m ()
publishResult (Either (Doc ann) (Doc ann)
result, Seq (Doc ann)
traces) Rope
fileRope =
      t m (LspId 'Method_WorkspaceApplyEdit) -> t m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (t m (LspId 'Method_WorkspaceApplyEdit) -> t m ())
-> (m (LspId 'Method_WorkspaceApplyEdit)
    -> t m (LspId 'Method_WorkspaceApplyEdit))
-> m (LspId 'Method_WorkspaceApplyEdit)
-> t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (LspId 'Method_WorkspaceApplyEdit)
-> t m (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (LspId 'Method_WorkspaceApplyEdit) -> t m ())
-> m (LspId 'Method_WorkspaceApplyEdit) -> t m ()
forall a b. (a -> b) -> a -> b
$
        SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> m ())
-> m (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams
MessageParams 'Method_WorkspaceApplyEdit
workSpaceEditParams ((Either
    (TResponseError 'Method_WorkspaceApplyEdit)
    (MessageResult 'Method_WorkspaceApplyEdit)
  -> m ())
 -> m (LspId 'Method_WorkspaceApplyEdit))
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> m ())
-> m (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$
          m ()
-> Either
     (TResponseError 'Method_WorkspaceApplyEdit)
     (MessageResult 'Method_WorkspaceApplyEdit)
-> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      where
        findResultLinesEnd :: Word -> Word
findResultLinesEnd Word
i
          -- don't override other eval comments
          | Text -> Text -> Bool
T.isPrefixOf Text
evalLensPrefix Text
commentLine =
              Word
i
          -- replace all output comments
          | Text -> Text -> Bool
T.isPrefixOf Text
"-- " Text
commentLine =
              Word -> Word
findResultLinesEnd (Word -> Word) -> Word -> Word
forall a b. (a -> b) -> a -> b
$ Word -> Word
forall a. Enum a => a -> a
succ Word
i
          -- stop otherwise
          | Bool
otherwise = Word
i
          where
            commentLine :: Text
commentLine = Rope -> Text
R.toText (Rope -> Text) -> Rope -> Text
forall a b. (a -> b) -> a -> b
$ Word -> Rope -> Rope
R.getLine Word
i Rope
fileRope
        insertText :: Text
insertText =
          -- TODO: configurable retained trace count
          let droppedTraceCount :: Int
droppedTraceCount = Seq (Doc ann) -> Int
forall a. Seq a -> Int
Seq.length Seq (Doc ann)
traces Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
100
              truncatedTraces :: Seq (Doc ann)
truncatedTraces =
                Int -> Seq (Doc ann) -> Seq (Doc ann)
forall a. Int -> Seq a -> Seq a
Seq.drop Int
droppedTraceCount Seq (Doc ann)
traces
                  Seq (Doc ann) -> (Seq (Doc ann) -> Seq (Doc ann)) -> Seq (Doc ann)
forall a b. a -> (a -> b) -> b
& if Int
droppedTraceCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                    then
                      ( Doc ann
"Hiding "
                          Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
droppedTraceCount
                          Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Int -> Doc ann
forall amount doc.
(Num amount, Eq amount) =>
doc -> doc -> amount -> doc
plural Doc ann
" trace" Doc ann
" traces" Int
droppedTraceCount
                          Doc ann -> Seq (Doc ann) -> Seq (Doc ann)
forall a. a -> Seq a -> Seq a
Seq.<|
                      )
                    else Seq (Doc ann) -> Seq (Doc ann)
forall a. a -> a
id
              allDocs :: Seq (Doc ann)
allDocs = Seq (Doc ann)
truncatedTraces Seq (Doc ann) -> Doc ann -> Seq (Doc ann)
forall a. Seq a -> a -> Seq a
:|> (Doc ann -> Doc ann)
-> (Doc ann -> Doc ann) -> Either (Doc ann) (Doc ann) -> Doc ann
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Doc ann -> Doc ann
forall a. a -> a
id Doc ann -> Doc ann
forall a. a -> a
id Either (Doc ann) (Doc ann)
result
              commentLines :: Text -> Text
commentLines =
                Text -> [Text]
T.lines
                  (Text -> [Text]) -> ([Text] -> Text) -> Text -> Text
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
                  ([Text] -> [Text]) -> ([Text] -> Text) -> [Text] -> Text
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Text] -> Text
T.unlines
           in Text -> Text
commentLines (Text -> Text) -> (Seq (Doc ann) -> Text) -> Seq (Doc ann) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Text
forall a. Doc a -> Text
docText (Doc ann -> Text)
-> (Seq (Doc ann) -> Doc ann) -> Seq (Doc ann) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann)
-> (Seq (Doc ann) -> [Doc ann]) -> Seq (Doc ann) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Doc ann) -> [Doc ann]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Doc ann) -> Text) -> Seq (Doc ann) -> Text
forall a b. (a -> b) -> a -> b
$ Seq (Doc ann)
allDocs
        insertResultEdit :: TextEdit
insertResultEdit =
          TextEdit
            { _newText :: Text
_newText = Text
insertText,
              _range :: Range
_range =
                Range
                  { _start :: Position
_start =
                      Position
                        { _character :: UInt
_character = UInt
0,
                          -- insert below the evaluation comment
                          _line :: UInt
_line = UInt
line UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1
                        },
                    _end :: Position
_end =
                      Position
                        { _line :: UInt
_line =
                            -- replace the entire comment range
                            -- removes any previous results
                            Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                              (Word -> UInt) -> (UInt -> Word) -> UInt -> UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
findResultLinesEnd
                              (Word -> Word) -> (UInt -> Word) -> UInt -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
forall a. Enum a => a -> a
succ
                              (Word -> Word) -> (UInt -> Word) -> UInt -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                              (UInt -> UInt) -> UInt -> UInt
forall a b. (a -> b) -> a -> b
$ UInt
line,
                          _character :: UInt
_character = UInt
0
                        }
                  }
            }
        workSpaceEditParams :: ApplyWorkspaceEditParams
workSpaceEditParams =
          ApplyWorkspaceEditParams
            { _label :: Maybe Text
_label = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Insert result of code lens evaluation",
              _edit :: WorkspaceEdit
_edit =
                WorkspaceEdit
                  { _documentChanges :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges = Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing,
                    _changeAnnotations :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changeAnnotations = Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing,
                    _changes :: Maybe (Map Uri [TextEdit])
_changes = Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
M.singleton Uri
docUri [TextEdit
insertResultEdit]
                  }
            }

    performEvaluation ::
      VFS ->
      Text ->
      IO (Either (Doc AnsiStyle) (Doc AnsiStyle), Seq (Doc AnsiStyle))
    performEvaluation :: Map String Text
-> Text
-> IO (Either (Doc AnsiStyle) (Doc AnsiStyle), Seq (Doc AnsiStyle))
performEvaluation Map String Text
currentVFS Text
expressionText = do
      resultVar <- IO (MVar (Either (Doc AnsiStyle) (Doc AnsiStyle)))
forall a. IO (MVar a)
newEmptyMVar
      traceRef <- newIORef Seq.empty
      _evaluationTid <- forkIO $ putMVar resultVar =<< evaluationAction traceRef
      (,) <$> takeMVar resultVar <*> readIORef traceRef
      where
        setupLimits :: IO ()
setupLimits = do
          -- I was unable to trigger the timeout with a lower limit at all
          Int64 -> IO ()
setAllocationCounter Int64
100_000_000_000
          IO ()
enableAllocationLimit

        evaluationAction ::
          IORef (Seq (Doc AnsiStyle)) ->
          IO (Either (Doc AnsiStyle) (Doc AnsiStyle))
        evaluationAction :: IORef (Seq (Doc AnsiStyle))
-> IO (Either (Doc AnsiStyle) (Doc AnsiStyle))
evaluationAction IORef (Seq (Doc AnsiStyle))
traceRef = EvalRecordRef (Doc AnsiStyle)
-> IO (Either (Doc AnsiStyle) (Doc AnsiStyle))
forall {b}. EvalRecordRef b -> IO (Either (Doc AnsiStyle) b)
interpret (EvalRecordRef (Doc AnsiStyle)
 -> IO (Either (Doc AnsiStyle) (Doc AnsiStyle)))
-> EvalRecordRef (Doc AnsiStyle)
-> IO (Either (Doc AnsiStyle) (Doc AnsiStyle))
forall a b. (a -> b) -> a -> b
$ do
          -- do not print warnings, no file
          let filePath :: Maybe String
filePath =
                Uri -> NormalizedUri
toNormalizedUri Uri
docUri
                  NormalizedUri
-> (NormalizedUri -> Maybe NormalizedFilePath)
-> Maybe NormalizedFilePath
forall a b. a -> (a -> b) -> b
& NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath
                  Maybe NormalizedFilePath
-> (Maybe NormalizedFilePath -> Maybe String) -> Maybe String
forall a b. a -> (a -> b) -> b
& (NormalizedFilePath -> String)
-> Maybe NormalizedFilePath -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NormalizedFilePath -> String
fromNormalizedFilePath
          let evalConfig' :: EvalConfig
evalConfig' = EvalConfig
evalConfig {evalPrintWarnings = False, evalFile = filePath}

          -- load the file the expression is located in
          interpreterState <-
            EvalConfig
-> Map String Text
-> EvalRecordRef (Either (Doc AnsiStyle) InterpreterState)
forall (m :: * -> *).
(MonadIO m, Evaluation m) =>
EvalConfig
-> Map String Text -> m (Either (Doc AnsiStyle) InterpreterState)
newInterpreterState EvalConfig
evalConfig' Map String Text
currentVFS
              EvalRecordRef (Either (Doc AnsiStyle) InterpreterState)
-> (Either (Doc AnsiStyle) InterpreterState
    -> EvalRecordRef InterpreterState)
-> EvalRecordRef InterpreterState
forall a b.
EvalRecordRef a -> (a -> EvalRecordRef b) -> EvalRecordRef b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Doc AnsiStyle -> EvalRecordRef InterpreterState)
-> (InterpreterState -> EvalRecordRef InterpreterState)
-> Either (Doc AnsiStyle) InterpreterState
-> EvalRecordRef InterpreterState
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Doc AnsiStyle -> EvalRecordRef InterpreterState
forall b. Doc AnsiStyle -> EvalRecordRef b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort InterpreterState -> EvalRecordRef InterpreterState
forall a. a -> EvalRecordRef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

          liftIO setupLimits

          runExpr interpreterState expressionText
          where
            -- TODO: Configurable allocation limit
            handleOom :: AllocationLimitExceeded -> f (Either a b)
handleOom AllocationLimitExceeded
AllocationLimitExceeded =
              Either a b -> f (Either a b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a b
forall a b. a -> Either a b
Left a
"Computation ran out of memory")

            -- TODO: Configurable timeout
            handleTimeout :: IO (Either a b) -> IO (Either a b)
handleTimeout IO (Either a b)
action =
              Int -> IO (Either a b) -> IO (Maybe (Either a b))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeoutMilliseconds IO (Either a b)
action
                IO (Maybe (Either a b))
-> (IO (Maybe (Either a b)) -> IO (Either a b)) -> IO (Either a b)
forall a b. a -> (a -> b) -> b
& (Maybe (Either a b) -> Either a b)
-> IO (Maybe (Either a b)) -> IO (Either a b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either a b -> Maybe (Either a b) -> Either a b
forall a. a -> Maybe a -> a
fromMaybe (a -> Either a b
forall a b. a -> Either a b
Left a
"Computation ran out of time"))
              where
                timeoutMilliseconds :: Int
timeoutMilliseconds = Int
15 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
6 :: Int)

            interpret :: EvalRecordRef b -> IO (Either (Doc AnsiStyle) b)
interpret =
              (AllocationLimitExceeded -> IO (Either (Doc AnsiStyle) b))
-> IO (Either (Doc AnsiStyle) b) -> IO (Either (Doc AnsiStyle) b)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle AllocationLimitExceeded -> IO (Either (Doc AnsiStyle) b)
forall {f :: * -> *} {a} {b}.
(Applicative f, IsString a) =>
AllocationLimitExceeded -> f (Either a b)
handleOom (IO (Either (Doc AnsiStyle) b) -> IO (Either (Doc AnsiStyle) b))
-> (EvalRecordRef b -> IO (Either (Doc AnsiStyle) b))
-> EvalRecordRef b
-> IO (Either (Doc AnsiStyle) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (Doc AnsiStyle) b) -> IO (Either (Doc AnsiStyle) b)
forall {a} {b}. IsString a => IO (Either a b) -> IO (Either a b)
handleTimeout (IO (Either (Doc AnsiStyle) b) -> IO (Either (Doc AnsiStyle) b))
-> (EvalRecordRef b -> IO (Either (Doc AnsiStyle) b))
-> EvalRecordRef b
-> IO (Either (Doc AnsiStyle) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Seq (Doc AnsiStyle))
-> EvalRecordRef b -> IO (Either (Doc AnsiStyle) b)
forall a.
IORef (Seq (Doc AnsiStyle))
-> EvalRecordRef a -> IO (Either (Doc AnsiStyle) a)
runEvalRecordRef IORef (Seq (Doc AnsiStyle))
traceRef