{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}

module Dhall.LSP.Handlers where

import Data.Void    (Void)
import Dhall.Core
    ( Expr (Embed, Note)
    , Import (..)
    , ImportHashed (..)
    , ImportType (..)
    , headers
    , pretty
    )
import Dhall.Import (localToPath)
import Dhall.Parser (Src (..))

import Dhall.LSP.Backend.Completion
    ( Completion (..)
    , buildCompletionContext
    , completeEnvironmentImport
    , completeFromContext
    , completeLocalImport
    , completeProjections
    , completionQueryAt
    )
import Dhall.LSP.Backend.Dhall
    ( FileIdentifier
    , fileIdentifierFromFilePath
    , fileIdentifierFromURI
    , invalidate
    , load
    , parse
    , parseWithHeader
    , typecheck
    )
import Dhall.LSP.Backend.Diagnostics
    ( Diagnosis (..)
    , Range (..)
    , diagnose
    , embedsWithRanges
    , explain
    , rangeFromDhall
    )
import Dhall.LSP.Backend.Formatting  (formatExpr, formatExprWithHeader)
import Dhall.LSP.Backend.Freezing
    ( computeSemanticHash
    , getAllImportsWithHashPositions
    , getImportHashPosition
    , stripHash
    )
import Dhall.LSP.Backend.Linting     (Suggestion (..), lint, suggest)
import Dhall.LSP.Backend.Parsing     (binderExprFromText)
import Dhall.LSP.Backend.Typing      (annotateLet, exprAt, typeAt)
import Dhall.LSP.State

import Control.Applicative              ((<|>))
import Control.Concurrent.MVar
import Control.Lens                     (assign, modifying, use, uses, (^.))
import Control.Monad                    (forM, guard)
import Control.Monad.Trans              (liftIO)
import Control.Monad.Trans.Except       (catchE, runExceptT, throwE)
import Control.Monad.Trans.State.Strict (execStateT)
import Data.Default                     (def)
import Data.Maybe                       (maybeToList)
import Data.Text                        (Text, isPrefixOf)
import System.FilePath
import Text.Megaparsec                  (SourcePos (..), unPos)

import qualified Data.Aeson                      as J
import qualified Data.HashMap.Strict             as HashMap
import qualified Data.Map.Strict                 as Map
import qualified Data.Rope.UTF16                 as Rope
import qualified Data.Text                       as Text
import qualified Language.Haskell.LSP.Core       as LSP
import qualified Language.Haskell.LSP.Messages   as LSP
import qualified Language.Haskell.LSP.Types      as J
import qualified Language.Haskell.LSP.Types.Lens as J
import qualified Language.Haskell.LSP.VFS        as LSP
import qualified Network.URI                     as URI
import qualified Network.URI.Encode              as URI


-- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
-- expects a multi-threaded implementation. Reports errors to the user via the
-- LSP `ShowMessage` notification.
wrapHandler
  :: MVar ServerState
  -> (a -> HandlerM ())
  -> a
  -> IO ()
wrapHandler :: MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
vstate a -> HandlerM ()
handle a
message =
  MVar ServerState -> (ServerState -> IO ServerState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ServerState
vstate ((ServerState -> IO ServerState) -> IO ())
-> (ServerState -> IO ServerState) -> IO ()
forall a b. (a -> b) -> a -> b
$
    StateT ServerState IO (Either (Severity, Text) ())
-> ServerState -> IO ServerState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT ServerState IO (Either (Severity, Text) ())
 -> ServerState -> IO ServerState)
-> (HandlerM ()
    -> StateT ServerState IO (Either (Severity, Text) ()))
-> HandlerM ()
-> ServerState
-> IO ServerState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerM () -> StateT ServerState IO (Either (Severity, Text) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (HandlerM () -> ServerState -> IO ServerState)
-> HandlerM () -> ServerState -> IO ServerState
forall a b. (a -> b) -> a -> b
$
      HandlerM () -> ((Severity, Text) -> HandlerM ()) -> HandlerM ()
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (a -> HandlerM ()
handle a
message) (Severity, Text) -> HandlerM ()
lspUserMessage

getServerConfig :: HandlerM ServerConfig
getServerConfig :: HandlerM ServerConfig
getServerConfig = do
  LspFuncs ServerConfig
lsp <- Getting (LspFuncs ServerConfig) ServerState (LspFuncs ServerConfig)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (LspFuncs ServerConfig)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (LspFuncs ServerConfig) ServerState (LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs
  Maybe ServerConfig
mConfig <- IO (Maybe ServerConfig)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe ServerConfig)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LspFuncs ServerConfig -> IO (Maybe ServerConfig)
forall c. LspFuncs c -> IO (Maybe c)
LSP.config LspFuncs ServerConfig
lsp)
  case Maybe ServerConfig
mConfig of
    Just ServerConfig
config -> ServerConfig -> HandlerM ServerConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ServerConfig
config
    Maybe ServerConfig
Nothing -> ServerConfig -> HandlerM ServerConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ServerConfig
forall a. Default a => a
def

lspUserMessage :: (Severity, Text) -> HandlerM ()
lspUserMessage :: (Severity, Text) -> HandlerM ()
lspUserMessage (Severity
Log, Text
text) =
  (NotificationMessage ServerMethod LogMessageParams
 -> FromServerMessage)
-> ServerMethod -> LogMessageParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod LogMessageParams
-> FromServerMessage
LSP.NotLogMessage ServerMethod
J.WindowLogMessage
    (LogMessageParams -> HandlerM ())
-> LogMessageParams -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> LogMessageParams
J.LogMessageParams MessageType
J.MtLog Text
text
lspUserMessage (Severity
severity, Text
text) =
  (NotificationMessage ServerMethod ShowMessageParams
 -> FromServerMessage)
-> ServerMethod -> ShowMessageParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod ShowMessageParams
-> FromServerMessage
LSP.NotShowMessage ServerMethod
J.WindowShowMessage
    (ShowMessageParams -> HandlerM ())
-> ShowMessageParams -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> ShowMessageParams
J.ShowMessageParams MessageType
severity' Text
text
  where severity' :: MessageType
severity' = case Severity
severity of
          Severity
Error -> MessageType
J.MtError
          Severity
Warning -> MessageType
J.MtWarning
          Severity
Info -> MessageType
J.MtInfo
          Severity
Log -> MessageType
J.MtLog


lspSend :: LSP.FromServerMessage -> HandlerM ()
lspSend :: FromServerMessage -> HandlerM ()
lspSend FromServerMessage
msg = do
  FromServerMessage -> IO ()
send <- Getting
  (FromServerMessage -> IO ())
  ServerState
  (FromServerMessage -> IO ())
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (FromServerMessage -> IO ())
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((LspFuncs ServerConfig
 -> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
-> ServerState -> Const (FromServerMessage -> IO ()) ServerState
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs ((LspFuncs ServerConfig
  -> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
 -> ServerState -> Const (FromServerMessage -> IO ()) ServerState)
-> (((FromServerMessage -> IO ())
     -> Const (FromServerMessage -> IO ()) (FromServerMessage -> IO ()))
    -> LspFuncs ServerConfig
    -> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
-> Getting
     (FromServerMessage -> IO ())
     ServerState
     (FromServerMessage -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FromServerMessage -> IO ())
 -> Const (FromServerMessage -> IO ()) (FromServerMessage -> IO ()))
-> LspFuncs ServerConfig
-> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig)
forall (f :: * -> *).
Functor f =>
LensLike' f (LspFuncs ServerConfig) (FromServerMessage -> IO ())
sendFunc)
  IO () -> HandlerM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerM ()) -> IO () -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
