{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP           #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE RecordWildCards     #-}

module Language.Rzk.VSCode.Handlers (
  typecheckFromConfigFile,
  provideCompletions,
  provideSymbols,
  provideWorkspaceSymbols,
  findDefinition,
  findReferences,
  provideHover,
  formatSignature,
  formatDocument,
  provideSemanticTokens,
  useSiteTokens,
  handleFilesChanged,
) where

import           Control.Applicative           ((<|>))
import           Control.Exception             (SomeAsyncException (..),
                                                SomeException, evaluate,
                                                fromException, throwIO, try)
import           Control.Lens
import           Control.Monad                 (forM, forM_, unless, when)
import           Control.Monad.Except          (ExceptT (ExceptT),
                                                MonadError (throwError),
                                                modifyError, runExceptT)
import           Control.Monad.IO.Class        (MonadIO (..))
import           Data.Default.Class
import           Data.List                     (find, intercalate, isSuffixOf,
                                                nub, sort, (\\))
import qualified Data.Map.Strict               as Map
import           Data.Maybe                    (fromMaybe, isNothing)
import qualified Data.Text                     as T
import qualified Data.Yaml                     as Yaml
import           Language.LSP.Diagnostics      (partitionBySource)
import           Language.LSP.Protocol.Lens    (HasContext (context),
                                                HasDetail (detail),
                                                HasDocumentation (documentation),
                                                HasKind (kind),
                                                HasLabel (label),
                                                HasParams (params),
                                                HasPosition (position),
                                                HasQuery (query),
                                                HasTextDocument (textDocument),
                                                HasUri (uri), changes, uri)
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Types as LSP
import           Language.LSP.Server
import           Language.LSP.VFS              (virtualFileText)
import           System.FilePath               (makeRelative, (</>))
import           System.FilePath.Glob          (compile, globDir)

import           Data.Char                     (isDigit)
import           Language.Rzk.Foil.Names       (RzkPosition (RzkPosition),
                                                VarIdent (getVarIdent))
import           Language.Rzk.Syntax           (Module, Term,
                                                Term' (ASCII_TypeFun, TypeFun),
                                                VarIdent' (VarIdent),
                                                parseModuleFile,
                                                parseModuleSafe, printTree)
import qualified Language.Rzk.VSCode.Config    as RzkConfig
import           Language.Rzk.VSCode.Env
import qualified Language.Rzk.VSCode.PositionEncoding as Enc
import qualified Language.Rzk.VSCode.ReferenceIndex as RefInd
import           Language.Rzk.VSCode.Logging
import           Language.Rzk.VSCode.Tokenize  (mergeTokens, tokenizeModule,
                                                tokenizeSyntaxSymbols)
import qualified Rzk.Diagnostic                as Diag
import qualified Rzk.Format                    as Fmt
import           Rzk.Project.Config            (ProjectConfig (include))
import           Rzk.TypeCheck
import           Text.Read                     (readMaybe)

-- | Like 'try', but re-throws asynchronous exceptions (a worker restart) and
-- 'ProgressCancelledException' (a client-side progress cancel; delivered by
-- 'Control.Concurrent.Async.cancelWith', so 'fromException' does not classify
-- it as asynchronous). Cancellation must abort the whole run instead of being
-- reported as a typechecker failure of the current module.
tryTypecheck :: IO a -> IO (Either SomeException a)
tryTypecheck :: forall a. IO a -> IO (Either SomeException a)
tryTypecheck IO a
action = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action IO (Either SomeException a)
-> (Either SomeException a -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left SomeException
e
    | Just (SomeAsyncException e
_) <- SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO (Either SomeException a)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
    | Just ProgressCancelledException
cancelled <- forall e. Exception e => SomeException -> Maybe e
fromException @ProgressCancelledException SomeException
e -> ProgressCancelledException -> IO (Either SomeException a)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ProgressCancelledException
cancelled
  Either SomeException a
result -> Either SomeException a -> IO (Either SomeException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException a
result

-- | Given a list of file paths, reads them and parses them as Rzk modules,
--   returning the same list of file paths but with the parsed module (or parse error)
parseFiles :: [FilePath] -> IO [(FilePath, Either T.Text Module)]
parseFiles :: [FilePath] -> IO [(FilePath, Either Text Module)]
parseFiles [] = [(FilePath, Either Text Module)]
-> IO [(FilePath, Either Text Module)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parseFiles (FilePath
x:[FilePath]
xs) = do
  errOrMod <- FilePath -> IO (Either Text Module)
parseModuleFile FilePath
x
  rest <- parseFiles xs
  return $ (x, errOrMod) : rest

-- | Given the list of possible modules returned by `parseFiles`, this segregates the errors
--   from the successfully parsed modules and returns them in separate lists so the errors
--   can be reported and the modules can be typechecked.
collectErrors :: [(FilePath, Either T.Text Module)] -> ([(FilePath, T.Text)], [(FilePath, Module)])
collectErrors :: [(FilePath, Either Text Module)]
-> ([(FilePath, Text)], [(FilePath, Module)])
collectErrors [] = ([], [])
collectErrors ((FilePath
path, Either Text Module
result) : [(FilePath, Either Text Module)]
paths) =
  case Either Text Module
result of
    Left Text
err      -> ((FilePath
path, Text
err) (FilePath, Text) -> [(FilePath, Text)] -> [(FilePath, Text)]
forall a. a -> [a] -> [a]
: [(FilePath, Text)]
errors, [])
    Right Module
module_ -> ([(FilePath, Text)]
errors, (FilePath
path, Module
module_) (FilePath, Module) -> [(FilePath, Module)] -> [(FilePath, Module)]
forall a. a -> [a] -> [a]
: [(FilePath, Module)]
modules)
  where
    ([(FilePath, Text)]
errors, [(FilePath, Module)]
modules) = [(FilePath, Either Text Module)]
-> ([(FilePath, Text)], [(FilePath, Module)])
collectErrors [(FilePath, Either Text Module)]
paths

-- | The maximum number of diagnostic messages to send to the client
maxDiagnosticCount :: Int
maxDiagnosticCount :: Int
maxDiagnosticCount = Int
100

filePathToNormalizedUri :: FilePath -> NormalizedUri
filePathToNormalizedUri :: FilePath -> NormalizedUri
filePathToNormalizedUri = Uri -> NormalizedUri
toNormalizedUri (Uri -> NormalizedUri)
-> (FilePath -> Uri) -> FilePath -> NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Uri
filePathToUri

tshow :: Show a => a -> T.Text
tshow :: forall a. Show a => a -> Text
tshow = FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

fromLspUri :: LSP.Uri -> RefInd.Uri
fromLspUri :: Uri -> Uri
fromLspUri Uri
u = RefInd.Uri { uriPath :: FilePath
uriPath = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Uri -> Maybe FilePath
uriToFilePath Uri
u) }

toLspUri :: RefInd.Uri -> LSP.Uri
toLspUri :: Uri -> Uri
toLspUri (RefInd.Uri { uriPath :: Uri -> FilePath
uriPath = FilePath
p }) = FilePath -> Uri
filePathToUri FilePath
p

-- | The astral-line map of a file, for position conversion at the LSP
-- boundary (see "Language.Rzk.VSCode.PositionEncoding"): from the editor
-- buffer when the file is open, from disk otherwise. A file that cannot be
-- read converts as all-BMP, i.e. the conversion is the identity.
astralLinesOfFile :: FilePath -> LSP Enc.AstralLines
astralLinesOfFile :: FilePath -> LSP AstralLines
astralLinesOfFile = (Text -> AstralLines)
-> LspT ServerConfig (ReaderT RzkEnv IO) Text -> LSP AstralLines
forall a b.
(a -> b)
-> LspT ServerConfig (ReaderT RzkEnv IO) a
-> LspT ServerConfig (ReaderT RzkEnv IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> AstralLines
Enc.astralLines (LspT ServerConfig (ReaderT RzkEnv IO) Text -> LSP AstralLines)
-> (FilePath -> LspT ServerConfig (ReaderT RzkEnv IO) Text)
-> FilePath
-> LSP AstralLines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> LspT ServerConfig (ReaderT RzkEnv IO) Text
sourceOfFile

-- | The text of a file as the client sees it: from the editor buffer when the
-- file is open, from disk otherwise. A file that cannot be read is empty.
sourceOfFile :: FilePath -> LSP T.Text
sourceOfFile :: FilePath -> LspT ServerConfig (ReaderT RzkEnv IO) Text
sourceOfFile FilePath
path = do
  mdoc <- NormalizedUri
-> LspT ServerConfig (ReaderT RzkEnv IO) (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (FilePath -> NormalizedUri
filePathToNormalizedUri FilePath
path)
  case virtualFileText <$> mdoc of
    Just Text
text -> Text -> LspT ServerConfig (ReaderT RzkEnv IO) Text
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Text
text)
    Maybe Text
Nothing -> IO Text -> LspT ServerConfig (ReaderT RzkEnv IO) Text
forall a. IO a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> LspT ServerConfig (ReaderT RzkEnv IO) Text)
-> IO Text -> LspT ServerConfig (ReaderT RzkEnv IO) Text
forall a b. (a -> b) -> a -> b
$ do
      result <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (FilePath -> IO FilePath
readFile FilePath
path)
      return $ case result of
        Left SomeException
_    -> Text
""
        Right FilePath
src -> (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (FilePath -> Text
T.pack FilePath
src)

-- | The lines of a document, by 0-based line number, for reading the token a
-- diagnostic marks.
newtype SourceLines = SourceLines (Map.Map Int T.Text)

sourceLinesOf :: T.Text -> SourceLines
sourceLinesOf :: Text -> SourceLines
sourceLinesOf Text
src = Map Int Text -> SourceLines
SourceLines ([(Int, Text)] -> Map Int Text
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Text -> [Text]
T.lines Text
src)))

-- | A line outside the document is empty, as is one in a file that could not be
-- read; a marking there falls back to a single character.
lineOf :: SourceLines -> Int -> T.Text
lineOf :: SourceLines -> Int -> Text
lineOf (SourceLines Map Int Text
ls) Int
line = Text -> Int -> Map Int Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Text
"" Int
line Map Int Text
ls

fromLspPosition :: Enc.AstralLines -> LSP.Position -> RefInd.Position
fromLspPosition :: AstralLines -> Position -> Position
fromLspPosition AstralLines
als (LSP.Position UInt
l UInt
c) =
  Int -> Int -> Position
RefInd.Position (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l)
    (AstralLines -> Int -> Int -> Int
Enc.colFromUtf16 AstralLines
als (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
c))

toLspPosition :: Enc.AstralLines -> RefInd.Position -> LSP.Position
toLspPosition :: AstralLines -> Position -> Position
toLspPosition AstralLines
als (RefInd.Position Int
l Int
c) =
  UInt -> UInt -> Position
LSP.Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
    (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AstralLines -> Int -> Int -> Int
Enc.colToUtf16 AstralLines
als Int
l Int
c))

toLspRange :: Enc.AstralLines -> RefInd.Range -> Range
toLspRange :: AstralLines -> Range -> Range
toLspRange AstralLines
als (RefInd.Range Position
s Position
e) =
  Position -> Position -> Range
Range (AstralLines -> Position -> Position
toLspPosition AstralLines
als Position
s) (AstralLines -> Position -> Position
toLspPosition AstralLines
als Position
e)

-- | Convert locations to LSP, fetching the astral-line map once per file.
toLspLocations :: [RefInd.Location] -> LSP [LSP.Location]
toLspLocations :: [Location] -> LSP [Location]
toLspLocations [Location]
locations = do
  let files :: [FilePath]
files = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ((Location -> FilePath) -> [Location] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Location -> FilePath
RefInd.locationPath [Location]
locations)
  alss <- [(FilePath, AstralLines)] -> Map FilePath AstralLines
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, AstralLines)] -> Map FilePath AstralLines)
-> LspT ServerConfig (ReaderT RzkEnv IO) [(FilePath, AstralLines)]
-> LspT ServerConfig (ReaderT RzkEnv IO) (Map FilePath AstralLines)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
-> (FilePath
    -> LspT ServerConfig (ReaderT RzkEnv IO) (FilePath, AstralLines))
-> LspT ServerConfig (ReaderT RzkEnv IO) [(FilePath, AstralLines)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
files (\FilePath
f -> (,) FilePath
f (AstralLines -> (FilePath, AstralLines))
-> LSP AstralLines
-> LspT ServerConfig (ReaderT RzkEnv IO) (FilePath, AstralLines)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> LSP AstralLines
astralLinesOfFile FilePath
f)
  return
    [ LSP.Location (toLspUri u) (toLspRange als r)
    | RefInd.Location u r <- locations
    , Just als <- [Map.lookup (RefInd.uriPath u) alss]
    ]

toLspLocation :: RefInd.Location -> LSP LSP.Location
toLspLocation :: Location -> LSP Location
toLspLocation (RefInd.Location Uri
u Range
r) = do
  als <- FilePath -> LSP AstralLines
astralLinesOfFile (Uri -> FilePath
RefInd.uriPath Uri
u)
  return (LSP.Location (toLspUri u) (toLspRange als r))

typecheckFromConfigFile :: LSP ()
typecheckFromConfigFile :: LSP ()
typecheckFromConfigFile = do
  Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logInfo Text
"Looking for rzk.yaml"
  root <- LspT ServerConfig (ReaderT RzkEnv IO) (Maybe FilePath)
forall config (m :: * -> *).
MonadLsp config m =>
m (Maybe FilePath)
getRootPath
  case root of
    Maybe FilePath
Nothing -> do
      Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logWarning Text
"Workspace has no root path, cannot find rzk.yaml"
      SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> LSP ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
MessageType_Warning Text
"Cannot find the workspace root")
    Just FilePath
rootPath -> do
      let rzkYamlPath :: FilePath
rzkYamlPath = FilePath
rootPath FilePath -> FilePath -> FilePath
</> FilePath
"rzk.yaml"
      eitherConfig <- IO (Either ParseException ProjectConfig)
-> LspT
     ServerConfig
     (ReaderT RzkEnv IO)
     (Either ParseException ProjectConfig)
forall a. IO a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseException ProjectConfig)
 -> LspT
      ServerConfig
      (ReaderT RzkEnv IO)
      (Either ParseException ProjectConfig))
-> IO (Either ParseException ProjectConfig)
-> LspT
     ServerConfig
     (ReaderT RzkEnv IO)
     (Either ParseException ProjectConfig)
forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither @ProjectConfig FilePath
rzkYamlPath
      case eitherConfig of
        Left ParseException
err -> do
          Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logError (Text
"Invalid or missing rzk.yaml: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ParseException -> FilePath
Yaml.prettyPrintParseException ParseException
err))

        Right ProjectConfig
config -> do
          Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logDebug Text
"Starting typechecking"
          rawPaths <- IO [[FilePath]]
-> LspT ServerConfig (ReaderT RzkEnv IO) [[FilePath]]
forall a. IO a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[FilePath]]
 -> LspT ServerConfig (ReaderT RzkEnv IO) [[FilePath]])
-> IO [[FilePath]]
-> LspT ServerConfig (ReaderT RzkEnv IO) [[FilePath]]
forall a b. (a -> b) -> a -> b
$ [Pattern] -> FilePath -> IO [[FilePath]]
globDir ((FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Pattern
compile (ProjectConfig -> [FilePath]
include ProjectConfig
config)) FilePath
rootPath
          let paths = ([FilePath] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [[FilePath]]
rawPaths

          cachedModules <- getCachedTypecheckedModules
          let cachedPaths = ((FilePath, RzkCachedModule) -> FilePath)
-> RzkTypecheckCache -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, RzkCachedModule) -> FilePath
forall a b. (a, b) -> a
fst RzkTypecheckCache
cachedModules
              modifiedFiles = [FilePath]
paths [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath]
cachedPaths

          logDebug ("Found " <> tshow (length cachedPaths) <> " files in the cache")
          logDebug (tshow (length modifiedFiles) <> " files have been modified")

          (parseErrors, parsedModules) <- liftIO $ collectErrors <$> parseFiles modifiedFiles

          -- Report parse errors to the client
          forM_ parseErrors $ \(FilePath
path, Text
err) -> do
            als <- FilePath -> LSP AstralLines
astralLinesOfFile FilePath
path
            publishDiagnostics maxDiagnosticCount (filePathToNormalizedUri path) Nothing (partitionBySource [diagnosticOfParseError als err])

          -- Files after the first parse error are not typechecked at all
          -- ('collectErrors' stops collecting modules there); mark the ones
          -- without a parse error of their own as blocked.
          case parseErrors of
            [] -> () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (FilePath
blockingPath, Text
_) : [(FilePath, Text)]
_ -> do
              let reported :: [FilePath]
reported = ((FilePath, Module) -> FilePath)
-> [(FilePath, Module)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Module) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Module)]
parsedModules [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> ((FilePath, Text) -> FilePath) -> [(FilePath, Text)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Text) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Text)]
parseErrors
              FilePath -> FilePath -> [FilePath] -> LSP ()
publishBlockedDiagnostics FilePath
rootPath FilePath
blockingPath
                ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath]
reported) [FilePath]
modifiedFiles)

          -- Typecheck the modified modules one at a time on top of the cached
          -- prefix, reporting progress to the client. Each module is cached
          -- and its diagnostics are published as soon as it is checked, so a
          -- cancelled run keeps the modules it has finished and the next run
          -- continues from there.
          unless (null parsedModules) $
            withProgress "rzk typechecking" Nothing Cancellable $ \ProgressAmount -> LSP ()
reportProgress ->
              (ProgressAmount -> LSP ())
-> FilePath -> RzkTypecheckCache -> [(FilePath, Module)] -> LSP ()
checkModulesInProject ProgressAmount -> LSP ()
reportProgress FilePath
rootPath RzkTypecheckCache
cachedModules [(FilePath, Module)]
parsedModules
  where
    checkModulesInProject
      :: (ProgressAmount -> LSP ())
      -> FilePath                -- ^ Workspace root (for progress messages).
      -> RzkTypecheckCache       -- ^ Cached results for the unchanged prefix.
      -> [(FilePath, Module)]    -- ^ Modified modules, in project order.
      -> LSP ()
    checkModulesInProject :: (ProgressAmount -> LSP ())
-> FilePath -> RzkTypecheckCache -> [(FilePath, Module)] -> LSP ()
checkModulesInProject ProgressAmount -> LSP ()
reportProgress FilePath
rootPath RzkTypecheckCache
cache [(FilePath, Module)]
modules = Int -> RzkTypecheckCache -> [(FilePath, Module)] -> LSP ()
go (Int
0 :: Int) RzkTypecheckCache
cache [(FilePath, Module)]
modules
      where
        total :: Int
total = [(FilePath, Module)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FilePath, Module)]
modules

        go :: Int -> RzkTypecheckCache -> [(FilePath, Module)] -> LSP ()
go Int
_ RzkTypecheckCache
_ [] = () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go Int
i RzkTypecheckCache
checked ((FilePath
path, Module
module_) : [(FilePath, Module)]
rest) = do
          ProgressAmount -> LSP ()
reportProgress (Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount
            (UInt -> Maybe UInt
forall a. a -> Maybe a
Just (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
total)))
            (Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack (FilePath -> FilePath -> FilePath
makeRelative FilePath
rootPath FilePath
path))))
          -- Run in lenient hole mode so holes are collected (and surfaced as
          -- hints) rather than reported as errors while editing.
          -- Resume from the context of the last module that is still cached: it
          -- /is/ the elaborated prefix, so nothing is replayed or re-elaborated.
          let prefix :: Checked
prefix = case RzkTypecheckCache -> RzkTypecheckCache
forall a. [a] -> [a]
reverse RzkTypecheckCache
checked of
                (FilePath
_, RzkCachedModule
entry) : RzkTypecheckCache
_ -> RzkCachedModule -> Checked
cachedModuleChecked RzkCachedModule
entry
                []             -> Checked
emptyCheckedWithHoles
          tcResult <- IO
  (Either
     SomeException
     (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
-> LspT
     ServerConfig
     (ReaderT RzkEnv IO)
     (Either
        SomeException
        (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
forall a. IO a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      SomeException
      (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
 -> LspT
      ServerConfig
      (ReaderT RzkEnv IO)
      (Either
         SomeException
         (Either TypeErrorInScopedContext (Checked, [HoleInfo]))))
-> IO
     (Either
        SomeException
        (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
-> LspT
     ServerConfig
     (ReaderT RzkEnv IO)
     (Either
        SomeException
        (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
forall a b. (a -> b) -> a -> b
$ IO (Either TypeErrorInScopedContext (Checked, [HoleInfo]))
-> IO
     (Either
        SomeException
        (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
forall a. IO a -> IO (Either SomeException a)
tryTypecheck (IO (Either TypeErrorInScopedContext (Checked, [HoleInfo]))
 -> IO
      (Either
         SomeException
         (Either TypeErrorInScopedContext (Checked, [HoleInfo]))))
-> IO (Either TypeErrorInScopedContext (Checked, [HoleInfo]))
-> IO
     (Either
        SomeException
        (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
forall a b. (a -> b) -> a -> b
$ Either TypeErrorInScopedContext (Checked, [HoleInfo])
-> IO (Either TypeErrorInScopedContext (Checked, [HoleInfo]))
forall a. a -> IO a
evaluate (Either TypeErrorInScopedContext (Checked, [HoleInfo])
 -> IO (Either TypeErrorInScopedContext (Checked, [HoleInfo])))
-> Either TypeErrorInScopedContext (Checked, [HoleInfo])
-> IO (Either TypeErrorInScopedContext (Checked, [HoleInfo]))
forall a b. (a -> b) -> a -> b
$
            Checked
-> [(FilePath, Module)]
-> Either TypeErrorInScopedContext (Checked, [HoleInfo])
recheckFrom Checked
prefix [(FilePath
path, Module
module_)]
          case tcResult of
            Left (SomeException
ex :: SomeException) -> do
              -- Just a warning to be logged in the "Output" panel and not shown to the user as an error message
              --  because exceptions are expected when the file has invalid syntax
              Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logWarning (Text
"Encountered an exception while typechecking:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
ex)
              FilePath -> FilePath -> [FilePath] -> LSP ()
publishBlockedDiagnostics FilePath
rootPath FilePath
path (((FilePath, Module) -> FilePath)
-> [(FilePath, Module)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Module) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Module)]
rest)
            Right (Left TypeErrorInScopedContext
err) -> do
              Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logError (Text
"An impossible error happened! Please report a bug:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (OutputDirection -> TypeErrorInScopedContext -> FilePath
ppTypeErrorInScopedContext OutputDirection
BottomUp TypeErrorInScopedContext
err))
              FilePath
-> [TypeErrorInScopedContext]
-> [CheckWarning]
-> [HoleInfo]
-> LSP ()
publishModuleDiagnostics FilePath
path [TypeErrorInScopedContext
err] [] []    -- sort of impossible
              FilePath -> FilePath -> [FilePath] -> LSP ()
publishBlockedDiagnostics FilePath
rootPath FilePath
path (((FilePath, Module) -> FilePath)
-> [(FilePath, Module)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Module) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Module)]
rest)
            Right (Right (Checked
checkedNow, [HoleInfo]
holeInfos)) -> do
              let errors :: [TypeErrorInScopedContext]
errors = Checked -> [TypeErrorInScopedContext]
checkedErrors Checked
checkedNow
              Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logDebug (FilePath -> Text
T.pack FilePath
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([TypeErrorInScopedContext] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeErrorInScopedContext]
errors) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" errors, "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([HoleInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HoleInfo]
holeInfos) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" holes")
              let decls :: [DeclView]
decls = [DeclView] -> Maybe [DeclView] -> [DeclView]
forall a. a -> Maybe a -> a
fromMaybe [] (FilePath -> [(FilePath, [DeclView])] -> Maybe [DeclView]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
path (Checked -> [(FilePath, [DeclView])]
declViews Checked
checkedNow))
                  checked' :: RzkTypecheckCache
checked' = RzkTypecheckCache
checked RzkTypecheckCache -> RzkTypecheckCache -> RzkTypecheckCache
forall a. [a] -> [a] -> [a]
++
                    [(FilePath
path, Checked
-> [DeclView] -> [TypeErrorInScopedContext] -> RzkCachedModule
RzkCachedModule Checked
checkedNow [DeclView]
decls
                        ((TypeErrorInScopedContext -> Bool)
-> [TypeErrorInScopedContext] -> [TypeErrorInScopedContext]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
path) (FilePath -> Bool)
-> (TypeErrorInScopedContext -> FilePath)
-> TypeErrorInScopedContext
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeErrorInScopedContext -> FilePath
filepathOfTypeError) [TypeErrorInScopedContext]
errors))]
              RzkTypecheckCache -> LSP ()
cacheTypecheckedModules RzkTypecheckCache
checked'
              FilePath
-> [TypeErrorInScopedContext]
-> [CheckWarning]
-> [HoleInfo]
-> LSP ()
publishModuleDiagnostics FilePath
path [TypeErrorInScopedContext]
errors (Checked -> [CheckWarning]
checkedWarnings Checked
checkedNow) [HoleInfo]
holeInfos
              -- Stop at the first module with errors, like the batch checker
              -- ('typecheckModulesWithLocation'') does: later modules depend
              -- on this one and would report cascading errors. Mark the
              -- modules this run will not reach.
              if [TypeErrorInScopedContext] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeErrorInScopedContext]
errors
                then Int -> RzkTypecheckCache -> [(FilePath, Module)] -> LSP ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) RzkTypecheckCache
checked' [(FilePath, Module)]
rest
                else FilePath -> FilePath -> [FilePath] -> LSP ()
publishBlockedDiagnostics FilePath
rootPath FilePath
path (((FilePath, Module) -> FilePath)
-> [(FilePath, Module)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Module) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Module)]
rest)

    -- Publish the diagnostics of one checked module, grouped by file so all
    -- diagnostics for a file are published in a single call
    -- (publishDiagnostics replaces a source's diagnostics per URI, so
    -- publishing them one at a time would clobber all but the last). The
    -- module's own file is always published, possibly with an empty list,
    -- replacing stale diagnostics from the previous run.
    --
    -- An empty list needs care: the lsp diagnostic store unions the new
    -- per-source map over the old one, and @partitionBySource []@ has no
    -- "rzk" key, so the old diagnostics would survive and be re-sent. A
    -- max count of 0 forces an empty publish to the client, clearing it.
    publishModuleDiagnostics :: FilePath -> [TypeErrorInScopedContext] -> [CheckWarning] -> [HoleInfo] -> LSP ()
    publishModuleDiagnostics :: FilePath
-> [TypeErrorInScopedContext]
-> [CheckWarning]
-> [HoleInfo]
-> LSP ()
publishModuleDiagnostics FilePath
path [TypeErrorInScopedContext]
typeErrors [CheckWarning]
warnings [HoleInfo]
holeInfos = do
      let errDiagnostics :: [(FilePath, [Diagnostic])]
errDiagnostics  = [ (TypeErrorInScopedContext -> FilePath
filepathOfTypeError TypeErrorInScopedContext
err, [OutputDirection -> TypeErrorInScopedContext -> Diagnostic
Diag.diagnoseTypeError OutputDirection
TopDown TypeErrorInScopedContext
err])
                            | TypeErrorInScopedContext
err <- [TypeErrorInScopedContext]
typeErrors ]
          warnDiagnostics :: [(FilePath, [Diagnostic])]
warnDiagnostics = [ (FilePath
path', [CheckWarning -> Diagnostic
Diag.diagnoseCheckWarning CheckWarning
warning])
                            | CheckWarning
warning <- [CheckWarning]
warnings
                            , let path' :: FilePath
path' = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
path
                                    (CheckWarning -> Maybe LocationInfo
warningLocation CheckWarning
warning Maybe LocationInfo
-> (LocationInfo -> Maybe FilePath) -> Maybe FilePath
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocationInfo -> Maybe FilePath
locationFilePath) ]
          holeDiagnostics :: [(FilePath, [Diagnostic])]
holeDiagnostics = [ (FilePath
path', [HoleInfo -> Diagnostic
Diag.diagnoseHole HoleInfo
hole])
                            | HoleInfo
hole <- [HoleInfo]
holeInfos
                            , Just FilePath
path' <- [HoleInfo -> Maybe LocationInfo
holeLocation HoleInfo
hole Maybe LocationInfo
-> (LocationInfo -> Maybe FilePath) -> Maybe FilePath
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocationInfo -> Maybe FilePath
locationFilePath] ]
          diagnosticsByFile :: Map FilePath [Diagnostic]
diagnosticsByFile = ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> FilePath
-> [Diagnostic]
-> Map FilePath [Diagnostic]
-> Map FilePath [Diagnostic]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. Semigroup a => a -> a -> a
(<>)) FilePath
path [] (Map FilePath [Diagnostic] -> Map FilePath [Diagnostic])
-> Map FilePath [Diagnostic] -> Map FilePath [Diagnostic]
forall a b. (a -> b) -> a -> b
$
            ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [(FilePath, [Diagnostic])] -> Map FilePath [Diagnostic]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. Semigroup a => a -> a -> a
(<>)) ([(FilePath, [Diagnostic])]
errDiagnostics [(FilePath, [Diagnostic])]
-> [(FilePath, [Diagnostic])] -> [(FilePath, [Diagnostic])]
forall a. Semigroup a => a -> a -> a
<> [(FilePath, [Diagnostic])]
warnDiagnostics [(FilePath, [Diagnostic])]
-> [(FilePath, [Diagnostic])] -> [(FilePath, [Diagnostic])]
forall a. Semigroup a => a -> a -> a
<> [(FilePath, [Diagnostic])]
holeDiagnostics)
      -- The source of each file with something to report, read once: a
      -- diagnostic marks the token it points at, and its column is converted
      -- to the UTF-16 the client counts in.
      [(FilePath, [Diagnostic])]