send FromServerMessage
msg

lspRespond :: (J.ResponseMessage response -> LSP.FromServerMessage)
  -> J.RequestMessage J.ClientMethod request response -> response -> HandlerM ()
lspRespond :: (ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage response -> FromServerMessage
constructor RequestMessage ClientMethod request response
request response
response =
  FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (ResponseMessage response -> FromServerMessage)
-> ResponseMessage response
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseMessage response -> FromServerMessage
constructor (ResponseMessage response -> HandlerM ())
-> ResponseMessage response -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ RequestMessage ClientMethod request response
-> response -> ResponseMessage response
forall req resp.
RequestMessage ClientMethod req resp
-> resp -> ResponseMessage resp
LSP.makeResponseMessage RequestMessage ClientMethod request response
request response
response

lspSendNotification
  :: (J.NotificationMessage J.ServerMethod params -> LSP.FromServerMessage)
  -> J.ServerMethod -> params -> HandlerM ()
lspSendNotification :: (NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod params -> FromServerMessage
constructor ServerMethod
method params
params =
  FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (NotificationMessage ServerMethod params -> FromServerMessage)
-> NotificationMessage ServerMethod params
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotificationMessage ServerMethod params -> FromServerMessage
constructor (NotificationMessage ServerMethod params -> HandlerM ())
-> NotificationMessage ServerMethod params -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ Text
-> ServerMethod
-> params
-> NotificationMessage ServerMethod params
forall m a. Text -> m -> a -> NotificationMessage m a
J.NotificationMessage Text
"2.0" ServerMethod
method params
params

lspRequest
  :: (J.RequestMessage J.ServerMethod params response -> LSP.FromServerMessage)
  -> J.ServerMethod -> params -> HandlerM ()
lspRequest :: (RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage ServerMethod params response -> FromServerMessage
constructor ServerMethod
method params
params = do
  IO LspId
getNextReqId <- LensLike' (Const (IO LspId)) ServerState (LspFuncs ServerConfig)
-> (LspFuncs ServerConfig -> IO LspId)
-> ExceptT (Severity, Text) (StateT ServerState IO) (IO LspId)
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (IO LspId)) ServerState (LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs LspFuncs ServerConfig -> IO LspId
forall c. LspFuncs c -> IO LspId
LSP.getNextReqId
  LspId
reqId <- IO LspId -> ExceptT (Severity, Text) (StateT ServerState IO) LspId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LspId
getNextReqId
  FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (RequestMessage ServerMethod params response
    -> FromServerMessage)
-> RequestMessage ServerMethod params response
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestMessage ServerMethod params response -> FromServerMessage
constructor (RequestMessage ServerMethod params response -> HandlerM ())
-> RequestMessage ServerMethod params response -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ Text
-> LspId
-> ServerMethod
-> params
-> RequestMessage ServerMethod params response
forall m req resp.
Text -> LspId -> m -> req -> RequestMessage m req resp
J.RequestMessage Text
"2.0" LspId
reqId ServerMethod
method params
params

-- | A helper function to query haskell-lsp's VFS.
readUri :: J.Uri -> HandlerM Text
readUri :: Uri -> HandlerM Text
readUri Uri
uri = do
  NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc <- LensLike'
  (Const (NormalizedUri -> IO (Maybe VirtualFile)))
  ServerState
  (LspFuncs ServerConfig)
-> (LspFuncs ServerConfig
    -> NormalizedUri -> IO (Maybe VirtualFile))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (NormalizedUri -> IO (Maybe VirtualFile))
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const (NormalizedUri -> IO (Maybe VirtualFile)))
  ServerState
  (LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs LspFuncs ServerConfig -> NormalizedUri -> IO (Maybe VirtualFile)
forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
LSP.getVirtualFileFunc
  Maybe VirtualFile
mVirtualFile <- IO (Maybe VirtualFile)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe VirtualFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe VirtualFile)
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) (Maybe VirtualFile))
-> IO (Maybe VirtualFile)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)
  case Maybe VirtualFile
mVirtualFile of
    Just (LSP.VirtualFile Int
_ Int
_ Rope
rope) -> Text -> HandlerM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Text
Rope.toText Rope
rope)
    Maybe VirtualFile
Nothing -> String -> HandlerM Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> HandlerM Text) -> String -> HandlerM Text
forall a b. (a -> b) -> a -> b
$ String
"Could not find " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in VFS."

loadFile :: J.Uri -> HandlerM (Expr Src Void)
loadFile :: Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri = do
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
  Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache

  Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
    Right Expr Src Import
e -> Expr Src Import
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
    Either DhallError (Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to parse Dhall file.")

  Either DhallError (Cache, Expr Src Void)
loaded <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
expr Cache
cache
  (Cache
cache', Expr Src Void
expr') <- case Either DhallError (Cache, Expr Src Void)
loaded of
    Right (Cache, Expr Src Void)
x -> (Cache, Expr Src Void)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache, Expr Src Void)
x
    Either DhallError (Cache, Expr Src Void)
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to resolve imports.")
  -- Update cache. Don't cache current expression because it might not have been
  -- written to disk yet (readUri reads from the VFS).
  ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
  Expr Src Void -> HandlerM (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
expr'

-- helper
fileIdentifierFromUri :: J.Uri -> HandlerM FileIdentifier
fileIdentifierFromUri :: Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri =
  let mFileIdentifier :: Maybe FileIdentifier
mFileIdentifier = (String -> FileIdentifier) -> Maybe String -> Maybe FileIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> FileIdentifier
fileIdentifierFromFilePath (Uri -> Maybe String
J.uriToFilePath Uri
uri)
                        Maybe FileIdentifier
-> Maybe FileIdentifier -> Maybe FileIdentifier
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do URI
uri' <- (String -> Maybe URI
URI.parseURI (String -> Maybe URI) -> (Uri -> String) -> Uri -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Uri -> Text) -> Uri -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> Text
J.getUri) Uri
uri
                                URI -> Maybe FileIdentifier
fileIdentifierFromURI URI
uri')
  in case Maybe FileIdentifier
mFileIdentifier of
    Just FileIdentifier
fileIdentifier -> FileIdentifier -> HandlerM FileIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return FileIdentifier
fileIdentifier
    Maybe FileIdentifier
Nothing -> (Severity, Text) -> HandlerM FileIdentifier
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Uri -> Text
J.getUri Uri
uri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid name for a dhall file.")

-- helper
rangeToJSON :: Range -> J.Range
rangeToJSON :: Range -> Range
rangeToJSON (Range (Int
x1,Int
y1) (Int
x2,Int
y2)) = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)

hoverExplain :: J.HoverRequest -> HandlerM ()
hoverExplain :: HoverRequest -> HandlerM ()
hoverExplain HoverRequest
request = do
  let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
  -> Const Uri TextDocumentPositionParams)
 -> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentPositionParams
    -> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
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
J.uri
      J.Position Int
line Int
col = HoverRequest
request HoverRequest -> Getting Position HoverRequest Position -> Position
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
 -> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
  -> Const Position TextDocumentPositionParams)
 -> HoverRequest -> Const Position HoverRequest)
-> ((Position -> Const Position Position)
    -> TextDocumentPositionParams
    -> Const Position TextDocumentPositionParams)
-> Getting Position HoverRequest Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position
  Maybe DhallError
mError <- LensLike'
  (Const (Maybe DhallError)) ServerState (Map Uri DhallError)
-> (Map Uri DhallError -> Maybe DhallError)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const (Maybe DhallError)) ServerState (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors ((Map Uri DhallError -> Maybe DhallError)
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (Map Uri DhallError -> Maybe DhallError)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b. (a -> b) -> a -> b
$ Uri -> Map Uri DhallError -> Maybe DhallError
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Uri
uri
  let isHovered :: Diagnosis -> Bool
isHovered (Diagnosis Text
_ (Just (Range (Int, Int)
left (Int, Int)
right)) Text
_) =
        (Int, Int)
left (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
line,Int
col) Bool -> Bool -> Bool
&& (Int
line,Int
col) (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
right
      isHovered Diagnosis
_ = Bool
False

      hoverFromDiagnosis :: Diagnosis -> Maybe Hover
hoverFromDiagnosis (Diagnosis Text
_ (Just (Range (Int, Int)
left (Int, Int)
right)) Text
diagnosis) =
        let _range :: Maybe Range
_range = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Range
J.Range ((Int -> Int -> Position) -> (Int, Int) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Position
J.Position (Int, Int)
left)
                                    ((Int -> Int -> Position) -> (Int, Int) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Position
J.Position (Int, Int)
right)
            encodedDiag :: String
encodedDiag = String -> String
URI.encode (Text -> String
Text.unpack Text
diagnosis)
            command :: Text
command = Text
"[Explain error](dhall-explain:?"
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
encodedDiag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"
            _contents :: HoverContents
_contents = MarkupContent -> HoverContents
J.HoverContents (MarkupContent -> HoverContents) -> MarkupContent -> HoverContents
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
J.MarkupContent MarkupKind
J.MkMarkdown Text
command
        in Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover :: HoverContents -> Maybe Range -> Hover
J.Hover { Maybe Range
HoverContents
$sel:_contents:Hover :: HoverContents
$sel:_range:Hover :: Maybe Range
_contents :: HoverContents
_range :: Maybe Range
.. }
      hoverFromDiagnosis Diagnosis
_ = Maybe Hover
forall a. Maybe a
Nothing

      mHover :: Maybe Hover
mHover = do DhallError
err <- Maybe DhallError
mError
                  Diagnosis
explanation <- DhallError -> Maybe Diagnosis
explain DhallError
err
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Diagnosis -> Bool
isHovered Diagnosis
explanation)
                  Diagnosis -> Maybe Hover
hoverFromDiagnosis Diagnosis
explanation
  (ResponseMessage (Maybe Hover) -> FromServerMessage)
-> HoverRequest -> Maybe Hover -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (Maybe Hover) -> FromServerMessage
LSP.RspHover HoverRequest
request Maybe Hover
mHover

hoverType :: J.HoverRequest -> HandlerM ()
hoverType :: HoverRequest -> HandlerM ()
hoverType HoverRequest
request = do
  let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
  -> Const Uri TextDocumentPositionParams)
 -> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentPositionParams
    -> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
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
J.uri
      J.Position Int
line Int
col = HoverRequest
request HoverRequest -> Getting Position HoverRequest Position -> Position
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
 -> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
  -> Const Position TextDocumentPositionParams)
 -> HoverRequest -> Const Position HoverRequest)
-> ((Position -> Const Position Position)
    -> TextDocumentPositionParams
    -> Const Position TextDocumentPositionParams)
-> Getting Position HoverRequest Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position
  Expr Src Void
expr <- Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri
  (WellTyped
welltyped, WellTyped
_) <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr of
    Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Info, Text
"Can't infer type; code does not type-check.")
    Right (WellTyped, WellTyped)
wt -> (WellTyped, WellTyped)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) a. Monad m => a -> m a
return (WellTyped, WellTyped)
wt
  case (Int, Int) -> WellTyped -> Either String (Maybe Src, Expr Src Void)
typeAt (Int
line,Int
col) WellTyped
welltyped of
    Left String
err -> (Severity, Text) -> HandlerM ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, String -> Text
Text.pack String
err)
    Right (Maybe Src
mSrc, Expr Src Void
typ) ->
      let _range :: Maybe Range
_range = (Src -> Range) -> Maybe Src -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Range -> Range
rangeToJSON (Range -> Range) -> (Src -> Range) -> Src -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Src -> Range
rangeFromDhall) Maybe Src
mSrc
          _contents :: HoverContents
_contents = MarkupContent -> HoverContents
J.HoverContents (MarkupContent -> HoverContents) -> MarkupContent -> HoverContents
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
J.MarkupContent MarkupKind
J.MkPlainText (Expr Src Void -> Text
forall a. Pretty a => a -> Text
pretty Expr Src Void
typ)
          hover :: Hover
hover = Hover :: HoverContents -> Maybe Range -> Hover
J.Hover{Maybe Range
HoverContents
_contents :: HoverContents
_range :: Maybe Range
$sel:_contents:Hover :: HoverContents
$sel:_range:Hover :: Maybe Range
..}
      in (ResponseMessage (Maybe Hover) -> FromServerMessage)
-> HoverRequest -> Maybe Hover -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (Maybe Hover) -> FromServerMessage
LSP.RspHover HoverRequest
request (Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover
hover)

hoverHandler :: J.HoverRequest -> HandlerM ()
hoverHandler :: HoverRequest -> HandlerM ()
hoverHandler HoverRequest
request = do
  let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
  -> Const Uri TextDocumentPositionParams)
 -> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentPositionParams
    -> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
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
J.uri
  Map Uri DhallError
errorMap <- Getting (Map Uri DhallError) ServerState (Map Uri DhallError)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Map Uri DhallError)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map Uri DhallError) ServerState (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors
  case Uri -> Map Uri DhallError -> Maybe DhallError
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Uri
uri Map Uri DhallError
errorMap of
    Maybe DhallError
Nothing -> HoverRequest -> HandlerM ()
hoverType HoverRequest
request
    Maybe DhallError
_ -> HoverRequest -> HandlerM ()
hoverExplain HoverRequest
request


documentLinkHandler :: J.DocumentLinkRequest -> HandlerM ()
documentLinkHandler :: DocumentLinkRequest -> HandlerM ()
documentLinkHandler DocumentLinkRequest
req = do
  let uri :: Uri
uri = DocumentLinkRequest
req DocumentLinkRequest -> Getting Uri DocumentLinkRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DocumentLinkParams -> Const Uri DocumentLinkParams)
-> DocumentLinkRequest -> Const Uri DocumentLinkRequest
forall s a. HasParams s a => Lens' s a
J.params ((DocumentLinkParams -> Const Uri DocumentLinkParams)
 -> DocumentLinkRequest -> Const Uri DocumentLinkRequest)
-> ((Uri -> Const Uri Uri)
    -> DocumentLinkParams -> Const Uri DocumentLinkParams)