-> ((FilePath, [Diagnostic]) -> LSP ()) -> LSP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath [Diagnostic] -> [(FilePath, [Diagnostic])]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath [Diagnostic]
diagnosticsByFile) (((FilePath, [Diagnostic]) -> LSP ()) -> LSP ())
-> ((FilePath, [Diagnostic]) -> LSP ()) -> LSP ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
path', [Diagnostic]
diags) -> do
        lspDiags <- case [Diagnostic]
diags of
          [] -> [Diagnostic] -> LspT ServerConfig (ReaderT RzkEnv IO) [Diagnostic]
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          [Diagnostic]
_  -> do
            src <- FilePath -> LspT ServerConfig (ReaderT RzkEnv IO) Text
sourceOfFile FilePath
path'
            let als = Text -> AstralLines
Enc.astralLines Text
src
                sourceLines = Text -> SourceLines
sourceLinesOf Text
src
            return (map (lspDiagnosticOf als sourceLines) diags)
        publishDiagnostics (if null lspDiags then 0 else maxDiagnosticCount)
          (filePathToNormalizedUri path') Nothing (partitionBySource lspDiags)

    -- Modules that a run never reaches (they come after a module with an
    -- error, and every rzk module depends on all earlier ones) get a single
    -- warning diagnostic naming the blocker, instead of keeping whatever
    -- diagnostics a previous run left behind. Warning severity keeps the
    -- file visible in the explorer (yellow badge) while staying distinct
    -- from a real error in the file itself. It is replaced by real
    -- diagnostics once the blocker is fixed and the module is reached
    -- again.
    publishBlockedDiagnostics :: FilePath -> FilePath -> [FilePath] -> LSP ()
    publishBlockedDiagnostics :: FilePath -> FilePath -> [FilePath] -> LSP ()
publishBlockedDiagnostics FilePath
rootPath FilePath
blockingPath [FilePath]
notReached =
      [FilePath] -> (FilePath -> LSP ()) -> LSP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
notReached ((FilePath -> LSP ()) -> LSP ()) -> (FilePath -> LSP ()) -> LSP ()
forall a b. (a -> b) -> a -> b
$ \FilePath
path ->
        Int
-> NormalizedUri -> Maybe Int32 -> DiagnosticsBySource -> LSP ()
forall config (m :: * -> *).
MonadLsp config m =>
Int -> NormalizedUri -> Maybe Int32 -> DiagnosticsBySource -> m ()
publishDiagnostics Int
maxDiagnosticCount (FilePath -> NormalizedUri
filePathToNormalizedUri FilePath
path) Maybe Int32
forall a. Maybe a
Nothing
          ([Diagnostic] -> DiagnosticsBySource
partitionBySource [Diagnostic
blockedDiagnostic])
      where
        blockedDiagnostic :: Diagnostic
blockedDiagnostic = Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
Diagnostic
          (Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
99))
          (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Warning)
          ((Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just (Text -> Int32 |? Text
forall a b. b -> a |? b
InR Text
"not-checked"))
          Maybe CodeDescription
forall a. Maybe a
Nothing                   -- diagnostic description
          (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rzk")              -- A human-readable string describing the source of this diagnostic
          (Text
"Not checked: blocked by an error in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (FilePath -> FilePath -> FilePath
makeRelative FilePath
rootPath FilePath
blockingPath))
          Maybe [DiagnosticTag]
forall a. Maybe a
Nothing                   -- tags
          ([DiagnosticRelatedInformation]
-> Maybe [DiagnosticRelatedInformation]
forall a. a -> Maybe a
Just [])                 -- related information
          Maybe Value
forall a. Maybe a
Nothing                   -- data that is preserved between different calls

    filepathOfTypeError :: TypeErrorInScopedContext -> FilePath
    filepathOfTypeError :: TypeErrorInScopedContext -> FilePath
filepathOfTypeError (TypeErrorInScopedContext Context n
ctx TypeError n
_err) =
      case Context n -> Maybe LocationInfo
forall (n :: S). Context n -> Maybe LocationInfo
ctxLocation Context n
ctx Maybe LocationInfo
-> (LocationInfo -> Maybe FilePath) -> Maybe FilePath
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocationInfo -> Maybe FilePath
locationFilePath of
        Just FilePath
path -> FilePath
path
        Maybe FilePath
_         -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"the impossible happened! Please contact Abdelrahman immediately!!!"

    -- Map a structured library diagnostic to an LSP diagnostic, marking the
    -- term it is about in the given source.
    lspDiagnosticOf :: Enc.AstralLines -> SourceLines -> Diag.Diagnostic -> Diagnostic
    lspDiagnosticOf :: AstralLines -> SourceLines -> Diagnostic -> Diagnostic
lspDiagnosticOf AstralLines
als SourceLines
sourceLines Diagnostic
d = Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
Diagnostic
                      (AstralLines -> Range -> Range
Enc.rangeToUtf16 AstralLines
als (SourceLines -> Diagnostic -> Range
diagnosticRange SourceLines
sourceLines Diagnostic
d))
                      (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just (Severity -> DiagnosticSeverity
lspSeverity (Diagnostic -> Severity
Diag.diagnosticSeverity Diagnostic
d)))
                      ((Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just (Text -> Int32 |? Text
forall a b. b -> a |? b
InR (FilePath -> Text
T.pack (Diagnostic -> FilePath
Diag.diagnosticCode Diagnostic
d))))
                      Maybe CodeDescription
forall a. Maybe a
Nothing                   -- diagnostic description
                      (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rzk")              -- A human-readable string describing the source of this diagnostic
                      (FilePath -> Text
T.pack (Diagnostic -> FilePath
Diag.diagnosticMessage Diagnostic
d))
                      Maybe [DiagnosticTag]
forall a. Maybe a
Nothing                   -- tags
                      ([DiagnosticRelatedInformation]
-> Maybe [DiagnosticRelatedInformation]
forall a. a -> Maybe a
Just [])                 -- related information
                      Maybe Value
forall a. Maybe a
Nothing                   -- data that is preserved between different calls

    -- What the diagnostic marks: the token the term it is about starts with.
    --
    -- The checker knows where a term begins and not where it ends (the surface
    -- syntax records only the start of a node), so the marked span is the head
    -- token. That puts the squiggle on the right thing without claiming an
    -- extent that was never measured, and a hole is marked exactly, since @?@
    -- and @?name@ are the whole term. A diagnostic that has no column is about
    -- a whole declaration and still marks the line.
    diagnosticRange :: SourceLines -> Diag.Diagnostic -> Range
    diagnosticRange :: SourceLines -> Diagnostic -> Range
diagnosticRange SourceLines
sourceLines Diagnostic
d = case Diagnostic -> Maybe LocationInfo
Diag.diagnosticLocation Diagnostic
d of
      Just LocationInfo
loc
        | Just Int
lineNo <- LocationInfo -> Maybe Int
locationLine LocationInfo
loc
        , Just Int
col <- LocationInfo -> Maybe Int
locationColumn LocationInfo
loc
        , let line :: UInt
line = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)  -- LSP counts lines from 0
        , let start :: UInt
start = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)    -- and columns too
        -> Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
line UInt
start)
                 (UInt -> UInt -> Position
Position UInt
line (UInt
start UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ SourceLines -> UInt -> UInt -> UInt
tokenWidth SourceLines
sourceLines UInt
line UInt
start))
      Just LocationInfo
loc
        | Just Int
lineNo <- LocationInfo -> Maybe Int
locationLine LocationInfo
loc
        , let line :: UInt
line = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        -> Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
line UInt
0) (UInt -> UInt -> Position
Position UInt
line UInt
99) -- to the end of the line
      Maybe LocationInfo
_ -> Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
99)

    -- The width of the token starting at a position, in code points, and never
    -- zero: an empty marking shows nothing at all. A token that opens with a
    -- bracket or a separator is one character wide, since those delimit rather
    -- than name; anything else runs to the next space or delimiter.
    tokenWidth :: SourceLines -> UInt -> UInt -> UInt
    tokenWidth :: SourceLines -> UInt -> UInt -> UInt
tokenWidth SourceLines
sourceLines UInt
line UInt
start =
      case Int -> Text -> Text
T.drop (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
start) (SourceLines -> Int -> Text
lineOf SourceLines
sourceLines (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
line)) of
        Text
rest | Just (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
rest, Bool -> Bool
not (Char -> Bool
isDelimiter Char
c)
             -> UInt -> UInt -> UInt
forall a. Ord a => a -> a -> a
max UInt
1 (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length ((Char -> Bool) -> Text -> Text
T.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDelimiter) Text
rest)))
        Text
_    -> UInt
1
      where
        isDelimiter :: Char -> Bool
isDelimiter Char
c = Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
" \t()[]{},;" :: String)

    lspSeverity :: Diag.Severity -> DiagnosticSeverity
    lspSeverity :: Severity -> DiagnosticSeverity
lspSeverity = \case
      Severity
Diag.SeverityError       -> DiagnosticSeverity
DiagnosticSeverity_Error
      Severity
Diag.SeverityWarning     -> DiagnosticSeverity
DiagnosticSeverity_Warning
      Severity
Diag.SeverityInformation -> DiagnosticSeverity
DiagnosticSeverity_Information
      Severity
Diag.SeverityHint        -> DiagnosticSeverity
DiagnosticSeverity_Hint

    diagnosticOfParseError :: Enc.AstralLines -> T.Text -> Diagnostic
    diagnosticOfParseError :: AstralLines -> Text -> Diagnostic