-> Getting Uri DocumentLinkRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentLinkParams -> Const Uri DocumentLinkParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentLinkParams -> Const Uri DocumentLinkParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DocumentLinkParams
-> Const Uri DocumentLinkParams
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
J.uri
  String
path <- case Uri -> Maybe String
J.uriToFilePath Uri
uri of
    Maybe String
Nothing -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not process document links; failed to convert URI to file path.")
    Just String
p -> String -> ExceptT (Severity, Text) (StateT ServerState IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
    Right Expr Src Import
e -> Expr Src Import
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
    Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not process document links; did not parse.")

  let imports :: [(Range, Import)]
imports = Expr Src Import -> [(Range, Import)]
forall a. Expr Src a -> [(Range, a)]
embedsWithRanges Expr Src Import
expr :: [(Range, Import)]

  let basePath :: String
basePath = String -> String
takeDirectory String
path

  let go :: (Range, Import) -> IO [J.DocumentLink]
      go :: (Range, Import) -> IO [DocumentLink]
go (Range
range, Import (ImportHashed Maybe SHA256Digest
_ (Local FilePrefix
prefix File
file)) ImportMode
_) = do
        String
filePath <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
        let filePath' :: String
filePath' = String
basePath String -> String -> String
</> String
filePath  -- absolute file path
        let url' :: Uri
url' = String -> Uri
J.filePathToUri String
filePath'
        let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
        let _target :: Maybe Text
_target = Text -> Maybe Text
forall a. a -> Maybe a
Just (Uri -> Text
J.getUri Uri
url')
        [DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Text -> DocumentLink
J.DocumentLink {Maybe Text
Range
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Text
_target :: Maybe Text
_range :: Range
..}]

      go (Range
range, Import (ImportHashed Maybe SHA256Digest
_ (Remote URL
url)) ImportMode
_) = do
        let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
        let url' :: URL
url' = URL
url { headers :: Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
forall a. Maybe a
Nothing }
        let _target :: Maybe Text
_target = Text -> Maybe Text
forall a. a -> Maybe a
Just (URL -> Text
forall a. Pretty a => a -> Text
pretty URL
url')
        [DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Text -> DocumentLink
J.DocumentLink {Maybe Text
Range
_target :: Maybe Text
_range :: Range
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Text
..}]

      go (Range, Import)
_ = [DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  [[DocumentLink]]
links <- IO [[DocumentLink]]
-> ExceptT
     (Severity, Text) (StateT ServerState IO) [[DocumentLink]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[DocumentLink]]
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) [[DocumentLink]])
-> IO [[DocumentLink]]
-> ExceptT
     (Severity, Text) (StateT ServerState IO) [[DocumentLink]]
forall a b. (a -> b) -> a -> b
$ ((Range, Import) -> IO [DocumentLink])
-> [(Range, Import)] -> IO [[DocumentLink]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range, Import) -> IO [DocumentLink]
go [(Range, Import)]
imports
  (ResponseMessage (List DocumentLink) -> FromServerMessage)
-> DocumentLinkRequest -> List DocumentLink -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (List DocumentLink) -> FromServerMessage
LSP.RspDocumentLink DocumentLinkRequest
req ([DocumentLink] -> List DocumentLink
forall a. [a] -> List a
J.List ([[DocumentLink]] -> [DocumentLink]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DocumentLink]]
links))


diagnosticsHandler :: J.Uri -> HandlerM ()
diagnosticsHandler :: Uri -> HandlerM ()
diagnosticsHandler Uri
uri = do
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
  -- make sure we don't keep a stale version around
  ASetter ServerState ServerState Cache Cache
-> (Cache -> Cache) -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache (FileIdentifier -> Cache -> Cache
invalidate FileIdentifier
fileIdentifier)
  Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache

  Maybe DhallError
errs <- (ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
 -> (DhallError
     -> ExceptT
          (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (DhallError
    -> ExceptT
         (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> (DhallError
    -> ExceptT
         (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (Maybe DhallError
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DhallError
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (DhallError -> Maybe DhallError)
-> DhallError
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhallError -> Maybe DhallError
forall a. a -> Maybe a
Just) (ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
 -> ExceptT
      (Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b. (a -> b) -> a -> b
$ do
      Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
        Right Expr Src Import
e -> Expr Src Import
-> ExceptT DhallError (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
        Left DhallError
err -> DhallError
-> ExceptT DhallError (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
      Either DhallError (Cache, Expr Src Void)
loaded <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     DhallError
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
 -> ExceptT
      DhallError
      (StateT ServerState IO)
      (Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     DhallError
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
expr Cache
cache
      (Cache
cache', Expr Src Void
expr') <- case Either DhallError (Cache, Expr Src Void)
loaded of
        Right (Cache, Expr Src Void)
x -> (Cache, Expr Src Void)
-> ExceptT
     DhallError (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache, Expr Src Void)
x
        Left DhallError
err -> DhallError
-> ExceptT
     DhallError (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
      WellTyped
_ <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr' of
        Right (WellTyped
wt, WellTyped
_typ) -> WellTyped -> ExceptT DhallError (StateT ServerState IO) WellTyped
forall (m :: * -> *) a. Monad m => a -> m a
return WellTyped
wt
        Left DhallError
err -> DhallError -> ExceptT DhallError (StateT ServerState IO) WellTyped
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
      ASetter ServerState ServerState Cache Cache
-> Cache -> ExceptT DhallError (StateT ServerState IO) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
      Maybe DhallError
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DhallError
forall a. Maybe a
Nothing

  let suggestions :: [Suggestion]
suggestions =
        case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
          Right Expr Src Import
expr -> Expr Src Import -> [Suggestion]
suggest Expr Src Import
expr
          Either DhallError (Expr Src Import)
_ -> []

      suggestionToDiagnostic :: Suggestion -> Diagnostic
suggestionToDiagnostic Suggestion {Text
Range
suggestion :: Suggestion -> Text
range :: Suggestion -> Range
suggestion :: Text
range :: Range
..} =
        let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
            _severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsHint
            _source :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Dhall.Lint"
            _code :: Maybe a
_code = Maybe a
forall a. Maybe a
Nothing
            _message :: Text
_message = Text
suggestion
            _tags :: Maybe a
_tags = Maybe a
forall a. Maybe a
Nothing
            _relatedInformation :: Maybe a
_relatedInformation = Maybe a
forall a. Maybe a
Nothing
        in Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic {Maybe Text
Maybe NumberOrString
Maybe DiagnosticSeverity
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
forall a. Maybe a
$sel:_range:Diagnostic :: Range
$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
$sel:_code:Diagnostic :: Maybe NumberOrString
$sel:_source:Diagnostic :: Maybe Text
$sel:_message:Diagnostic :: Text
$sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation :: forall a. Maybe a
_tags :: forall a. Maybe a
_message :: Text
_code :: forall a. Maybe a
_source :: Maybe Text
_severity :: Maybe DiagnosticSeverity
_range :: Range
..}

      diagnosisToDiagnostic :: Diagnosis -> Diagnostic
diagnosisToDiagnostic Diagnosis {Maybe Range
Text
diagnosis :: Diagnosis -> Text
range :: Diagnosis -> Maybe Range
doctor :: Diagnosis -> Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
..} =
        let _range :: Range
_range = case Maybe Range
range of
              Just Range
range' ->
                Range -> Range
rangeToJSON Range
range'
              Maybe Range
Nothing -> Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
0 Int
0)
            _severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsError
            _source :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
doctor
            _code :: Maybe a
_code = Maybe a
forall a. Maybe a
Nothing
            _tags :: Maybe a
_tags = Maybe a
forall a. Maybe a
Nothing
            _message :: Text
_message = Text
diagnosis
            _relatedInformation :: Maybe a
_relatedInformation = Maybe a
forall a. Maybe a
Nothing
        in Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic {Maybe Text
Maybe NumberOrString
Maybe DiagnosticSeverity
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
forall a. Maybe a
_relatedInformation :: forall a. Maybe a
_message :: Text
_tags :: forall a. Maybe a
_code :: forall a. Maybe a
_source :: Maybe Text
_severity :: Maybe DiagnosticSeverity
_range :: Range
$sel:_range:Diagnostic :: Range
$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
$sel:_code:Diagnostic :: Maybe NumberOrString
$sel:_source:Diagnostic :: Maybe Text
$sel:_message:Diagnostic :: Text
$sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
..}

      diagnostics :: [Diagnostic]
diagnostics = (DhallError -> [Diagnostic]) -> [DhallError] -> [Diagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Diagnosis -> Diagnostic) -> [Diagnosis] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map Diagnosis -> Diagnostic
diagnosisToDiagnostic ([Diagnosis] -> [Diagnostic])
-> (DhallError -> [Diagnosis]) -> DhallError -> [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhallError -> [Diagnosis]
diagnose) (Maybe DhallError -> [DhallError]
forall a. Maybe a -> [a]
maybeToList Maybe DhallError
errs)
                     [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. [a] -> [a] -> [a]
++ (Suggestion -> Diagnostic) -> [Suggestion] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map Suggestion -> Diagnostic
suggestionToDiagnostic [Suggestion]
suggestions

  ASetter
  ServerState ServerState (Map Uri DhallError) (Map Uri DhallError)
-> (Map Uri DhallError -> Map Uri DhallError) -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  ServerState ServerState (Map Uri DhallError) (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors ((Maybe DhallError -> Maybe DhallError)
-> Uri -> Map Uri DhallError -> Map Uri DhallError
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe DhallError -> Maybe DhallError -> Maybe DhallError
forall a b. a -> b -> a
const Maybe DhallError
errs) Uri
uri)  -- cache errors
  (NotificationMessage ServerMethod PublishDiagnosticsParams
 -> FromServerMessage)
-> ServerMethod -> PublishDiagnosticsParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod PublishDiagnosticsParams
-> FromServerMessage
LSP.NotPublishDiagnostics ServerMethod
J.TextDocumentPublishDiagnostics
                      (Uri -> List Diagnostic -> PublishDiagnosticsParams
J.PublishDiagnosticsParams Uri
uri ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
J.List [Diagnostic]
diagnostics))


documentFormattingHandler :: J.DocumentFormattingRequest -> HandlerM ()
documentFormattingHandler :: DocumentFormattingRequest -> HandlerM ()
documentFormattingHandler DocumentFormattingRequest
request = do
  let uri :: Uri
uri = DocumentFormattingRequest
request DocumentFormattingRequest
-> Getting Uri DocumentFormattingRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> DocumentFormattingRequest -> Const Uri DocumentFormattingRequest
forall s a. HasParams s a => Lens' s a
J.params ((DocumentFormattingParams -> Const Uri DocumentFormattingParams)
 -> DocumentFormattingRequest
 -> Const Uri DocumentFormattingRequest)
-> ((Uri -> Const Uri Uri)
    -> DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> Getting Uri DocumentFormattingRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentFormattingParams -> Const Uri DocumentFormattingParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DocumentFormattingParams
-> Const Uri DocumentFormattingParams
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
J.uri
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri

  (Header
header, Expr Src Import
expr) <- case Text -> Either DhallError (Header, Expr Src Import)
parseWithHeader Text
txt of
    Right (Header, Expr Src Import)
res -> (Header, Expr Src Import)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header, Expr Src Import)
res
    Either DhallError (Header, Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to format dhall code; parse error.")

  ServerConfig {Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig

  let formatted :: Text
formatted = Maybe CharacterSet -> Expr Src Import -> Header -> Text
forall b.
Pretty b =>
Maybe CharacterSet -> Expr Src b -> Header -> Text
formatExprWithHeader Maybe CharacterSet
chosenCharacterSet Expr Src Import
expr Header
header
      numLines :: Int
numLines = Text -> Int
Text.length Text
txt
      range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
numLines Int
0)
      edits :: List TextEdit
edits = [TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
formatted]

  (ResponseMessage (List TextEdit) -> FromServerMessage)
-> DocumentFormattingRequest -> List TextEdit -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (List TextEdit) -> FromServerMessage
LSP.RspDocumentFormatting DocumentFormattingRequest
request List TextEdit
edits


executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM ()
executeCommandHandler :: ExecuteCommandRequest -> HandlerM ()
executeCommandHandler ExecuteCommandRequest
request
  | Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.lint" = ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat ExecuteCommandRequest
request
  | Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.annotateLet" = ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet ExecuteCommandRequest
request
  | Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeImport" = ExecuteCommandRequest -> HandlerM ()
executeFreezeImport ExecuteCommandRequest
request
  | Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeAllImports" = ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports ExecuteCommandRequest
request
  | Bool
otherwise = (Severity, Text) -> HandlerM ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Command '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
command
                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not known; ignored.")
  where command :: Text
command = ExecuteCommandRequest
request ExecuteCommandRequest
-> Getting Text ExecuteCommandRequest Text -> Text
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
J.params ((ExecuteCommandParams -> Const Text ExecuteCommandParams)
 -> ExecuteCommandRequest -> Const Text ExecuteCommandRequest)
-> ((Text -> Const Text Text)
    -> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting Text ExecuteCommandRequest Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
J.command

getCommandArguments :: J.FromJSON a => J.ExecuteCommandRequest -> HandlerM a
getCommandArguments :: ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request = do
  Value
json <- case ExecuteCommandRequest
request ExecuteCommandRequest
-> Getting
     (Maybe (List Value)) ExecuteCommandRequest (Maybe (List Value))
-> Maybe (List Value)
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams
 -> Const (Maybe (List Value)) ExecuteCommandParams)
-> ExecuteCommandRequest
-> Const (Maybe (List Value)) ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
J.params ((ExecuteCommandParams
  -> Const (Maybe (List Value)) ExecuteCommandParams)
 -> ExecuteCommandRequest
 -> Const (Maybe (List Value)) ExecuteCommandRequest)
-> ((Maybe (List Value)
     -> Const (Maybe (List Value)) (Maybe (List Value)))
    -> ExecuteCommandParams
    -> Const (Maybe (List Value)) ExecuteCommandParams)
-> Getting
     (Maybe (List Value)) ExecuteCommandRequest (Maybe (List Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (List Value)
 -> Const (Maybe (List Value)) (Maybe (List Value)))
-> ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams
forall s a. HasArguments s a => Lens' s a
J.arguments of
    Just (J.List (Value
x : [Value]
_)) -> Value -> ExceptT (Severity, Text) (StateT ServerState IO) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
    Maybe (List Value)
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to execute command; arguments missing.")
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
    J.Success a
args -> a -> HandlerM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
args
    Result a
_ -> (Severity, Text) -> HandlerM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to execute command; failed to parse arguments.")


-- implements dhall.server.lint
executeLintAndFormat :: J.ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat :: ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat ExecuteCommandRequest
request = do
  Uri
uri <- ExecuteCommandRequest -> HandlerM Uri
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri

  (Header
header, Expr Src Import
expr) <- case Text -> Either DhallError (Header, Expr Src Import)
parseWithHeader Text
txt of
    Right (Header, Expr Src Import)
res -> (Header, Expr Src Import)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header, Expr Src Import)
res
    Either DhallError (Header, Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to lint dhall code; parse error.")

  ServerConfig {Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig

  let linted :: Text
linted = Maybe CharacterSet -> Expr Src Import -> Header -> Text
forall b.
Pretty b =>
Maybe CharacterSet -> Expr Src b -> Header -> Text
formatExprWithHeader Maybe CharacterSet
chosenCharacterSet (Expr Src Import -> Expr Src Import
forall s. Expr s Import -> Expr s Import
lint Expr Src Import
expr) Header
header
      numLines :: Int
numLines = Text -> Int
Text.length Text
txt
      range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
numLines Int
0)
      edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
        (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
linted]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing

  (ResponseMessage Value -> FromServerMessage)
-> ExecuteCommandRequest -> Value -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage Value -> FromServerMessage
LSP.RspExecuteCommand ExecuteCommandRequest
request Value
J.Null
  (RequestMessage
   ServerMethod
   ApplyWorkspaceEditParams
   ApplyWorkspaceEditResponseBody
 -> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
    (WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)


executeAnnotateLet :: J.ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet :: ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet ExecuteCommandRequest
request = do
  TextDocumentPositionParams
args <- ExecuteCommandRequest -> HandlerM TextDocumentPositionParams
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request :: HandlerM J.TextDocumentPositionParams
  let uri :: Uri
uri = TextDocumentPositionParams
args TextDocumentPositionParams
-> ((Uri -> Const Uri Uri)
    -> TextDocumentPositionParams
    -> Const Uri TextDocumentPositionParams)
-> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
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
J.uri
      line :: Int
line = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> TextDocumentPositionParams
 -> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
      col :: Int
col = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> TextDocumentPositionParams
 -> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character

  Expr Src Void
expr <- Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri
  (WellTyped
welltyped, WellTyped
_) <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr of
    Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to annotate let binding; not well-typed.")
    Right (WellTyped, WellTyped)
e -> (WellTyped, WellTyped)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) a. Monad m => a -> m a
return (WellTyped, WellTyped)
e

  ServerConfig {Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig

  (Src (SourcePos String
_ Pos
x1 Pos
y1) (SourcePos String
_ Pos
x2 Pos
y2) Text
_, Expr Src Void
annotExpr)
    <- case (Int, Int) -> WellTyped -> Either String (Src, Expr Src Void)
annotateLet (Int
line, Int
col) WellTyped
welltyped of
      Right (Src, Expr Src Void)
x -> (Src, Expr Src Void)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Src, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Src, Expr Src Void)
x
      Left String
msg -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Src, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, String -> Text
Text.pack String
msg)

  let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position (Pos -> Int
unPos Pos
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Pos -> Int
unPos Pos
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                      (Int -> Int -> Position
J.Position (Pos -> Int
unPos Pos
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Pos -> Int
unPos Pos
y2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      txt :: Text
txt = Maybe CharacterSet -> Expr Src Void -> Text
forall b. Pretty b => Maybe CharacterSet -> Expr Src b -> Text
formatExpr Maybe CharacterSet
chosenCharacterSet Expr Src Void
annotExpr
      edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
        (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
txt]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing

  (RequestMessage
   ServerMethod
   ApplyWorkspaceEditParams
   ApplyWorkspaceEditResponseBody
 -> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
    (WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)


executeFreezeAllImports :: J.ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports :: ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports ExecuteCommandRequest
request = do
  Uri
uri <- ExecuteCommandRequest -> HandlerM Uri
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request

  FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
    Right Expr Src Import
e -> Expr Src Import
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
    Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Could not freeze imports; did not parse.")

  let importRanges :: [(Import, Range)]
importRanges = Expr Src Import -> [(Import, Range)]
getAllImportsWithHashPositions Expr Src Import
expr
  [TextEdit]
edits <- [(Import, Range)]
-> ((Import, Range)
    -> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
-> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Import, Range)]
importRanges (((Import, Range)
  -> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
 -> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit])
-> ((Import, Range)
    -> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
-> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit]
forall a b. (a -> b) -> a -> b
$ \(Import
import_, Range (Int
x1, Int
y1) (Int
x2, Int
y2)) -> do
    Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
    let importExpr :: Expr s Import
importExpr = Import -> Expr s Import
forall s a. a -> Expr s a
Embed (Import -> Import
stripHash Import
import_)

    Either DhallError (Cache, Text)
hashResult <- IO (Either DhallError (Cache, Text))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Text))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Text))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import -> Cache -> IO (Either DhallError (Cache, Text))
computeSemanticHash FileIdentifier
fileIdentifier Expr Src Import
forall s. Expr s Import
importExpr Cache
cache
    (Cache
cache', Text
hash) <- case Either DhallError (Cache, Text)
hashResult of
      Right (Cache
c, Text
t) -> (Cache, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
c, Text
t)
      Left DhallError
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Could not freeze import; failed to evaluate import.")
    ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'

    let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)
    TextEdit
-> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> Text -> TextEdit
J.TextEdit Range
range (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash))

  let workspaceEdit :: WorkspaceEdit
workspaceEdit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
        (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [TextEdit]
edits))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing
  (RequestMessage
   ServerMethod
   ApplyWorkspaceEditParams
   ApplyWorkspaceEditResponseBody
 -> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
    (WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
workspaceEdit)


executeFreezeImport :: J.ExecuteCommandRequest -> HandlerM ()
executeFreezeImport :: ExecuteCommandRequest -> HandlerM ()
executeFreezeImport ExecuteCommandRequest
request = do
  TextDocumentPositionParams
args <- ExecuteCommandRequest -> HandlerM TextDocumentPositionParams
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request :: HandlerM J.TextDocumentPositionParams
  let uri :: Uri
uri = TextDocumentPositionParams
args TextDocumentPositionParams
-> ((Uri -> Const Uri Uri)
    -> TextDocumentPositionParams
    -> Const Uri TextDocumentPositionParams)
-> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> TextDocumentPositionParams
 -> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
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
J.uri
      line :: Int
line = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> TextDocumentPositionParams
 -> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
      col :: Int
col = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> TextDocumentPositionParams
 -> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character

  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
    Right Expr Src Import
e -> Expr Src Import
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
    Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Could not freeze import; did not parse.")

  (Src
src, Import
import_)
    <- case (Int, Int) -> Expr Src Import -> Maybe (Expr Src Import)
forall a. (Int, Int) -> Expr Src a -> Maybe (Expr Src a)
exprAt (Int
line, Int
col) Expr Src Import
expr of
      Just (Note Src
src (Embed Import
i)) -> (Src, Import)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Src, Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Src
src, Import
i)
      Maybe (Expr Src Import)
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Src, Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"You weren't pointing at an import!")

  Range (Int
x1, Int
y1) (Int
x2, Int
y2) <- case Src -> Maybe Range
getImportHashPosition Src
src of
      Just Range
range -> Range -> ExceptT (Severity, Text) (StateT ServerState IO) Range
forall (m :: * -> *) a. Monad m => a -> m a
return Range
range
      Maybe Range
Nothing -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) Range
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to re-parse import!")

  FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
  Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
  let importExpr :: Expr s Import
importExpr = Import -> Expr s Import
forall s a. a -> Expr s a
Embed (Import -> Import
stripHash Import
import_)

  Either DhallError (Cache, Text)
hashResult <- IO (Either DhallError (Cache, Text))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Text))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Text))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import -> Cache -> IO (Either DhallError (Cache, Text))
computeSemanticHash FileIdentifier
fileIdentifier Expr Src Import
forall s. Expr s Import
importExpr Cache
cache
  (Cache
cache', Text
hash) <- case Either DhallError (Cache, Text)
hashResult of
    Right (Cache
c, Text
t) -> (Cache, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
c, Text
t)
    Left DhallError
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Could not freeze import; failed to evaluate import.")
  ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'

  let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)
      edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
        (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash)]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing

  (RequestMessage
   ServerMethod
   ApplyWorkspaceEditParams
   ApplyWorkspaceEditResponseBody
 -> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
    (WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)

completionHandler :: J.CompletionRequest -> HandlerM ()
completionHandler :: CompletionRequest -> HandlerM ()
completionHandler CompletionRequest
request = do
  let uri :: Uri
uri = CompletionRequest
request CompletionRequest -> Getting Uri CompletionRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Uri CompletionParams)
-> CompletionRequest -> Const Uri CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Uri CompletionParams)
 -> CompletionRequest -> Const Uri CompletionRequest)