diagnosticOfParseError AstralLines
als Text
err = Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
Diagnostic (AstralLines -> Range -> Range
Enc.rangeToUtf16 AstralLines
als (Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
errLine UInt
errColumnStart) (UInt -> UInt -> Position
Position UInt
errLine UInt
errColumnEnd)))
                      (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error)
                      ((Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just ((Int32 |? Text) -> Maybe (Int32 |? Text))
-> (Int32 |? Text) -> Maybe (Int32 |? Text)
forall a b. (a -> b) -> a -> b
$ Text -> Int32 |? Text
forall a b. b -> a |? b
InR Text
"parse-error")
                      Maybe CodeDescription
forall a. Maybe a
Nothing
                      (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rzk")
                      Text
err
                      Maybe [DiagnosticTag]
forall a. Maybe a
Nothing
                      ([DiagnosticRelatedInformation]
-> Maybe [DiagnosticRelatedInformation]
forall a. a -> Maybe a
Just [])
                      Maybe Value
forall a. Maybe a
Nothing
      where
        errStr :: FilePath
errStr = Text -> FilePath
T.unpack Text
err
        (UInt
errLine, UInt
errColumnStart, UInt
errColumnEnd) = (UInt, UInt, UInt)
-> Maybe (UInt, UInt, UInt) -> (UInt, UInt, UInt)
forall a. a -> Maybe a -> a
fromMaybe (UInt
0, UInt
0, UInt
0) (Maybe (UInt, UInt, UInt) -> (UInt, UInt, UInt))
-> Maybe (UInt, UInt, UInt) -> (UInt, UInt, UInt)
forall a b. (a -> b) -> a -> b
$
          case FilePath -> [FilePath]
words FilePath
errStr of
            -- Happy parse error
            (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
9 -> [FilePath
"syntax", FilePath
"error", FilePath
"at", FilePath
"line", FilePath
lineStr, FilePath
"column", FilePath
columnStr, FilePath
"before", FilePath
token]) -> do
              line <- FilePath -> Maybe UInt
forall a. Read a => FilePath -> Maybe a
readMaybe ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit FilePath
lineStr)
              columnStart <- readMaybe (takeWhile isDigit columnStr)
              return (line - 1, columnStart - 1, columnStart + fromIntegral (length token) - 3)
            -- Happy parse error due to lexer error
            (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
7 -> [FilePath
"syntax", FilePath
"error", FilePath
"at", FilePath
"line", FilePath
lineStr, FilePath
"column", FilePath
columnStr]) -> do
              line <- FilePath -> Maybe UInt
forall a. Read a => FilePath -> Maybe a
readMaybe ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit FilePath
lineStr)
              columnStart <- readMaybe (takeWhile isDigit columnStr)
              return (line - 1, columnStart - 1, columnStart - 1)
            -- BNFC layout resolver error
            (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
14 -> [FilePath
"Layout", FilePath
"error", FilePath
"at", FilePath
"line", FilePath
_lineStr, FilePath
"column", FilePath
_columnStr, FilePath
"found", FilePath
token, FilePath
"at", FilePath
"line", FilePath
lineStr', FilePath
"column", FilePath
columnStr']) -> do
              -- line <- readMaybe (takeWhile isDigit lineStr)
              -- columnStart <- readMaybe (takeWhile isDigit columnStr)
              line' <- FilePath -> Maybe UInt
forall a. Read a => FilePath -> Maybe a
readMaybe ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit FilePath
lineStr')
              columnStart' <- readMaybe (takeWhile isDigit columnStr')
              return (line' - 1, columnStart', columnStart' + fromIntegral (length token) - 2)
            [FilePath]
_ -> Maybe (UInt, UInt, UInt)
forall a. Maybe a
Nothing

instance Default T.Text where def :: Text
def = Text
""
instance Default CompletionItem
instance Default CompletionItemLabelDetails

provideCompletions :: Handler LSP 'Method_TextDocumentCompletion
provideCompletions :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentCompletion
provideCompletions TRequestMessage 'Method_TextDocumentCompletion
req Either
  (TResponseError 'Method_TextDocumentCompletion)
  ([CompletionItem] |? (CompletionList |? Null))
-> LSP ()
res = do
  Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logInfo Text
"Providing text completions"
  root <- LspT ServerConfig (ReaderT RzkEnv IO) (Maybe FilePath)
forall config (m :: * -> *).
MonadLsp config m =>
m (Maybe FilePath)
getRootPath
  when (isNothing root) $ logDebug "Not in a workspace. Cannot find root path for relative paths"
  let rootDir = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"/" Maybe FilePath
root
  cachedModules <- getCachedTypecheckedModules
  logDebug ("Found " <> tshow (length cachedModules) <> " modules in the cache")
  let currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe FilePath
uriToFilePath (Uri -> Maybe FilePath) -> Uri -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ TRequestMessage 'Method_TextDocumentCompletion
req TRequestMessage 'Method_TextDocumentCompletion
-> Getting Uri (TRequestMessage 'Method_TextDocumentCompletion) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Uri CompletionParams)
-> TRequestMessage 'Method_TextDocumentCompletion
-> Const Uri (TRequestMessage 'Method_TextDocumentCompletion)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentCompletion) CompletionParams
params ((CompletionParams -> Const Uri CompletionParams)
 -> TRequestMessage 'Method_TextDocumentCompletion
 -> Const Uri (TRequestMessage 'Method_TextDocumentCompletion))
-> ((Uri -> Const Uri Uri)
    -> CompletionParams -> Const Uri CompletionParams)
-> Getting Uri (TRequestMessage 'Method_TextDocumentCompletion) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CompletionParams -> Const Uri CompletionParams
forall s a. HasTextDocument s a => Lens' s a
Lens' CompletionParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> CompletionParams -> Const Uri CompletionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> CompletionParams
-> Const Uri CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
  -- Take all the modules up to and including the currently open one
  let modules = ((FilePath, RzkCachedModule) -> (FilePath, [DeclView]))
-> RzkTypecheckCache -> [(FilePath, [DeclView])]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, RzkCachedModule) -> (FilePath, [DeclView])
forall {a}. (a, RzkCachedModule) -> (a, [DeclView])
ignoreErrors (RzkTypecheckCache -> [(FilePath, [DeclView])])
-> RzkTypecheckCache -> [(FilePath, [DeclView])]
forall a b. (a -> b) -> a -> b
$ ((FilePath, RzkCachedModule) -> Bool)
-> RzkTypecheckCache -> RzkTypecheckCache
forall a. (a -> Bool) -> [a] -> [a]
takeWhileInc ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
currentFile) (FilePath -> Bool)
-> ((FilePath, RzkCachedModule) -> FilePath)
-> (FilePath, RzkCachedModule)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, RzkCachedModule) -> FilePath
forall a b. (a, b) -> a
fst) RzkTypecheckCache
cachedModules
        where
          ignoreErrors :: (a, RzkCachedModule) -> (a, [DeclView])
ignoreErrors (a
path, RzkCachedModule{[TypeErrorInScopedContext]
[DeclView]
Checked
cachedModuleChecked :: RzkCachedModule -> Checked
cachedModuleChecked :: Checked
cachedModuleDecls :: [DeclView]
cachedModuleErrors :: [TypeErrorInScopedContext]
cachedModuleErrors :: RzkCachedModule -> [TypeErrorInScopedContext]
cachedModuleDecls :: RzkCachedModule -> [DeclView]
..}) = (a
path, [DeclView]
cachedModuleDecls)
          takeWhileInc :: (a -> Bool) -> [a] -> [a]
takeWhileInc a -> Bool
_ [] = []
          takeWhileInc a -> Bool
p (a
x:[a]
xs)
            | a -> Bool
p a
x       = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
takeWhileInc a -> Bool
p [a]
xs
            | Bool
otherwise = [a
x]

  let items = ((FilePath, [DeclView]) -> [CompletionItem])
-> [(FilePath, [DeclView])] -> [CompletionItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath -> (FilePath, [DeclView]) -> [CompletionItem]
declsToItems FilePath
rootDir) [(FilePath, [DeclView])]
modules
  logDebug ("Sending " <> T.pack (show (length items)) <> " completion items")
  res $ Right $ InL items
  where
    declsToItems :: FilePath -> (FilePath, [DeclView]) -> [CompletionItem]
    declsToItems :: FilePath -> (FilePath, [DeclView]) -> [CompletionItem]
declsToItems FilePath
root (FilePath
path, [DeclView]
decls) = (DeclView -> CompletionItem) -> [DeclView] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> DeclView -> CompletionItem
declToItem FilePath
root FilePath
path) [DeclView]
decls
    declToItem :: FilePath -> FilePath -> DeclView -> CompletionItem
    declToItem :: FilePath -> FilePath -> DeclView -> CompletionItem
declToItem FilePath
rootDir FilePath
path (DeclView VarIdent
name Rendered
type' Bool
_ Maybe LocationInfo
_loc DeclKind
declKind) = CompletionItem
forall a. Default a => a
def

      CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text)
-> CompletionItem -> Identity CompletionItem
forall s a. HasLabel s a => Lens' s a
Lens' CompletionItem Text
label ((Text -> Identity Text)
 -> CompletionItem -> Identity CompletionItem)
-> Text -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FilePath -> Text
T.pack (VarIdent' RzkPosition -> FilePath
forall a. Print a => a -> FilePath
printTree (VarIdent' RzkPosition -> FilePath)
-> VarIdent' RzkPosition -> FilePath
forall a b. (a -> b) -> a -> b
$ VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name)
      CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe CompletionItemKind -> Identity (Maybe CompletionItemKind))
-> CompletionItem -> Identity CompletionItem
forall s a. HasKind s a => Lens' s a
Lens' CompletionItem (Maybe CompletionItemKind)
kind ((Maybe CompletionItemKind -> Identity (Maybe CompletionItemKind))
 -> CompletionItem -> Identity CompletionItem)
-> CompletionItemKind -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ DeclKind -> CompletionItemKind
completionKindOfDecl DeclKind
declKind
      CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> CompletionItem -> Identity CompletionItem
forall s a. HasDetail s a => Lens' s a
Lens' CompletionItem (Maybe Text)
detail ((Maybe Text -> Identity (Maybe Text))
 -> CompletionItem -> Identity CompletionItem)
-> Text -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ FilePath -> Text
T.pack (Rendered -> FilePath
forall a. Show a => a -> FilePath
show Rendered
type')
      CompletionItem
-> (CompletionItem -> CompletionItem) -> CompletionItem
forall a b. a -> (a -> b) -> b
& (Maybe (Text |? MarkupContent)
 -> Identity (Maybe (Text |? MarkupContent)))
-> CompletionItem -> Identity CompletionItem
forall s a. HasDocumentation s a => Lens' s a
Lens' CompletionItem (Maybe (Text |? MarkupContent))
documentation ((Maybe (Text |? MarkupContent)
  -> Identity (Maybe (Text |? MarkupContent)))
 -> CompletionItem -> Identity CompletionItem)
-> (Text |? MarkupContent) -> CompletionItem -> CompletionItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ MarkupContent -> Text |? MarkupContent
forall a b. b -> a |? b
InR (MarkupKind -> Text -> MarkupContent
MarkupContent MarkupKind
MarkupKind_Markdown (Text -> MarkupContent) -> Text -> MarkupContent
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
          FilePath
"---\nDefined" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
          (if Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then FilePath
" at line " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
line else FilePath
"")
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in *" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
makeRelative FilePath
rootDir FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"*")
      where
        (VarIdent RzkPosition
pos VarIdentToken
_) = VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name
        (RzkPosition Maybe FilePath
_path BNFC'Position
pos') = RzkPosition
pos
        line :: Int
line = Int -> ((Int, Int) -> Int) -> BNFC'Position -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int, Int) -> Int
forall a b. (a, b) -> a
fst BNFC'Position
pos'
        _col :: Int
_col = Int -> ((Int, Int) -> Int) -> BNFC'Position -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int, Int) -> Int
forall a b. (a, b) -> b
snd BNFC'Position
pos'

-- | Full-document range for LSP (0-based line and character).
--   End position is exclusive. Computed from the actual text so that every
--   character (including trailing newlines) is included; using T.lines would
--   drop trailing newlines and leave them in place after the edit (extra blank line).
fullDocumentRange :: T.Text -> Range
fullDocumentRange :: Text -> Range
fullDocumentRange Text
source
  | Text -> Bool
T.null Text
source = Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
0)
  | Bool
otherwise =
      let newlineCount :: Int
newlineCount = HasCallStack => Text -> Text -> Int
Text -> Text -> Int
T.count (Char -> Text
T.singleton Char
'\n') Text
source
          endLine :: Int
endLine = Int
newlineCount
          -- Length of the last line (after the last newline; if no newline,
          -- the whole text is one line), in UTF-16 units as LSP counts them.
          endCharacter :: UInt
endCharacter
            | HasCallStack => Text -> Char
Text -> Char
T.last Text
source Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = UInt
0
            | Bool
otherwise = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Enc.utf16Length ((Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
source))
      in Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endLine) UInt
endCharacter)

formatDocument :: Handler LSP 'Method_TextDocumentFormatting
formatDocument :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentFormatting
formatDocument TRequestMessage 'Method_TextDocumentFormatting
req Either
  (TResponseError 'Method_TextDocumentFormatting)
  ([TextEdit] |? Null)
-> LSP ()
res = do
  let doc :: NormalizedUri
doc = TRequestMessage 'Method_TextDocumentFormatting
req TRequestMessage 'Method_TextDocumentFormatting
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentFormatting)
     NormalizedUri
-> NormalizedUri
forall s a. s -> Getting a s a -> a
^. (DocumentFormattingParams
 -> Const NormalizedUri DocumentFormattingParams)
-> TRequestMessage 'Method_TextDocumentFormatting
-> Const
     NormalizedUri (TRequestMessage 'Method_TextDocumentFormatting)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentFormatting)
  DocumentFormattingParams
params ((DocumentFormattingParams
  -> Const NormalizedUri DocumentFormattingParams)
 -> TRequestMessage 'Method_TextDocumentFormatting
 -> Const
      NormalizedUri (TRequestMessage 'Method_TextDocumentFormatting))
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> DocumentFormattingParams
    -> Const NormalizedUri DocumentFormattingParams)
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentFormatting)
     NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> DocumentFormattingParams
-> Const NormalizedUri DocumentFormattingParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DocumentFormattingParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier
  -> Const NormalizedUri TextDocumentIdentifier)
 -> DocumentFormattingParams
 -> Const NormalizedUri DocumentFormattingParams)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> TextDocumentIdentifier
    -> Const NormalizedUri TextDocumentIdentifier)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> DocumentFormattingParams
-> Const NormalizedUri DocumentFormattingParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const NormalizedUri Uri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri ((Uri -> Const NormalizedUri Uri)
 -> TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> Uri -> Const NormalizedUri Uri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> NormalizedUri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> Uri
-> Const NormalizedUri Uri
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> NormalizedUri
toNormalizedUri
  Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logInfo (Text -> LSP ()) -> Text -> LSP ()
forall a b. (a -> b) -> a -> b
$ Text
"Formatting document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (NormalizedUri -> FilePath
forall a. Show a => a -> FilePath
show NormalizedUri
doc)
  RzkConfig.ServerConfig {RzkConfig.formatEnabled = fmtEnabled} <- LspT ServerConfig (ReaderT RzkEnv IO) ServerConfig
forall config (m :: * -> *). MonadLsp config m => m config
getConfig
  if fmtEnabled then do
    mdoc <- getVirtualFile doc
    possibleEdits <- case virtualFileText <$> mdoc of
      Maybe Text
Nothing         -> Either Text [TextEdit]
-> LspT ServerConfig (ReaderT RzkEnv IO) (Either Text [TextEdit])
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text [TextEdit]
forall a b. a -> Either a b
Left Text
"Failed to get file contents")
      Just Text
sourceCode -> do
        -- 'fullDocumentRange' spans the trailing newlines too, so the
        -- replacement carries them: 'formatDocument' keeps as many as the
        -- source had, and the document is returned with its final newline
        -- intact.
        let source :: Text
source = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Text
sourceCode
            range :: Range
range = Text -> Range
fullDocumentRange Text
source
        Either Text [TextEdit]
-> LspT ServerConfig (ReaderT RzkEnv IO) (Either Text [TextEdit])
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TextEdit] -> Either Text [TextEdit]
forall a b. b -> Either a b
Right [Range -> Text -> TextEdit
TextEdit Range
range (Text -> Text
Fmt.formatDocument Text
source)])
    case possibleEdits of
#if MIN_VERSION_lsp(2,7,0)
      Left Text