-> ((Uri -> Const Uri Uri)
    -> CompletionParams -> Const Uri CompletionParams)
-> Getting Uri CompletionRequest 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
J.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
J.uri
      line :: Int
line = CompletionRequest
request CompletionRequest -> Getting Int CompletionRequest Int -> Int
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Int CompletionParams)
 -> CompletionRequest -> Const Int CompletionRequest)
-> ((Int -> Const Int Int)
    -> CompletionParams -> Const Int CompletionParams)
-> Getting Int CompletionRequest Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> CompletionParams -> Const Int CompletionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> CompletionParams
-> Const Int CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
      col :: Int
col = CompletionRequest
request CompletionRequest -> Getting Int CompletionRequest Int -> Int
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Int CompletionParams)
 -> CompletionRequest -> Const Int CompletionRequest)
-> ((Int -> Const Int Int)
    -> CompletionParams -> Const Int CompletionParams)
-> Getting Int CompletionRequest Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
 -> CompletionParams -> Const Int CompletionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> CompletionParams
-> Const Int CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character

  Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
  let (Text
completionLeadup, Text
completionPrefix) = Text -> (Int, Int) -> (Text, Text)
completionQueryAt Text
txt (Int
line, Int
col)

  let computeCompletions :: ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
computeCompletions
        -- environment variable
        | Text
"env:" Text -> Text -> Bool
`isPrefixOf` Text
completionPrefix =
          IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Completion]
completeEnvironmentImport

        -- local import
        | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`isPrefixOf` Text
completionPrefix) [ Text
"/", Text
"./", Text
"../", Text
"~/" ] = do
          let relativeTo :: String
relativeTo | Just String
path <- Uri -> Maybe String
J.uriToFilePath Uri
uri = String
path
                         | Bool
otherwise = String
"."
          IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Completion]
 -> ExceptT (Severity, Text) (StateT ServerState IO) [Completion])
-> IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO [Completion]
completeLocalImport String
relativeTo (Text -> String
Text.unpack Text
completionPrefix)

        -- record projection / union constructor
        | (Text
target, Text
_) <- Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." Text
completionPrefix
        , Bool -> Bool
not (Text -> Bool
Text.null Text
target) = do
          let bindersExpr :: Expr Src Import
bindersExpr = Text -> Expr Src Import
binderExprFromText Text
completionLeadup

          FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
          Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
          Either DhallError (Cache, Expr Src Void)
loadedBinders <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
bindersExpr Cache
cache

          (Cache
cache', Expr Src Void
bindersExpr') <-
            case Either DhallError (Cache, Expr Src Void)
loadedBinders of
              Right (Cache
cache', Expr Src Void
binders) ->
                (Cache, Expr Src Void)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
cache', Expr Src Void
binders)
              Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; failed to load binders expression.")

          let completionContext :: CompletionContext
completionContext = Expr Src Void -> CompletionContext
buildCompletionContext Expr Src Void
bindersExpr'

          Expr Src Import
targetExpr <- case Text -> Either DhallError (Expr Src Import)
parse (Int -> Text -> Text
Text.dropEnd Int
1 Text
target) of
            Right Expr Src Import
e -> Expr Src Import
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
            Left DhallError