err    -> Either
  (TResponseError 'Method_TextDocumentFormatting)
  ([TextEdit] |? Null)
-> LSP ()
res (Either
   (TResponseError 'Method_TextDocumentFormatting)
   ([TextEdit] |? Null)
 -> LSP ())
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
-> LSP ()
forall a b. (a -> b) -> a -> b
$ TResponseError 'Method_TextDocumentFormatting
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
forall a b. a -> Either a b
Left (TResponseError 'Method_TextDocumentFormatting
 -> Either
      (TResponseError 'Method_TextDocumentFormatting)
      ([TextEdit] |? Null))
-> TResponseError 'Method_TextDocumentFormatting
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData 'Method_TextDocumentFormatting)
-> TResponseError 'Method_TextDocumentFormatting
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) Text
err Maybe (ErrorData 'Method_TextDocumentFormatting)
forall a. Maybe a
Nothing
#else
      Left err    -> res $ Left $ ResponseError (InR ErrorCodes_InternalError) err Nothing
#endif
      Right [TextEdit]
edits -> do
        Either
  (TResponseError 'Method_TextDocumentFormatting)
  ([TextEdit] |? Null)
-> LSP ()
res (Either
   (TResponseError 'Method_TextDocumentFormatting)
   ([TextEdit] |? Null)
 -> LSP ())
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
-> LSP ()
forall a b. (a -> b) -> a -> b
$ ([TextEdit] |? Null)
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
forall a b. b -> Either a b
Right (([TextEdit] |? Null)
 -> Either
      (TResponseError 'Method_TextDocumentFormatting)
      ([TextEdit] |? Null))
-> ([TextEdit] |? Null)
-> Either
     (TResponseError 'Method_TextDocumentFormatting)
     ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> [TextEdit] |? Null
forall a b. a -> a |? b
InL [TextEdit]
edits
  else do
    logDebug "Formatting is disabled in config"
    res $ Right $ InR Null

provideSemanticTokens :: Handler LSP 'Method_TextDocumentSemanticTokensFull
provideSemanticTokens :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentSemanticTokensFull
provideSemanticTokens TRequestMessage 'Method_TextDocumentSemanticTokensFull
req Either
  (TResponseError 'Method_TextDocumentSemanticTokensFull)
  (SemanticTokens |? Null)
-> LSP ()
responder = do
  let doc :: NormalizedUri
doc = TRequestMessage 'Method_TextDocumentSemanticTokensFull
req TRequestMessage 'Method_TextDocumentSemanticTokensFull
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
     NormalizedUri
-> NormalizedUri
forall s a. s -> Getting a s a -> a
^. (SemanticTokensParams -> Const NormalizedUri SemanticTokensParams)
-> TRequestMessage 'Method_TextDocumentSemanticTokensFull
-> Const
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
  SemanticTokensParams
params ((SemanticTokensParams -> Const NormalizedUri SemanticTokensParams)
 -> TRequestMessage 'Method_TextDocumentSemanticTokensFull
 -> Const
      NormalizedUri
      (TRequestMessage 'Method_TextDocumentSemanticTokensFull))
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> SemanticTokensParams
    -> Const NormalizedUri SemanticTokensParams)
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
     NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> SemanticTokensParams -> Const NormalizedUri SemanticTokensParams
forall s a. HasTextDocument s a => Lens' s a
Lens' SemanticTokensParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier
  -> Const NormalizedUri TextDocumentIdentifier)
 -> SemanticTokensParams
 -> Const NormalizedUri SemanticTokensParams)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> TextDocumentIdentifier
    -> Const NormalizedUri TextDocumentIdentifier)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> SemanticTokensParams
-> Const NormalizedUri SemanticTokensParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const NormalizedUri Uri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri ((Uri -> Const NormalizedUri Uri)
 -> TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> Uri -> Const NormalizedUri Uri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> NormalizedUri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> Uri
-> Const NormalizedUri Uri
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> NormalizedUri
toNormalizedUri
      currentFile :: FilePath
currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Uri -> Maybe FilePath
uriToFilePath (TRequestMessage 'Method_TextDocumentSemanticTokensFull
req TRequestMessage 'Method_TextDocumentSemanticTokensFull
-> Getting
     Uri (TRequestMessage 'Method_TextDocumentSemanticTokensFull) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (SemanticTokensParams -> Const Uri SemanticTokensParams)
-> TRequestMessage 'Method_TextDocumentSemanticTokensFull
-> Const
     Uri (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentSemanticTokensFull)
  SemanticTokensParams
params ((SemanticTokensParams -> Const Uri SemanticTokensParams)
 -> TRequestMessage 'Method_TextDocumentSemanticTokensFull
 -> Const
      Uri (TRequestMessage 'Method_TextDocumentSemanticTokensFull))
-> ((Uri -> Const Uri Uri)
    -> SemanticTokensParams -> Const Uri SemanticTokensParams)
-> Getting
     Uri (TRequestMessage 'Method_TextDocumentSemanticTokensFull) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> SemanticTokensParams -> Const Uri SemanticTokensParams
forall s a. HasTextDocument s a => Lens' s a
Lens' SemanticTokensParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> SemanticTokensParams -> Const Uri SemanticTokensParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> SemanticTokensParams
-> Const Uri SemanticTokensParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri))
  mdoc <- NormalizedUri
-> LspT ServerConfig (ReaderT RzkEnv IO) (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
doc
  -- Use-site classification needs name resolution (an occurrence of a
  -- constructor is a plain variable to the AST walk): the reference index
  -- resolves the occurrences, and the typecheck cache knows each
  -- declaration's kind.
  referenceIndex <- indexProject currentFile
  cachedModules <- getCachedTypecheckedModules
  let declsByFile = [ (FilePath
path, RzkCachedModule -> [DeclView]
cachedModuleDecls RzkCachedModule
m) | (FilePath
path, RzkCachedModule
m) <- RzkTypecheckCache
cachedModules ]
      overlay = [(FilePath, [DeclView])]
-> ReferenceIndex -> FilePath -> [SemanticTokenAbsolute]
useSiteTokens [(FilePath, [DeclView])]
declsByFile ReferenceIndex
referenceIndex FilePath
currentFile
  possibleTokens <- case virtualFileText <$> mdoc of
    Maybe Text
Nothing         -> Either Text [SemanticTokenAbsolute]
-> LspT
     ServerConfig
     (ReaderT RzkEnv IO)
     (Either Text [SemanticTokenAbsolute])
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text [SemanticTokenAbsolute]
forall a b. a -> Either a b
Left Text
"Failed to get file content")
    Just Text
sourceCode -> do
      let src :: Text
src = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Text
sourceCode
      -- Fixed symbols (commands, keywords, operators) are highlighted from
      -- the lexer token stream, so they survive parse failures; identifiers
      -- need the parsed module.
      astTokens <- IO (Either Text Module)
-> LspT ServerConfig (ReaderT RzkEnv IO) (Either Text Module)
forall a. IO a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO (Either Text Module)
parseModuleSafe Text
src) LspT ServerConfig (ReaderT RzkEnv IO) (Either Text Module)
-> (Either Text Module
    -> LspT ServerConfig (ReaderT RzkEnv IO) [SemanticTokenAbsolute])
-> LspT ServerConfig (ReaderT RzkEnv IO) [SemanticTokenAbsolute]
forall a b.
LspT ServerConfig (ReaderT RzkEnv IO) a
-> (a -> LspT ServerConfig (ReaderT RzkEnv IO) b)
-> LspT ServerConfig (ReaderT RzkEnv IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Text
err -> do
          Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logWarning (Text
"Failed to parse file for semantic tokens: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
          [SemanticTokenAbsolute]
-> LspT ServerConfig (ReaderT RzkEnv IO) [SemanticTokenAbsolute]
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Right Module
rzkModule -> [SemanticTokenAbsolute]
-> LspT ServerConfig (ReaderT RzkEnv IO) [SemanticTokenAbsolute]
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> [SemanticTokenAbsolute]
tokenizeModule Module
rzkModule)
      -- On overlapping positions: the AST walk wins (it has the declaration
      -- modifiers), then the use-site overlay, then the lexer baseline.
      return (Right (Enc.tokensToUtf16 (Enc.astralLines src)
        (mergeTokens (mergeTokens astTokens overlay) (tokenizeSyntaxSymbols src))))
  case possibleTokens of
    Left Text
err -> do
      -- Exception occurred when parsing the module
      Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logWarning (Text
"Failed to tokenize file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
    Right [SemanticTokenAbsolute]
tokens -> do
      let encoded :: Either Text [UInt]
encoded = SemanticTokensLegend
-> [SemanticTokenRelative] -> Either Text [UInt]
encodeTokens SemanticTokensLegend
defaultSemanticTokensLegend ([SemanticTokenRelative] -> Either Text [UInt])
-> [SemanticTokenRelative] -> Either Text [UInt]
forall a b. (a -> b) -> a -> b
$ [SemanticTokenAbsolute] -> [SemanticTokenRelative]
relativizeTokens [SemanticTokenAbsolute]
tokens
      case Either Text [UInt]
encoded of
        Left Text
_err -> do
          -- Failed to encode the tokens
          () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Right [UInt]
list ->
          Either
  (TResponseError 'Method_TextDocumentSemanticTokensFull)
  (SemanticTokens |? Null)
-> LSP ()
responder ((SemanticTokens |? Null)
-> Either
     (TResponseError 'Method_TextDocumentSemanticTokensFull)
     (SemanticTokens |? Null)
forall a b. b -> Either a b
Right (SemanticTokens -> SemanticTokens |? Null
forall a b. a -> a |? b
InL (Maybe Text -> [UInt] -> SemanticTokens
SemanticTokens Maybe Text
forall a. Maybe a
Nothing [UInt]
list)))

findDefinition :: Handler LSP 'Method_TextDocumentDefinition
findDefinition :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentDefinition
findDefinition TRequestMessage 'Method_TextDocumentDefinition
req Either
  (TResponseError 'Method_TextDocumentDefinition)
  (Definition |? ([DefinitionLink] |? Null))
-> LSP ()
res = do
  let uri' :: Uri
uri' = TRequestMessage 'Method_TextDocumentDefinition
req TRequestMessage 'Method_TextDocumentDefinition
-> Getting Uri (TRequestMessage 'Method_TextDocumentDefinition) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (DefinitionParams -> Const Uri DefinitionParams)
-> TRequestMessage 'Method_TextDocumentDefinition
-> Const Uri (TRequestMessage 'Method_TextDocumentDefinition)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentDefinition) DefinitionParams
params ((DefinitionParams -> Const Uri DefinitionParams)
 -> TRequestMessage 'Method_TextDocumentDefinition
 -> Const Uri (TRequestMessage 'Method_TextDocumentDefinition))
-> ((Uri -> Const Uri Uri)
    -> DefinitionParams -> Const Uri DefinitionParams)
-> Getting Uri (TRequestMessage 'Method_TextDocumentDefinition) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DefinitionParams -> Const Uri DefinitionParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DefinitionParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DefinitionParams -> Const Uri DefinitionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DefinitionParams
-> Const Uri DefinitionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
      currentFile :: FilePath
currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Uri -> Maybe FilePath
uriToFilePath Uri
uri')
  referenceIndex <- FilePath -> LSP ReferenceIndex
indexProject FilePath
currentFile
  als <- astralLinesOfFile currentFile
  case RefInd.lookupAt referenceIndex (fromLspUri uri') (fromLspPosition als (req ^. params . position)) of
    Just Binding
binding -> do
      location <- Location -> LSP Location
toLspLocation (Binding -> Location
RefInd.bindingDef Binding
binding)
      res $ Right $ InL $ Definition $ InL location
    Maybe Binding
Nothing      -> Either
  (TResponseError 'Method_TextDocumentDefinition)
  (Definition |? ([DefinitionLink] |? Null))
-> LSP ()
res (Either
   (TResponseError 'Method_TextDocumentDefinition)
   (Definition |? ([DefinitionLink] |? Null))
 -> LSP ())
-> Either
     (TResponseError 'Method_TextDocumentDefinition)
     (Definition |? ([DefinitionLink] |? Null))
-> LSP ()
forall a b. (a -> b) -> a -> b
$ (Definition |? ([DefinitionLink] |? Null))
-> Either
     (TResponseError 'Method_TextDocumentDefinition)
     (Definition |? ([DefinitionLink] |? Null))
forall a b. b -> Either a b
Right ((Definition |? ([DefinitionLink] |? Null))
 -> Either
      (TResponseError 'Method_TextDocumentDefinition)
      (Definition |? ([DefinitionLink] |? Null)))
-> (Definition |? ([DefinitionLink] |? Null))
-> Either
     (TResponseError 'Method_TextDocumentDefinition)
     (Definition |? ([DefinitionLink] |? Null))
forall a b. (a -> b) -> a -> b
$ ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null)
 -> Definition |? ([DefinitionLink] |? Null))
-> ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> [DefinitionLink] |? Null
forall a b. b -> a |? b
InR Null
Null

findReferences :: Handler LSP 'Method_TextDocumentReferences
findReferences :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentReferences
findReferences TRequestMessage 'Method_TextDocumentReferences
req Either
  (TResponseError 'Method_TextDocumentReferences)
  ([Location] |? Null)
-> LSP ()
res = do
  let uri' :: Uri
uri' = TRequestMessage 'Method_TextDocumentReferences
req TRequestMessage 'Method_TextDocumentReferences
-> Getting Uri (TRequestMessage 'Method_TextDocumentReferences) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (ReferenceParams -> Const Uri ReferenceParams)
-> TRequestMessage 'Method_TextDocumentReferences
-> Const Uri (TRequestMessage 'Method_TextDocumentReferences)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentReferences) ReferenceParams
params ((ReferenceParams -> Const Uri ReferenceParams)
 -> TRequestMessage 'Method_TextDocumentReferences
 -> Const Uri (TRequestMessage 'Method_TextDocumentReferences))
-> ((Uri -> Const Uri Uri)
    -> ReferenceParams -> Const Uri ReferenceParams)
-> Getting Uri (TRequestMessage 'Method_TextDocumentReferences) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> ReferenceParams -> Const Uri ReferenceParams
forall s a. HasTextDocument s a => Lens' s a
Lens' ReferenceParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> ReferenceParams -> Const Uri ReferenceParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> ReferenceParams
-> Const Uri ReferenceParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
      currentFile :: FilePath
currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Uri -> Maybe FilePath
uriToFilePath Uri
uri')
      includeDeclaration :: Bool
includeDeclaration = TRequestMessage 'Method_TextDocumentReferences
req TRequestMessage 'Method_TextDocumentReferences
-> Getting
     Bool (TRequestMessage 'Method_TextDocumentReferences) Bool
-> Bool
forall s a. s -> Getting a s a -> a
^. (ReferenceParams -> Const Bool ReferenceParams)
-> TRequestMessage 'Method_TextDocumentReferences
-> Const Bool (TRequestMessage 'Method_TextDocumentReferences)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentReferences) ReferenceParams
params ((ReferenceParams -> Const Bool ReferenceParams)
 -> TRequestMessage 'Method_TextDocumentReferences
 -> Const Bool (TRequestMessage 'Method_TextDocumentReferences))
-> ((Bool -> Const Bool Bool)
    -> ReferenceParams -> Const Bool ReferenceParams)
-> Getting
     Bool (TRequestMessage 'Method_TextDocumentReferences) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReferenceContext -> Const Bool ReferenceContext)
-> ReferenceParams -> Const Bool ReferenceParams
forall s a. HasContext s a => Lens' s a
Lens' ReferenceParams ReferenceContext
context ((ReferenceContext -> Const Bool ReferenceContext)
 -> ReferenceParams -> Const Bool ReferenceParams)
-> ((Bool -> Const Bool Bool)
    -> ReferenceContext -> Const Bool ReferenceContext)
-> (Bool -> Const Bool Bool)
-> ReferenceParams
-> Const Bool ReferenceParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReferenceContext -> Bool)
-> (Bool -> Const Bool Bool)
-> ReferenceContext
-> Const Bool ReferenceContext
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (\(ReferenceContext Bool
incl) -> Bool
incl)
  referenceIndex <- FilePath -> LSP ReferenceIndex
indexProject FilePath
currentFile
  als <- astralLinesOfFile currentFile
  case RefInd.lookupAt referenceIndex (fromLspUri uri') (fromLspPosition als (req ^. params . position)) of
    Just Binding
binding -> do
      let sites :: [Location]
sites
            | Bool
includeDeclaration = Binding -> [Location]
RefInd.bindingSites Binding
binding
            | Bool
otherwise          = Binding -> [Location]
RefInd.bindingRefs Binding
binding
      locations <- [Location] -> LSP [Location]
toLspLocations [Location]
sites
      res $ Right $ InL locations
    Maybe Binding
Nothing -> Either
  (TResponseError 'Method_TextDocumentReferences)
  ([Location] |? Null)
-> LSP ()
res (Either
   (TResponseError 'Method_TextDocumentReferences)
   ([Location] |? Null)
 -> LSP ())
-> Either
     (TResponseError 'Method_TextDocumentReferences)
     ([Location] |? Null)
-> LSP ()
forall a b. (a -> b) -> a -> b
$ ([Location] |? Null)
-> Either
     (TResponseError 'Method_TextDocumentReferences)
     ([Location] |? Null)
forall a b. b -> Either a b
Right (([Location] |? Null)
 -> Either
      (TResponseError 'Method_TextDocumentReferences)
      ([Location] |? Null))
-> ([Location] |? Null)
-> Either
     (TResponseError 'Method_TextDocumentReferences)
     ([Location] |? Null)
forall a b. (a -> b) -> a -> b
$ [Location] -> [Location] |? Null
forall a b. a -> a |? b
InL []

indexProject :: FilePath -> LSP RefInd.ReferenceIndex
indexProject :: FilePath -> LSP ReferenceIndex
indexProject FilePath
currentFile = do
  cached <- LSP RzkTypecheckCache
getCachedTypecheckedModules
  let paths = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub (FilePath
currentFile FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ((FilePath, RzkCachedModule) -> FilePath)
-> RzkTypecheckCache -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, RzkCachedModule) -> FilePath
forall a b. (a, b) -> a
fst RzkTypecheckCache
cached)
  mdoc <- getVirtualFile (filePathToNormalizedUri currentFile)
  let msrc = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VirtualFile -> Text
virtualFileText (VirtualFile -> Text) -> Maybe VirtualFile -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mdoc)
  ReferenceIndexCache oldModules oldResult <- getCachedReferenceIndex
  -- Re-parse only what changed: the current file is revalidated against the
  -- editor buffer, while other files keep their cached parse until a
  -- file-change notification invalidates it (see resetCacheForFiles).
  let reusable FilePath
p ParsedModule
pm = case ParsedModule -> ParseSource
parsedSource ParsedModule
pm of
        ParseSource
ParseInvalidated   -> Bool
False
        ParsedFromBuffer Text
t -> FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
currentFile Bool -> Bool -> Bool
|| Maybe Text
msrc Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
        ParseSource
ParsedFromDisk     -> FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
currentFile Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
msrc
  entries <- forM paths $ \FilePath
p ->
    case FilePath -> Map FilePath ParsedModule -> Maybe ParsedModule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
p Map FilePath ParsedModule
oldModules of
      Just ParsedModule
pm | FilePath -> ParsedModule -> Bool
reusable FilePath
p ParsedModule
pm -> (FilePath, ParsedModule, Bool)
-> LspT
     ServerConfig (ReaderT RzkEnv IO) (FilePath, ParsedModule, Bool)
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
p, ParsedModule
pm, Bool
False)
      Maybe ParsedModule
mold -> do
        parsed <- FilePath -> Maybe Text -> FilePath -> LSP (Maybe Module)
parseProjectFile FilePath
currentFile Maybe Text
msrc FilePath
p
        let source = if FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
currentFile
              then ParseSource -> (Text -> ParseSource) -> Maybe Text -> ParseSource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParseSource
ParsedFromDisk Text -> ParseSource
ParsedFromBuffer Maybe Text
msrc
              else ParseSource
ParsedFromDisk
            -- A failed parse (a syntax error mid-edit) keeps the last good
            -- module, so hover and navigation stay available; the source is
            -- still updated, so the parse is retried once per edit, not once
            -- per request.
            module_ = Maybe Module
parsed Maybe Module -> Maybe Module -> Maybe Module
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsedModule -> Maybe Module
parsedModule (ParsedModule -> Maybe Module)
-> Maybe ParsedModule -> Maybe Module
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ParsedModule
mold)
        return (p, ParsedModule source module_, True)
  let reparsed = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
r | (FilePath
_, ParsedModule
_, Bool
r) <- [(FilePath, ParsedModule, Bool)]
entries ]
  case oldResult of
    Just ([FilePath]
ps, ReferenceIndex
cachedIndex) | [FilePath]
ps [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath]
paths, Bool -> Bool
not Bool
reparsed -> ReferenceIndex -> LSP ReferenceIndex
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ReferenceIndex
cachedIndex
    Maybe ([FilePath], ReferenceIndex)
_ -> do
      let referenceIndex :: ReferenceIndex
referenceIndex = [(FilePath, Module)] -> ReferenceIndex
RefInd.indexModules
            [ (FilePath
p, Module
m) | (FilePath
p, ParsedModule ParseSource
_ (Just Module
m), Bool
_) <- [(FilePath, ParsedModule, Bool)]
entries ]
      ReferenceIndexCache -> LSP ()
cacheReferenceIndex (ReferenceIndexCache -> LSP ()) -> ReferenceIndexCache -> LSP ()
forall a b. (a -> b) -> a -> b
$ Map FilePath ParsedModule
-> Maybe ([FilePath], ReferenceIndex) -> ReferenceIndexCache
ReferenceIndexCache
        ([(FilePath, ParsedModule)] -> Map FilePath ParsedModule
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (FilePath
p, ParsedModule
pm) | (FilePath
p, ParsedModule
pm, Bool
_) <- [(FilePath, ParsedModule, Bool)]
entries ])
        (([FilePath], ReferenceIndex) -> Maybe ([FilePath], ReferenceIndex)
forall a. a -> Maybe a
Just ([FilePath]
paths, ReferenceIndex
referenceIndex))
      ReferenceIndex -> LSP ReferenceIndex
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ReferenceIndex
referenceIndex

parseProjectFile :: FilePath -> Maybe T.Text -> FilePath -> LSP (Maybe Module)
parseProjectFile :: FilePath -> Maybe Text -> FilePath -> LSP (Maybe Module)
parseProjectFile FilePath
currentFile Maybe Text
msrc FilePath
p
  | FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
currentFile = case Maybe Text
msrc of
      Just Text
src -> IO (Either Text Module) -> LSP (Maybe Module)
forall {f :: * -> *} {a} {a}.
MonadIO f =>
IO (Either a a) -> f (Maybe a)
parseOr (Text -> IO (Either Text Module)
parseModuleSafe Text
src)
      Maybe Text
Nothing  -> IO (Either Text Module) -> LSP (Maybe Module)
forall {f :: * -> *} {a} {a}.
MonadIO f =>
IO (Either a a) -> f (Maybe a)
parseOr (FilePath -> IO (Either Text Module)
parseModuleFile FilePath
p)
  | Bool
otherwise = IO (Either Text Module) -> LSP (Maybe Module)
forall {f :: * -> *} {a} {a}.
MonadIO f =>
IO (Either a a) -> f (Maybe a)
parseOr (FilePath -> IO (Either Text Module)
parseModuleFile FilePath
p)
  where
    parseOr :: IO (Either a a) -> f (Maybe a)
parseOr IO (Either a a)
act = (a -> Maybe a) -> (a -> Maybe a) -> Either a a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either a a -> Maybe a) -> f (Either a a) -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either a a) -> f (Either a a)
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either a a)
act

-- | A signature for the hover code block. A long function type is split
-- with one parameter per line, in the style rzk definitions are written:
--
-- > is-equiv
-- >   : ( A : U)
-- >   → ( B : U)
-- >   → ( f : A → B)
-- >   → U
formatSignature :: String -> Term -> String
formatSignature :: FilePath -> Term' BNFC'Position -> FilePath
formatSignature FilePath
name Term' BNFC'Position
ty
  | FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
inline Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
60 = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
inline
  | (piParams :: [FilePath]
piParams@(FilePath
_ : [FilePath]
_), Term' BNFC'Position
ret) <- Term' BNFC'Position -> ([FilePath], Term' BNFC'Position)
forall {a}. Term' a -> ([FilePath], Term' a)
peelPi Term' BNFC'Position
ty =
      FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" (FilePath
name FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath -> FilePath)
-> [FilePath] -> [FilePath] -> [FilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
(++) (FilePath
"  : " FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
forall a. a -> [a]
repeat FilePath
"  → ") ([FilePath]
piParams [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [Term' BNFC'Position -> FilePath
forall a. Print a => a -> FilePath
printTree Term' BNFC'Position
ret]))
  | Bool
otherwise = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
inline
  where
    inline :: FilePath
inline = Term' BNFC'Position -> FilePath
forall a. Print a => a -> FilePath
printTree Term' BNFC'Position
ty
    peelPi :: Term' a -> ([FilePath], Term' a)
peelPi (TypeFun a
_ ParamDecl' a
param Term' a
ret)       = let ([FilePath]
ps, Term' a
r) = Term' a -> ([FilePath], Term' a)
peelPi Term' a
ret in (ParamDecl' a -> FilePath
forall a. Print a => a -> FilePath
printTree ParamDecl' a
param FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
ps, Term' a
r)
    peelPi (ASCII_TypeFun a
_ ParamDecl' a
param Term' a
ret) = let ([FilePath]
ps, Term' a
r) = Term' a -> ([FilePath], Term' a)
peelPi Term' a
ret in (ParamDecl' a -> FilePath
forall a. Print a => a -> FilePath
printTree ParamDecl' a
param FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
ps, Term' a
r)
    peelPi Term' a
r                           = ([], Term' a
r)

provideHover :: Handler LSP 'Method_TextDocumentHover
provideHover :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO)) 'Method_TextDocumentHover
provideHover TRequestMessage 'Method_TextDocumentHover
req Either (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
-> LSP ()
res = do
  let uri' :: Uri
uri' = TRequestMessage 'Method_TextDocumentHover
req TRequestMessage 'Method_TextDocumentHover
-> Getting Uri (TRequestMessage 'Method_TextDocumentHover) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (HoverParams -> Const Uri HoverParams)
-> TRequestMessage 'Method_TextDocumentHover
-> Const Uri (TRequestMessage 'Method_TextDocumentHover)
forall s a. HasParams s a => Lens' s a
Lens' (TRequestMessage 'Method_TextDocumentHover) HoverParams
params ((HoverParams -> Const Uri HoverParams)
 -> TRequestMessage 'Method_TextDocumentHover
 -> Const Uri (TRequestMessage 'Method_TextDocumentHover))
-> ((Uri -> Const Uri Uri) -> HoverParams -> Const Uri HoverParams)
-> Getting Uri (TRequestMessage 'Method_TextDocumentHover) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> HoverParams -> Const Uri HoverParams
forall s a. HasTextDocument s a => Lens' s a
Lens' HoverParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> HoverParams -> Const Uri HoverParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> HoverParams
-> Const Uri HoverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
      currentFile :: FilePath
currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe FilePath
uriToFilePath Uri
uri'
  referenceIndex <- FilePath -> LSP ReferenceIndex
indexProject FilePath
currentFile
  als <- astralLinesOfFile currentFile
  let pos = AstralLines -> Position -> Position
fromLspPosition AstralLines
als (TRequestMessage 'Method_TextDocumentHover
req TRequestMessage 'Method_TextDocumentHover
-> Getting
     Position (TRequestMessage 'Method_TextDocumentHover) Position
-> Position
forall s a. s -> Getting a s a -> a
^. (HoverParams -> Const Position HoverParams)
-> TRequestMessage 'Method_TextDocumentHover
-> Const Position (TRequestMessage 'Method_TextDocumentHover)
forall s a. HasParams s a => Lens' s a
Lens' (TRequestMessage 'Method_TextDocumentHover) HoverParams
params ((HoverParams -> Const Position HoverParams)
 -> TRequestMessage 'Method_TextDocumentHover
 -> Const Position (TRequestMessage 'Method_TextDocumentHover))
-> ((Position -> Const Position Position)
    -> HoverParams -> Const Position HoverParams)
-> Getting
     Position (TRequestMessage 'Method_TextDocumentHover) Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> HoverParams -> Const Position HoverParams
forall s a. HasPosition s a => Lens' s a
Lens' HoverParams Position
position)
  case RefInd.lookupAt referenceIndex (fromLspUri uri') pos of
    Maybe Binding
Nothing -> Either (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
-> LSP ()
res (Either (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
 -> LSP ())
-> Either
     (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
-> LSP ()
forall a b. (a -> b) -> a -> b
$ (Hover |? Null)
-> Either
     (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
forall a b. b -> Either a b
Right ((Hover |? Null)
 -> Either
      (TResponseError 'Method_TextDocumentHover) (Hover |? Null))
-> (Hover |? Null)
-> Either
     (TResponseError 'Method_TextDocumentHover) (Hover |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Hover |? Null
forall a b. b -> a |? b
InR Null
Null
    Just Binding
binding -> do
      cached <- LSP RzkTypecheckCache
getCachedTypecheckedModules
      let body = Binding -> RzkTypecheckCache -> Text
hoverContent Binding
binding RzkTypecheckCache
cached
      LSP.Location _ defRange <- toLspLocation (RefInd.bindingDef binding)
      res $ Right $ InL $ Hover
        (InL (MarkupContent MarkupKind_Markdown body))
        (Just defRange)
  where
    hoverContent :: Binding -> RzkTypecheckCache -> Text
hoverContent Binding
binding RzkTypecheckCache
cached =
      FilePath -> Text
T.pack (FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\n```rzk\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
signature FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n```")
      where
        file :: FilePath
file = Location -> FilePath
RefInd.locationPath (Binding -> Location
RefInd.bindingDef Binding
binding)
        name :: Text
name = Binding -> Text
RefInd.bindingName Binding
binding
        defLine :: Int
defLine = Position -> Int
RefInd.positionLine (Range -> Position
RefInd.rangeStart (Location -> Range
RefInd.locationRange (Binding -> Location
RefInd.bindingDef Binding
binding)))
        decls :: [DeclView]
decls = [DeclView]
-> (RzkCachedModule -> [DeclView])
-> Maybe RzkCachedModule
-> [DeclView]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] RzkCachedModule -> [DeclView]
cachedModuleDecls (FilePath -> RzkTypecheckCache -> Maybe RzkCachedModule
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
file RzkTypecheckCache
cached)
        -- The elaborated type is the default: for a local binder, from the
        -- binder-type walk over the cached declarations; for a top-level
        -- name, from the declaration itself (preferring the one on the same
        -- line, so that a local that shadows a global does not show the
        -- global's type). The surface annotation from the reference index is
        -- the fallback, e.g. for mid-edit or ill-typed code with no cache.
        defCol :: Int
defCol = Position -> Int
RefInd.positionCharacter (Range -> Position
RefInd.rangeStart (Location -> Range
RefInd.locationRange (Binding -> Location
RefInd.bindingDef Binding
binding)))
        -- The whole checked project is in scope, so that splitting a pair binder
        -- can unfold defined Σ-types from any file of it.
        binderTypes :: [(VarIdent, BinderTypeView)]
binderTypes = case RzkTypecheckCache -> RzkTypecheckCache
forall a. [a] -> [a]
reverse RzkTypecheckCache
cached of
          (FilePath
_, RzkCachedModule
entry) : RzkTypecheckCache
_ -> Checked -> FilePath -> [(VarIdent, BinderTypeView)]
binderTypesOfFile (RzkCachedModule -> Checked
cachedModuleChecked RzkCachedModule
entry) FilePath
file
          []             -> []
        elaboratedLocal :: Maybe BinderTypeView
elaboratedLocal = (Int, Int)
-> [((Int, Int), BinderTypeView)] -> Maybe BinderTypeView
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int
defLine, Int
defCol)
          [ ((Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1), BinderTypeView
t)
          | (VarIdent
v, BinderTypeView
t) <- [(VarIdent, BinderTypeView)]
binderTypes
          , let VarIdent (RzkPosition Maybe FilePath
_path BNFC'Position
mpos) VarIdentToken
_ = VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
v
          , Just (Int
l, Int
c) <- [BNFC'Position
mpos]
          ]
        signature :: FilePath
signature = case Maybe BinderTypeView
elaboratedLocal of
          Just (TypeView Rendered
t)       -> FilePath -> Term' BNFC'Position -> FilePath
formatSignature (Text -> FilePath
T.unpack Text
name) (Rendered -> Term' BNFC'Position
getRendered Rendered
t)
          Just (ShapeView Rendered
c Rendered
tope) -> Text -> FilePath
T.unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Rendered -> FilePath
forall a. Show a => a -> FilePath
show Rendered
c FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" | " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Rendered -> FilePath
forall a. Show a => a -> FilePath
show Rendered
tope
          Maybe BinderTypeView
Nothing -> case (DeclView -> Bool) -> [DeclView] -> Maybe DeclView
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find DeclView -> Bool
declOnSameLine [DeclView]
decls of
            Just DeclView
d  -> FilePath -> Term' BNFC'Position -> FilePath
formatSignature (Text -> FilePath
T.unpack Text
name) (Rendered -> Term' BNFC'Position
getRendered (DeclView -> Rendered
declViewType DeclView
d))
            Maybe DeclView
Nothing -> case Binding -> Maybe Text
RefInd.bindingType Binding
binding of
              Just Text
ann -> Text -> FilePath
T.unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
ann
              Maybe Text
Nothing  -> case (DeclView -> Bool) -> [DeclView] -> Maybe DeclView
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find DeclView -> Bool
declWithName [DeclView]
decls of
                Just DeclView
d  -> FilePath -> Term' BNFC'Position -> FilePath
formatSignature (Text -> FilePath
T.unpack Text
name) (Rendered -> Term' BNFC'Position
getRendered (DeclView -> Rendered
declViewType DeclView
d))
                Maybe DeclView
Nothing -> Text -> FilePath
T.unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : ?"
        declWithName :: DeclView -> Bool
declWithName (DeclView VarIdent
v Rendered
_ Bool
_ Maybe LocationInfo
_ DeclKind
_) =
          FilePath -> Text
T.pack (VarIdent' RzkPosition -> FilePath
forall a. Print a => a -> FilePath
printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
v)) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
        declOnSameLine :: DeclView -> Bool
declOnSameLine d :: DeclView
d@(DeclView VarIdent
_ Rendered
_ Bool
_ Maybe LocationInfo
mloc DeclKind
_) =
          DeclView -> Bool
declWithName DeclView
d Bool -> Bool -> Bool
&& (LocationInfo -> Maybe Int
locationLine (LocationInfo -> Maybe Int) -> Maybe LocationInfo -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe LocationInfo
mloc) Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
defLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- | The printed name of a declaration and the range of its defining
-- occurrence, shared by the document and workspace symbol providers.
declNameRange :: Enc.AstralLines -> DeclView -> (T.Text, Range)
declNameRange :: AstralLines -> DeclView -> (Text, Range)
declNameRange AstralLines
als (DeclView VarIdent
name Rendered
_ Bool
_ Maybe LocationInfo
_ DeclKind
_) = (FilePath -> Text
T.pack (VarIdent' RzkPosition -> FilePath
forall a. Print a => a -> FilePath
printTree VarIdent' RzkPosition
ident), Range
range)
  where
    ident :: VarIdent' RzkPosition
ident = VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name
    VarIdent RzkPosition
pos VarIdentToken
_ = VarIdent' RzkPosition
ident
    RzkPosition Maybe FilePath
_path BNFC'Position
pos' = RzkPosition
pos
    (Int
line, Int
col) = (Int, Int) -> BNFC'Position -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
0, Int
0) BNFC'Position
pos'
    len :: Int
len = FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (VarIdent' RzkPosition -> FilePath
forall a. Print a => a -> FilePath
printTree VarIdent' RzkPosition
ident)
    line0 :: Int
line0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    col0 :: Int
col0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    pos0 :: Position
pos0 = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
line0) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AstralLines -> Int -> Int -> Int
Enc.colToUtf16 AstralLines
als Int
line0 Int
col0))
    end :: Position
end  = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
line0) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AstralLines -> Int -> Int -> Int
Enc.colToUtf16 AstralLines
als Int
line0 (Int
col0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)))
    range :: Range
range = Position -> Position -> Range
Range Position
pos0 Position
end

provideSymbols :: Handler LSP 'Method_TextDocumentDocumentSymbol
provideSymbols :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_TextDocumentDocumentSymbol
provideSymbols TRequestMessage 'Method_TextDocumentDocumentSymbol
req Either
  (TResponseError 'Method_TextDocumentDocumentSymbol)
  ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> LSP ()
res = do
  let currentFile :: FilePath
currentFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe FilePath
uriToFilePath (Uri -> Maybe FilePath) -> Uri -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ TRequestMessage 'Method_TextDocumentDocumentSymbol
req TRequestMessage 'Method_TextDocumentDocumentSymbol
-> Getting
     Uri (TRequestMessage 'Method_TextDocumentDocumentSymbol) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> TRequestMessage 'Method_TextDocumentDocumentSymbol
-> Const Uri (TRequestMessage 'Method_TextDocumentDocumentSymbol)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_TextDocumentDocumentSymbol)
  DocumentSymbolParams
params ((DocumentSymbolParams -> Const Uri DocumentSymbolParams)
 -> TRequestMessage 'Method_TextDocumentDocumentSymbol
 -> Const Uri (TRequestMessage 'Method_TextDocumentDocumentSymbol))
-> ((Uri -> Const Uri Uri)
    -> DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> Getting
     Uri (TRequestMessage 'Method_TextDocumentDocumentSymbol) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentSymbolParams -> Const Uri DocumentSymbolParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DocumentSymbolParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DocumentSymbolParams
-> Const Uri DocumentSymbolParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
  cachedModules <- LSP RzkTypecheckCache
getCachedTypecheckedModules
  als <- astralLinesOfFile currentFile
  let decls = [DeclView]
-> (RzkCachedModule -> [DeclView])
-> Maybe RzkCachedModule
-> [DeclView]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] RzkCachedModule -> [DeclView]
cachedModuleDecls (FilePath -> RzkTypecheckCache -> Maybe RzkCachedModule
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
currentFile RzkTypecheckCache
cachedModules)
  res $ Right $ InR $ InL $ outline als decls
  where
    -- A #data contributes one symbol with its constructors as children; the
    -- generated eliminators stay out of the outline (they are not in the
    -- source; workspace symbol search still finds them).
    outline :: Enc.AstralLines -> [DeclView] -> [DocumentSymbol]
    outline :: AstralLines -> [DeclView] -> [DocumentSymbol]
outline AstralLines
_ [] = []
    outline AstralLines
als (DeclView
d : [DeclView]
ds) = case DeclView -> DeclKind
declViewKind DeclView
d of
      DeclKind
DeclKindData ->
        let isChildOf :: DeclView -> Bool
isChildOf DeclView
c = case DeclView -> DeclKind
declViewKind DeclView
c of
              DeclKindDataCon VarIdent
parent -> VarIdent
parent VarIdent -> VarIdent -> Bool
forall a. Eq a => a -> a -> Bool
== DeclView -> VarIdent
declViewName DeclView
d
              DeclKind
_                      -> Bool
False
            ([DeclView]
childDecls, [DeclView]
rest) = (DeclView -> Bool) -> [DeclView] -> ([DeclView], [DeclView])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span DeclView -> Bool
isChildOf [DeclView]
ds
        in AstralLines -> Maybe [DocumentSymbol] -> DeclView -> DocumentSymbol
declToSymbol AstralLines
als ([DocumentSymbol] -> Maybe [DocumentSymbol]
forall a. a -> Maybe a
Just ((DeclView -> DocumentSymbol) -> [DeclView] -> [DocumentSymbol]
forall a b. (a -> b) -> [a] -> [b]
map (AstralLines -> Maybe [DocumentSymbol] -> DeclView -> DocumentSymbol
declToSymbol AstralLines
als Maybe [DocumentSymbol]
forall a. Maybe a
Nothing) [DeclView]
childDecls)) DeclView
d
             DocumentSymbol -> [DocumentSymbol] -> [DocumentSymbol]
forall a. a -> [a] -> [a]
: AstralLines -> [DeclView] -> [DocumentSymbol]
outline AstralLines
als [DeclView]
rest
      DeclKindDataElim VarIdent
_ -> AstralLines -> [DeclView] -> [DocumentSymbol]
outline AstralLines
als [DeclView]
ds
      DeclKind
_ -> AstralLines -> Maybe [DocumentSymbol] -> DeclView -> DocumentSymbol
declToSymbol AstralLines
als Maybe [DocumentSymbol]
forall a. Maybe a
Nothing DeclView
d DocumentSymbol -> [DocumentSymbol] -> [DocumentSymbol]
forall a. a -> [a] -> [a]
: AstralLines -> [DeclView] -> [DocumentSymbol]
outline AstralLines
als [DeclView]
ds

    declToSymbol :: Enc.AstralLines -> Maybe [DocumentSymbol] -> DeclView -> DocumentSymbol
    declToSymbol :: AstralLines -> Maybe [DocumentSymbol] -> DeclView -> DocumentSymbol
declToSymbol AstralLines
als Maybe [DocumentSymbol]
mchildren decl :: DeclView
decl@(DeclView VarIdent
_ Rendered
type' Bool
_ Maybe LocationInfo
_loc DeclKind
declKind) = DocumentSymbol
      { _name :: Text
_name           = Text
symbolName
      , _detail :: Maybe Text
_detail         = Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack (Rendered -> FilePath
forall a. Show a => a -> FilePath
show Rendered
type'))
      , _kind :: SymbolKind
_kind           = DeclKind -> SymbolKind
symbolKindOfDecl DeclKind
declKind
      , _tags :: Maybe [SymbolTag]
_tags           = Maybe [SymbolTag]
forall a. Maybe a
Nothing
      , _deprecated :: Maybe Bool
_deprecated     = Maybe Bool
forall a. Maybe a
Nothing
      , _range :: Range
_range          = Range
range
      , _selectionRange :: Range
_selectionRange = Range
range
      , _children :: Maybe [DocumentSymbol]
_children       = Maybe [DocumentSymbol]
mchildren
      }
      where
        (Text
symbolName, Range
range) = AstralLines -> DeclView -> (Text, Range)
declNameRange AstralLines
als DeclView
decl

-- | The LSP symbol kind of a declaration, mirroring the semantic token
-- choices at the declaration site (class for a data type, enum member for a
-- constructor, function otherwise).
symbolKindOfDecl :: DeclKind -> SymbolKind
symbolKindOfDecl :: DeclKind -> SymbolKind
symbolKindOfDecl = \case
  DeclKind
DeclKindData       -> SymbolKind
SymbolKind_Class
  DeclKindDataCon VarIdent
_  -> SymbolKind
SymbolKind_EnumMember
  DeclKindDataElim VarIdent
_ -> SymbolKind
SymbolKind_Function
  DeclKind
DeclKindPostulate  -> SymbolKind
SymbolKind_Function
  DeclKind
DeclKindDefine     -> SymbolKind
SymbolKind_Function

-- | The completion kind of a declaration, mirroring 'symbolKindOfDecl'.
completionKindOfDecl :: DeclKind -> CompletionItemKind
completionKindOfDecl :: DeclKind -> CompletionItemKind
completionKindOfDecl = \case
  DeclKind
DeclKindData       -> CompletionItemKind
CompletionItemKind_Class
  DeclKindDataCon VarIdent
_  -> CompletionItemKind
CompletionItemKind_EnumMember
  DeclKindDataElim VarIdent
_ -> CompletionItemKind
CompletionItemKind_Function
  DeclKind
DeclKindPostulate  -> CompletionItemKind
CompletionItemKind_Function
  DeclKind
DeclKindDefine     -> CompletionItemKind
CompletionItemKind_Function

-- | The checker-derived token overlay for identifier /uses/: an occurrence
-- that resolves to a product of a @#data@ declaration is coloured by its
-- kind wherever it appears — a constructor as an enum member, the type as a
-- class, a generated eliminator as a library function — and an occurrence
-- of a postulate or an assumption is marked abstract (declared, but not
-- proven), so a proof that leans on an axiom is visible at a glance.
-- Postulates, top-level assumptions, and in-section assumptions get
-- distinct type/modifier combinations, in decreasing order of severity.
-- Occurrences are
-- matched to declarations by definition site (file and line) /and/ name, so
-- a local that shadows a constructor stays plain, and plain definitions are
-- left to the lexer baseline. Positions are code points, like every other
-- token source; the UTF-16 conversion happens after merging.
useSiteTokens
  :: [(FilePath, [DeclView])]  -- ^ the typechecked declarations, per file
  -> RefInd.ReferenceIndex
  -> FilePath                  -- ^ the file to produce tokens for
  -> [SemanticTokenAbsolute]
useSiteTokens :: [(FilePath, [DeclView])]
-> ReferenceIndex -> FilePath -> [SemanticTokenAbsolute]
useSiteTokens [(FilePath, [DeclView])]
declsByFile ReferenceIndex
refIndex FilePath
path =
  [ SemanticTokenAbsolute
      { _line :: UInt
_line = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
      , _startChar :: UInt
_startChar = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s
      , _length :: UInt
_length = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s)
      , _tokenType :: SemanticTokenTypes
_tokenType = SemanticTokenTypes
tokenType
      , _tokenModifiers :: [SemanticTokenModifiers]
_tokenModifiers = [SemanticTokenModifiers]
modifiers
      }
  | (Binding
binding, Int
l, Int
s, Int
e) <- ReferenceIndex -> FilePath -> [(Binding, Int, Int, Int)]
RefInd.fileOccurrences ReferenceIndex
refIndex FilePath
path
  , Just (SemanticTokenTypes
tokenType, [SemanticTokenModifiers]
modifiers) <- [Binding -> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
classify Binding
binding]
  ]
  where
    classify :: Binding -> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
classify Binding
binding
      -- Assumptions do not survive to the typechecked declarations (the
      -- section mechanism folds them into their users), so they are
      -- recognised by their syntactic definition site instead. A
      -- top-level assumption is a file-wide axiom; one inside a section
      -- is a hypothesis discharged at its #end, so it keeps the
      -- parameter token type and only gains the abstract modifier.
      | Just AssumeScope
scope <- ReferenceIndex -> Location -> Maybe AssumeScope
RefInd.assumeScopeAt ReferenceIndex
refIndex (Binding -> Location
RefInd.bindingDef Binding
binding) =
          (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. a -> Maybe a
Just ((SemanticTokenTypes, [SemanticTokenModifiers])
 -> Maybe (SemanticTokenTypes, [SemanticTokenModifiers]))
-> (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a b. (a -> b) -> a -> b
$ case AssumeScope
scope of
            AssumeScope
RefInd.AssumeTopLevel ->
              (SemanticTokenTypes
SemanticTokenTypes_Function, [SemanticTokenModifiers
SemanticTokenModifiers_Abstract])
            AssumeScope
RefInd.AssumeInSection ->
              (SemanticTokenTypes
SemanticTokenTypes_Parameter, [SemanticTokenModifiers
SemanticTokenModifiers_Abstract])
      | Bool
otherwise = do
      let RefInd.Location (RefInd.Uri FilePath
defPath) Range
range = Binding -> Location
RefInd.bindingDef Binding
binding
          defStart :: Position
defStart = Range -> Position
RefInd.rangeStart Range
range
          key :: (FilePath, Int, Int, Text)
key = ( FilePath
defPath
                , Position -> Int
RefInd.positionLine Position
defStart
                , Position -> Int
RefInd.positionCharacter Position
defStart
                , Binding -> Text
RefInd.bindingName Binding
binding )
      declKind <- (FilePath, Int, Int, Text)
-> Map (FilePath, Int, Int, Text) DeclKind -> Maybe DeclKind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FilePath, Int, Int, Text)
key Map (FilePath, Int, Int, Text) DeclKind
kindTable
      case declKind of
        DeclKind
DeclKindData       -> (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. a -> Maybe a
Just (SemanticTokenTypes
SemanticTokenTypes_Class, [])
        DeclKindDataCon VarIdent
_  -> (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. a -> Maybe a
Just (SemanticTokenTypes
SemanticTokenTypes_EnumMember, [])
        DeclKindDataElim VarIdent
_ ->
          (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. a -> Maybe a
Just (SemanticTokenTypes
SemanticTokenTypes_Function, [SemanticTokenModifiers
SemanticTokenModifiers_DefaultLibrary])
        -- The abstract and static modifiers are in the default legend, so
        -- no custom legend is needed; clients style function.abstract
        -- distinctly (the VS Code extension maps it to a bright scope).
        -- The static modifier only distinguishes a postulate (a permanent
        -- axiom) from a top-level assumption (discharged at module end),
        -- so a postulate can be styled louder.
        DeclKind
DeclKindPostulate  ->
          (SemanticTokenTypes, [SemanticTokenModifiers])
-> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. a -> Maybe a
Just ( SemanticTokenTypes
SemanticTokenTypes_Function
               , [SemanticTokenModifiers
SemanticTokenModifiers_Abstract, SemanticTokenModifiers
SemanticTokenModifiers_Static] )
        DeclKind
DeclKindDefine     -> Maybe (SemanticTokenTypes, [SemanticTokenModifiers])
forall a. Maybe a
Nothing
    -- Keyed by the declared name's own position, which is what the index
    -- records as the definition site (a constructor's key is where it is
    -- written, also in a multi-line declaration). The generated eliminators
    -- share the type name's position — its derived zero-width entries — so
    -- the name is part of the key.
    kindTable :: Map (FilePath, Int, Int, Text) DeclKind
kindTable = [((FilePath, Int, Int, Text), DeclKind)]
-> Map (FilePath, Int, Int, Text) DeclKind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ ((FilePath
file, Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Text
name), DeclView -> DeclKind
declViewKind DeclView
d)
      | (FilePath
_, [DeclView]
decls) <- [(FilePath, [DeclView])]
declsByFile
      , DeclView
d <- [DeclView]
decls
      , let ident :: VarIdent' RzkPosition
ident = VarIdent -> VarIdent' RzkPosition
getVarIdent (DeclView -> VarIdent
declViewName DeclView
d)
      , let name :: Text
name = FilePath -> Text
T.pack (VarIdent' RzkPosition -> FilePath
forall a. Print a => a -> FilePath
printTree VarIdent' RzkPosition
ident)
      , VarIdent (RzkPosition Maybe FilePath
mpath BNFC'Position
mpos) VarIdentToken
_ <- [VarIdent' RzkPosition
ident]
      , Just FilePath
file <- [Maybe FilePath
mpath]
      , Just (Int
line, Int
col) <- [BNFC'Position
mpos]
      ]

-- | Workspace-wide symbol search over every typechecked module in the cache.
-- The query is matched case-insensitively as an infix of the definition name;
-- an empty query lists all definitions (clients filter further as the user
-- types).
provideWorkspaceSymbols :: Handler LSP 'Method_WorkspaceSymbol
provideWorkspaceSymbols :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO)) 'Method_WorkspaceSymbol
provideWorkspaceSymbols TRequestMessage 'Method_WorkspaceSymbol
req Either
  (TResponseError 'Method_WorkspaceSymbol)
  ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> LSP ()
res = do
  let symbolQuery :: Text
symbolQuery = Text -> Text
T.toLower (TRequestMessage 'Method_WorkspaceSymbol
req TRequestMessage 'Method_WorkspaceSymbol
-> Getting Text (TRequestMessage 'Method_WorkspaceSymbol) Text
-> Text
forall s a. s -> Getting a s a -> a
^. (WorkspaceSymbolParams -> Const Text WorkspaceSymbolParams)
-> TRequestMessage 'Method_WorkspaceSymbol
-> Const Text (TRequestMessage 'Method_WorkspaceSymbol)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceSymbol) WorkspaceSymbolParams
params ((WorkspaceSymbolParams -> Const Text WorkspaceSymbolParams)
 -> TRequestMessage 'Method_WorkspaceSymbol
 -> Const Text (TRequestMessage 'Method_WorkspaceSymbol))
-> ((Text -> Const Text Text)
    -> WorkspaceSymbolParams -> Const Text WorkspaceSymbolParams)
-> Getting Text (TRequestMessage 'Method_WorkspaceSymbol) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> WorkspaceSymbolParams -> Const Text WorkspaceSymbolParams
forall s a. HasQuery s a => Lens' s a
Lens' WorkspaceSymbolParams Text
query)
  cachedModules <- LSP RzkTypecheckCache
getCachedTypecheckedModules
  symbols <- fmap concat $ forM cachedModules $ \(FilePath
path, RzkCachedModule
cachedModule) -> do
    als <- FilePath -> LSP AstralLines
astralLinesOfFile FilePath
path
    return
      [ WorkspaceSymbol
          { _name          = symbolName
          , _kind          = symbolKindOfDecl (declViewKind decl)
          , _tags          = Nothing
          , _containerName = Nothing
          , _location      = InL (Location (filePathToUri path) range)
          , _data_         = Nothing
          }
      | decl <- cachedModuleDecls cachedModule
      , let (symbolName, range) = declNameRange als decl
      , symbolQuery `T.isInfixOf` T.toLower symbolName
      ]
  res $ Right $ InR $ InL symbols


data IsChanged
  = HasChanged
  | NotChanged

-- | Detects if the given path has changes in its declaration compared to what's in the cache
isChanged :: RzkTypecheckCache -> FilePath -> LSP IsChanged
isChanged :: RzkTypecheckCache -> FilePath -> LSP IsChanged
isChanged RzkTypecheckCache
cache FilePath
path = ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) IsChanged
-> LSP IsChanged
forall {m :: * -> *} {e}.
Monad m =>
ExceptT e m IsChanged -> m IsChanged
toIsChanged (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) IsChanged
 -> LSP IsChanged)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) IsChanged
-> LSP IsChanged
forall a b. (a -> b) -> a -> b
$ do
  errors <- Maybe [TypeErrorInScopedContext]
-> ExceptT
     ()
     (LspT ServerConfig (ReaderT RzkEnv IO))
     [TypeErrorInScopedContext]
forall {a}.
Maybe a -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
maybeToEitherLSP (Maybe [TypeErrorInScopedContext]
 -> ExceptT
      ()
      (LspT ServerConfig (ReaderT RzkEnv IO))
      [TypeErrorInScopedContext])
-> Maybe [TypeErrorInScopedContext]
-> ExceptT
     ()
     (LspT ServerConfig (ReaderT RzkEnv IO))
     [TypeErrorInScopedContext]
forall a b. (a -> b) -> a -> b
$ RzkCachedModule -> [TypeErrorInScopedContext]
cachedModuleErrors (RzkCachedModule -> [TypeErrorInScopedContext])
-> Maybe RzkCachedModule -> Maybe [TypeErrorInScopedContext]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> RzkTypecheckCache -> Maybe RzkCachedModule
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
path RzkTypecheckCache
cache
  cachedDecls <- maybeToEitherLSP $ cachedModuleDecls <$> lookup path cache
  module' <- toExceptTLifted $ parseModuleFile path
  -- Re-check this file from the context of the prefix before it.
  let prefix = case RzkTypecheckCache -> RzkTypecheckCache
forall a. [a] -> [a]
reverse (((FilePath, RzkCachedModule) -> Bool)
-> RzkTypecheckCache -> RzkTypecheckCache
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
path) (FilePath -> Bool)
-> ((FilePath, RzkCachedModule) -> FilePath)
-> (FilePath, RzkCachedModule)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, RzkCachedModule) -> FilePath
forall a b. (a, b) -> a
fst) RzkTypecheckCache
cache) of
        (FilePath
_, RzkCachedModule
entry) : RzkTypecheckCache
_ -> RzkCachedModule -> Checked
cachedModuleChecked RzkCachedModule
entry
        []             -> Checked
emptyCheckedWithHoles
  e <- toExceptTLifted $ try @SomeException $ evaluate $
    recheckFrom prefix [(path, module')]
  (checkedNow, _holes) <- toExceptT $ return e
  decls' <- maybeToEitherLSP $ lookup path (declViews checkedNow)
  return $ if null (checkedErrors checkedNow) && null errors && decls' == cachedDecls
    then NotChanged
    else HasChanged
  where
    toExceptT :: ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
toExceptT = (e -> ())
-> ExceptT e (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO))) a
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError (() -> e -> ()
forall a b. a -> b -> a
const ()) (ExceptT e (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO))) a
 -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a)
-> (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
    -> ExceptT
         e (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO))) a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
-> ExceptT e (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO))) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
    toExceptTLifted :: IO (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
toExceptTLifted = ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall {e} {a}.
ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
toExceptT (ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
 -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a)
-> (IO (Either e a)
    -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a))
-> IO (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either e a)
-> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) (Either e a)
forall a.
IO a -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    maybeToEitherLSP :: Maybe a -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
maybeToEitherLSP = \case
      Maybe a
Nothing -> () -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall a.
() -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
      Just a
x -> a -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall a. a -> ExceptT () (LspT ServerConfig (ReaderT RzkEnv IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    toIsChanged :: ExceptT e m IsChanged -> m IsChanged
toIsChanged ExceptT e m IsChanged
m = ExceptT e m IsChanged -> m (Either e IsChanged)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m IsChanged
m m (Either e IsChanged)
-> (Either e IsChanged -> m IsChanged) -> m IsChanged
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left e
_ -> IsChanged -> m IsChanged
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IsChanged
HasChanged -- in case of error consider the file has changed
      Right IsChanged
x -> IsChanged -> m IsChanged
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IsChanged
x

hasNotChanged :: RzkTypecheckCache -> FilePath -> LSP Bool
hasNotChanged :: RzkTypecheckCache -> FilePath -> LSP Bool
hasNotChanged RzkTypecheckCache
cache FilePath
path = RzkTypecheckCache -> FilePath -> LSP IsChanged
isChanged RzkTypecheckCache
cache FilePath
path LSP IsChanged -> (IsChanged -> LSP Bool) -> LSP Bool
forall a b.
LspT ServerConfig (ReaderT RzkEnv IO) a
-> (a -> LspT ServerConfig (ReaderT RzkEnv IO) b)
-> LspT ServerConfig (ReaderT RzkEnv IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  IsChanged
HasChanged -> Bool -> LSP Bool
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  IsChanged
NotChanged -> Bool -> LSP Bool
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Monadic 'dropWhile'
dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
dropWhileM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM a -> m Bool
_ []     = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dropWhileM a -> m Bool
p (a
x:[a]
xs) = do
  q <- a -> m Bool
p a
x
  if q
    then dropWhileM p xs
    else return (x:xs)

-- | The cache eviction and the re-typecheck run on the typecheck worker
-- thread, so this handler returns immediately and later requests (e.g. a
-- formatting request from format-on-save) are answered while the project
-- re-check is still running. Spawning the worker cancels the previous one,
-- so a newer change restarts the re-check.
handleFilesChanged :: Handler LSP 'Method_WorkspaceDidChangeWatchedFiles
handleFilesChanged :: Handler
  (LspT ServerConfig (ReaderT RzkEnv IO))
  'Method_WorkspaceDidChangeWatchedFiles
handleFilesChanged TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
msg = do
  let modifiedPaths :: [FilePath]
modifiedPaths = TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
msg TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
-> Getting
     (Endo [FilePath])
     (TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles)
     FilePath
-> [FilePath]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (DidChangeWatchedFilesParams
 -> Const (Endo [FilePath]) DidChangeWatchedFilesParams)
-> TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
-> Const
     (Endo [FilePath])
     (TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles)
  DidChangeWatchedFilesParams
params ((DidChangeWatchedFilesParams
  -> Const (Endo [FilePath]) DidChangeWatchedFilesParams)
 -> TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
 -> Const
      (Endo [FilePath])
      (TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles))
-> ((FilePath -> Const (Endo [FilePath]) FilePath)
    -> DidChangeWatchedFilesParams
    -> Const (Endo [FilePath]) DidChangeWatchedFilesParams)
-> Getting
     (Endo [FilePath])
     (TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles)
     FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FileEvent] -> Const (Endo [FilePath]) [FileEvent])
-> DidChangeWatchedFilesParams
-> Const (Endo [FilePath]) DidChangeWatchedFilesParams
forall s a. HasChanges s a => Lens' s a
Lens' DidChangeWatchedFilesParams [FileEvent]
changes (([FileEvent] -> Const (Endo [FilePath]) [FileEvent])
 -> DidChangeWatchedFilesParams
 -> Const (Endo [FilePath]) DidChangeWatchedFilesParams)
-> ((FilePath -> Const (Endo [FilePath]) FilePath)
    -> [FileEvent] -> Const (Endo [FilePath]) [FileEvent])
-> (FilePath -> Const (Endo [FilePath]) FilePath)
-> DidChangeWatchedFilesParams
-> Const (Endo [FilePath]) DidChangeWatchedFilesParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileEvent -> Const (Endo [FilePath]) FileEvent)
-> [FileEvent] -> Const (Endo [FilePath]) [FileEvent]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((FileEvent -> Const (Endo [FilePath]) FileEvent)
 -> [FileEvent] -> Const (Endo [FilePath]) [FileEvent])
-> ((FilePath -> Const (Endo [FilePath]) FilePath)
    -> FileEvent -> Const (Endo [FilePath]) FileEvent)
-> (FilePath -> Const (Endo [FilePath]) FilePath)
-> [FileEvent]
-> Const (Endo [FilePath]) [FileEvent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const (Endo [FilePath]) Uri)
-> FileEvent -> Const (Endo [FilePath]) FileEvent
forall s a. HasUri s a => Lens' s a
Lens' FileEvent Uri
uri ((Uri -> Const (Endo [FilePath]) Uri)
 -> FileEvent -> Const (Endo [FilePath]) FileEvent)
-> ((FilePath -> Const (Endo [FilePath]) FilePath)
    -> Uri -> Const (Endo [FilePath]) Uri)
-> (FilePath -> Const (Endo [FilePath]) FilePath)
-> FileEvent
-> Const (Endo [FilePath]) FileEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Maybe FilePath)
-> (Maybe FilePath -> Const (Endo [FilePath]) (Maybe FilePath))
-> Uri
-> Const (Endo [FilePath]) Uri
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> Maybe FilePath
uriToFilePath ((Maybe FilePath -> Const (Endo [FilePath]) (Maybe FilePath))
 -> Uri -> Const (Endo [FilePath]) Uri)
-> ((FilePath -> Const (Endo [FilePath]) FilePath)
    -> Maybe FilePath -> Const (Endo [FilePath]) (Maybe FilePath))
-> (FilePath -> Const (Endo [FilePath]) FilePath)
-> Uri
-> Const (Endo [FilePath]) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Const (Endo [FilePath]) FilePath)
-> Maybe FilePath -> Const (Endo [FilePath]) (Maybe FilePath)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
  LSP () -> LSP ()
spawnTypecheckWorker (LSP () -> LSP ()) -> LSP () -> LSP ()
forall a b. (a -> b) -> a -> b
$ do
    if (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath
"rzk.yaml" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [FilePath]
modifiedPaths
      then do
        Text -> LSP ()
forall c (m :: * -> *). MonadLsp c m => Text -> m ()
logDebug Text
"rzk.yaml modified. Clearing module cache"
        LSP ()
resetCacheForAllFiles
      else do
        cache <- LSP RzkTypecheckCache
getCachedTypecheckedModules
        actualModified <- dropWhileM (hasNotChanged cache) modifiedPaths
        resetCacheForFiles actualModified
    LSP ()
typecheckFromConfigFile