_ -> (Severity, Text)
-> ExceptT
     (Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; prefix did not parse.")

          Either DhallError (Cache, Expr Src Void)
loaded' <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
targetExpr Cache
cache'
          case Either DhallError (Cache, Expr Src Void)
loaded' of
            Right (Cache
cache'', Expr Src Void
targetExpr') -> do
              ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache''
              [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionContext -> Expr Src Void -> [Completion]
completeProjections CompletionContext
completionContext Expr Src Void
targetExpr')
            Left DhallError
_ -> [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return []

        -- complete identifiers in scope
        | Bool
otherwise = do
          let bindersExpr :: Expr Src Import
bindersExpr = Text -> Expr Src Import
binderExprFromText Text
completionLeadup

          FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
          Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache  -- todo save cache afterwards
          Either DhallError (Cache, Expr Src Void)
loadedBinders <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
 -> ExceptT
      (Severity, Text)
      (StateT ServerState IO)
      (Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
     (Severity, Text)
     (StateT ServerState IO)
     (Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
bindersExpr Cache
cache

          Expr Src Void
bindersExpr' <-
            case Either DhallError (Cache, Expr Src Void)
loadedBinders of
              Right (Cache
cache', Expr Src Void
binders) -> do
                ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
                Expr Src Void -> HandlerM (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
binders
              Left DhallError
_ -> (Severity, Text) -> HandlerM (Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; failed to load binders expression.")

          let context :: CompletionContext
context = Expr Src Void -> CompletionContext
buildCompletionContext Expr Src Void
bindersExpr'
          [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionContext -> [Completion]
completeFromContext CompletionContext
context)

  [Completion]
completions <- ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
computeCompletions

  let item :: Completion -> CompletionItem
item (Completion {Maybe (Expr Src Void)
Text
completeType :: Completion -> Maybe (Expr Src Void)
completeText :: Completion -> Text
completeType :: Maybe (Expr Src Void)
completeText :: Text
..}) = CompletionItem :: Text
-> Maybe CompletionItemKind
-> Maybe (List CompletionItemTag)
-> Maybe Text
-> Maybe CompletionDoc
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe TextEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
J.CompletionItem {Maybe Bool
Maybe Text
Maybe Value
Maybe CompletionItemKind
Maybe InsertTextFormat
Maybe CompletionDoc
Maybe TextEdit
Maybe Command
Maybe (List Text)
Maybe (List CompletionItemTag)
Maybe (List TextEdit)
Text
forall a. Maybe a
$sel:_label:CompletionItem :: Text
$sel:_kind:CompletionItem :: Maybe CompletionItemKind
$sel:_tags:CompletionItem :: Maybe (List CompletionItemTag)
$sel:_detail:CompletionItem :: Maybe Text
$sel:_documentation:CompletionItem :: Maybe CompletionDoc
$sel:_deprecated:CompletionItem :: Maybe Bool
$sel:_preselect:CompletionItem :: Maybe Bool
$sel:_sortText:CompletionItem :: Maybe Text
$sel:_filterText:CompletionItem :: Maybe Text
$sel:_insertText:CompletionItem :: Maybe Text
$sel:_insertTextFormat:CompletionItem :: Maybe InsertTextFormat
$sel:_textEdit:CompletionItem :: Maybe TextEdit
$sel:_additionalTextEdits:CompletionItem :: Maybe (List TextEdit)
$sel:_commitCharacters:CompletionItem :: Maybe (List Text)
$sel:_command:CompletionItem :: Maybe Command
$sel:_xdata:CompletionItem :: Maybe Value
_xdata :: forall a. Maybe a
_command :: forall a. Maybe a
_commitCharacters :: forall a. Maybe a
_additionalTextEdits :: forall a. Maybe a
_textEdit :: forall a. Maybe a
_insertTextFormat :: forall a. Maybe a
_insertText :: forall a. Maybe a
_filterText :: forall a. Maybe a
_sortText :: forall a. Maybe a
_preselect :: forall a. Maybe a
_deprecated :: forall a. Maybe a
_documentation :: forall a. Maybe a
_detail :: Maybe Text
_tags :: Maybe (List CompletionItemTag)
_kind :: forall a. Maybe a
_label :: Text
..}
       where
        _label :: Text
_label = Text
completeText
        _kind :: Maybe a
_kind = Maybe a
forall a. Maybe a
Nothing
#if MIN_VERSION_haskell_lsp(0,21,0)
        _tags :: Maybe (List CompletionItemTag)
_tags = Maybe (List CompletionItemTag)
forall a. Monoid a => a
mempty
#endif
        _detail :: Maybe Text
_detail = (Expr Src Void -> Text) -> Maybe (Expr Src Void) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Void -> Text
forall a. Pretty a => a -> Text
pretty Maybe (Expr Src Void)
completeType
        _documentation :: Maybe a
_documentation = Maybe a
forall a. Maybe a
Nothing
        _deprecated :: Maybe a
_deprecated = Maybe a
forall a. Maybe a
Nothing
        _preselect :: Maybe a
_preselect = Maybe a
forall a. Maybe a
Nothing
        _sortText :: Maybe a
_sortText = Maybe a
forall a. Maybe a
Nothing
        _filterText :: Maybe a
_filterText = Maybe a
forall a. Maybe a
Nothing
        _insertText :: Maybe a
_insertText = Maybe a
forall a. Maybe a
Nothing
        _insertTextFormat :: Maybe a
_insertTextFormat = Maybe a
forall a. Maybe a
Nothing
        _textEdit :: Maybe a
_textEdit = Maybe a
forall a. Maybe a
Nothing
        _additionalTextEdits :: Maybe a
_additionalTextEdits = Maybe a
forall a. Maybe a
Nothing
        _commitCharacters :: Maybe a
_commitCharacters = Maybe a
forall a. Maybe a
Nothing
        _command :: Maybe a
_command = Maybe a
forall a. Maybe a
Nothing
        _xdata :: Maybe a
_xdata = Maybe a
forall a. Maybe a
Nothing
  (ResponseMessage CompletionResponseResult -> FromServerMessage)
-> CompletionRequest -> CompletionResponseResult -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage CompletionResponseResult -> FromServerMessage
LSP.RspCompletion CompletionRequest
request (CompletionResponseResult -> HandlerM ())
-> CompletionResponseResult -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ List CompletionItem -> CompletionResponseResult
J.Completions ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List ((Completion -> CompletionItem) -> [Completion] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Completion -> CompletionItem
item [Completion]
completions))


-- handler that doesn't do anything. Useful for example to make haskell-lsp shut
-- up about unhandled DidChangeTextDocument notifications (which are already
-- handled haskell-lsp itself).
nullHandler :: a -> HandlerM ()
nullHandler :: a -> HandlerM ()
nullHandler a
_ = () -> HandlerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

didOpenTextDocumentNotificationHandler
  :: J.DidOpenTextDocumentNotification -> HandlerM ()
didOpenTextDocumentNotificationHandler :: DidOpenTextDocumentNotification -> HandlerM ()
didOpenTextDocumentNotificationHandler DidOpenTextDocumentNotification
notification = do
  let uri :: Uri
uri = DidOpenTextDocumentNotification
notification DidOpenTextDocumentNotification
-> Getting Uri DidOpenTextDocumentNotification Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> DidOpenTextDocumentNotification
-> Const Uri DidOpenTextDocumentNotification
forall s a. HasParams s a => Lens' s a
J.params ((DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
 -> DidOpenTextDocumentNotification
 -> Const Uri DidOpenTextDocumentNotification)
-> ((Uri -> Const Uri Uri)
    -> DidOpenTextDocumentParams
    -> Const Uri DidOpenTextDocumentParams)
-> Getting Uri DidOpenTextDocumentNotification Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentItem -> Const Uri TextDocumentItem)
-> DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentItem -> Const Uri TextDocumentItem)
 -> DidOpenTextDocumentParams
 -> Const Uri DidOpenTextDocumentParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentItem -> Const Uri TextDocumentItem)
-> (Uri -> Const Uri Uri)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentItem -> Const Uri TextDocumentItem
forall s a. HasUri s a => Lens' s a
J.uri
  Uri -> HandlerM ()
diagnosticsHandler Uri
uri

didSaveTextDocumentNotificationHandler
  :: J.DidSaveTextDocumentNotification -> HandlerM ()
didSaveTextDocumentNotificationHandler :: DidSaveTextDocumentNotification -> HandlerM ()
didSaveTextDocumentNotificationHandler DidSaveTextDocumentNotification
notification = do
  let uri :: Uri
uri = DidSaveTextDocumentNotification
notification DidSaveTextDocumentNotification
-> Getting Uri DidSaveTextDocumentNotification Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> DidSaveTextDocumentNotification
-> Const Uri DidSaveTextDocumentNotification
forall s a. HasParams s a => Lens' s a
J.params ((DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
 -> DidSaveTextDocumentNotification
 -> Const Uri DidSaveTextDocumentNotification)
-> ((Uri -> Const Uri Uri)
    -> DidSaveTextDocumentParams
    -> Const Uri DidSaveTextDocumentParams)
-> Getting Uri DidSaveTextDocumentNotification Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DidSaveTextDocumentParams
 -> Const Uri DidSaveTextDocumentParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams
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
J.uri
  Uri -> HandlerM ()
diagnosticsHandler Uri
uri