From 8dba10b48c2bf0a17b114f70e92921fef7aa018c Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 4 Aug 2025 15:33:10 -0700 Subject: [PATCH 01/47] typo: consumer --- src/Monad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monad.hs b/src/Monad.hs index 3726b86..563c340 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -78,7 +78,7 @@ provideCommand iotcm = do controller <- asks envCommandController liftIO $ CommandController.put controller iotcm --- | Consumter +-- | Consumer consumeCommand :: (Monad m, MonadIO m) => Env -> m IOTCM consumeCommand env = liftIO $ CommandController.take (envCommandController env) From 2c5a2f2be58365d0a0c184e87131508a2bb1644e Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 4 Aug 2025 18:43:45 -0700 Subject: [PATCH 02/47] set up basic indexing infrastructure --- agda-language-server.cabal | 10 ++++++ src/Language/LSP/Protocol/Types/Uri/More.hs | 16 ++++++++++ src/Monad.hs | 7 ++++- src/Server/Model.hs | 15 +++++++++ src/Server/Model/AgdaFile.hs | 10 ++++++ src/Server/Model/AgdaLib.hs | 25 +++++++++++++++ src/Server/Model/Symbol.hs | 34 +++++++++++++++++++++ 7 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 src/Language/LSP/Protocol/Types/Uri/More.hs create mode 100644 src/Server/Model.hs create mode 100644 src/Server/Model/AgdaFile.hs create mode 100644 src/Server/Model/AgdaLib.hs create mode 100644 src/Server/Model/Symbol.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 378b857..d5add18 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -53,6 +53,7 @@ library Agda.Parser Agda.Position Control.Concurrent.SizedChan + Language.LSP.Protocol.Types.Uri.More Monad Options Render @@ -70,6 +71,10 @@ library Server Server.CommandController Server.Handler + Server.Model + Server.Model.AgdaFile + Server.Model.AgdaLib + Server.Model.Symbol Server.ResponseController Switchboard other-modules: @@ -177,6 +182,7 @@ test-suite als-test Agda.Parser Agda.Position Control.Concurrent.SizedChan + Language.LSP.Protocol.Types.Uri.More Monad Options Render @@ -194,6 +200,10 @@ test-suite als-test Server Server.CommandController Server.Handler + Server.Model + Server.Model.AgdaFile + Server.Model.AgdaLib + Server.Model.Symbol Server.ResponseController Switchboard Paths_agda_language_server diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs new file mode 100644 index 0000000..efadd4b --- /dev/null +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -0,0 +1,16 @@ +module Language.LSP.Protocol.Types.Uri.More (isUriAncestorOf) where + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Types as LSP + +getNormalizedUri :: LSP.NormalizedUri -> Text +getNormalizedUri = LSP.getUri . LSP.fromNormalizedUri + +-- | Determine if the first URI is an ancestor of the second. +-- +-- This is a heuristic implementation and may need replacement if the heuristic +-- leads to bugs. +isUriAncestorOf :: LSP.NormalizedUri -> LSP.NormalizedUri -> Bool +isUriAncestorOf ancestor descendant = + getNormalizedUri ancestor `Text.isPrefixOf` getNormalizedUri descendant diff --git a/src/Monad.hs b/src/Monad.hs index 563c340..a798201 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -28,6 +28,9 @@ import Language.LSP.Server import Options import Server.CommandController (CommandController) import qualified Server.CommandController as CommandController +import Server.Model (Model) +import qualified Server.Model as Model +import Server.Model.AgdaLib (AgdaLib) import Server.ResponseController (ResponseController) import qualified Server.ResponseController as ResponseController @@ -40,7 +43,8 @@ data Env = Env envLogChan :: Chan Text, envCommandController :: CommandController, envResponseChan :: Chan Response, - envResponseController :: ResponseController + envResponseController :: ResponseController, + envModel :: !(IORef Model) } createInitEnv :: (MonadIO m, MonadLsp Config m) => Options -> m Env @@ -51,6 +55,7 @@ createInitEnv options = <*> liftIO CommandController.new <*> liftIO newChan <*> liftIO ResponseController.new + <*> liftIO (newIORef Model.empty) -------------------------------------------------------------------------------- diff --git a/src/Server/Model.hs b/src/Server/Model.hs new file mode 100644 index 0000000..90ae171 --- /dev/null +++ b/src/Server/Model.hs @@ -0,0 +1,15 @@ +module Server.Model (Model, empty) where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model.AgdaFile (AgdaFile) +import Server.Model.AgdaLib (AgdaLib) + +data Model = Model + { _modelAgdaLibs :: !([AgdaLib]), + _modelAgdaFiles :: !(Map LSP.Uri AgdaFile) + } + +empty :: Model +empty = Model [] Map.empty diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs new file mode 100644 index 0000000..ce4d52c --- /dev/null +++ b/src/Server/Model/AgdaFile.hs @@ -0,0 +1,10 @@ +module Server.Model.AgdaFile (AgdaFile) where + +import qualified Agda.Syntax.Abstract as A +import Data.Map (Map) +import Server.Model.Symbol (Ref, SymbolInfo) + +data AgdaFile = AgdaFile + { _agdaFileSymbols :: !(Map A.QName SymbolInfo), + _agdaFileRefs :: !(Map A.QName [Ref]) + } diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs new file mode 100644 index 0000000..d65a78d --- /dev/null +++ b/src/Server/Model/AgdaLib.hs @@ -0,0 +1,25 @@ +module Server.Model.AgdaLib + ( AgdaLib, + isAgdaLibForUri, + ) +where + +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.IORef (IORef) +import Agda.Utils.Lens (Lens', (<&>), (^.)) +import Data.Map (Map) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Types.Uri.More as LSP +import Server.Model.AgdaFile (AgdaFile) + +data AgdaLib = AgdaLib + { _agdaLibIncludes :: ![LSP.NormalizedUri], + _agdaLibTcState :: !(IORef TCM.TCState), + _agdaLibTcEnv :: !TCM.TCEnv + } + +agdaLibIncludes :: Lens' AgdaLib [LSP.NormalizedUri] +agdaLibIncludes f a = f (_agdaLibIncludes a) <&> \x -> a {_agdaLibIncludes = x} + +isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool +isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs new file mode 100644 index 0000000..5506f15 --- /dev/null +++ b/src/Server/Model/Symbol.hs @@ -0,0 +1,34 @@ +module Server.Model.Symbol (SymbolInfo, Ref) where + +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Position (Position, PositionWithoutFile) +import qualified Language.LSP.Protocol.Types as LSP + +data SymbolKind + = Con + | CoCon + | Field + | PatternSyn + | GeneralizeVar + | Macro + | Data + | Record + | Fun + | Axiom + | Prim + | Module + | Param + | Local + | Unknown + deriving (Show) + +data SymbolInfo = SymbolInfo + { _symbolKind :: !SymbolKind, + _symbolType :: !(Maybe String), + _symbolParent :: !(Maybe A.QName) + } + +data Ref = Ref + { _refSymbol :: !A.QName, + _refRange :: !LSP.Range + } From 2c0a0bf1f61c9e1532ff998009e7aeb1c5fc1df7 Mon Sep 17 00:00:00 2001 From: nvarner Date: Wed, 6 Aug 2025 18:52:43 -0700 Subject: [PATCH 03/47] look up indexed file to handle requests --- agda-language-server.cabal | 7 + src/Language/LSP/Protocol/Types/Uri/More.hs | 6 +- src/Monad.hs | 7 + src/Options.hs | 1 + src/Server.hs | 2 +- src/Server/Handler/Monad.hs | 176 ++++++++++++++++++ .../Handler/TextDocument/DocumentSymbol.hs | 18 ++ src/Server/Model.hs | 17 +- src/Server/Model/AgdaFile.hs | 15 +- src/Server/Model/AgdaLib.hs | 23 ++- test/Test.hs | 6 +- test/Test/HandlerMonad.hs | 92 +++++++++ test/Test/Model.hs | 59 ++++++ test/TestData.hs | 80 ++++++++ 14 files changed, 499 insertions(+), 10 deletions(-) create mode 100644 src/Server/Handler/Monad.hs create mode 100644 src/Server/Handler/TextDocument/DocumentSymbol.hs create mode 100644 test/Test/HandlerMonad.hs create mode 100644 test/Test/Model.hs create mode 100644 test/TestData.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index d5add18..7b83d61 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -71,6 +71,8 @@ library Server Server.CommandController Server.Handler + Server.Handler.Monad + Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib @@ -173,9 +175,12 @@ test-suite als-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Test.HandlerMonad Test.LSP + Test.Model Test.SrcLoc Test.WASM + TestData Agda Agda.Convert Agda.IR @@ -200,6 +205,8 @@ test-suite als-test Server Server.CommandController Server.Handler + Server.Handler.Monad + Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index efadd4b..f8c1b69 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -1,4 +1,8 @@ -module Language.LSP.Protocol.Types.Uri.More (isUriAncestorOf) where +module Language.LSP.Protocol.Types.Uri.More + ( getNormalizedUri, + isUriAncestorOf, + ) +where import Data.Text (Text) import qualified Data.Text as Text diff --git a/src/Monad.hs b/src/Monad.hs index a798201..ff0d346 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} module Monad where import Agda.IR import Agda.Interaction.Base (IOTCM) import Agda.TypeChecking.Monad (TCMT) +import Agda.Utils.Lens (Lens', (^.)) import Control.Concurrent import Control.Monad.Reader import Data.IORef @@ -77,6 +79,11 @@ writeLog' x = do chan <- asks envLogChan liftIO $ writeChan chan $ pack $ show x +askModel :: (MonadIO m) => ServerM m Model +askModel = do + modelVar <- asks envModel + liftIO $ readIORef modelVar + -- | Provider provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerM m () provideCommand iotcm = do diff --git a/src/Options.hs b/src/Options.hs index 27742d5..b5c3808 100644 --- a/src/Options.hs +++ b/src/Options.hs @@ -3,6 +3,7 @@ module Options ( Options (..), + defaultOptions, getOptionsFromArgv, versionNumber, versionString, diff --git a/src/Server.hs b/src/Server.hs index df833f4..db8cfbb 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -81,7 +81,7 @@ run options = do } lspOptions :: LSP.Options -lspOptions = defaultOptions {optTextDocumentSync = Just syncOptions} +lspOptions = LSP.defaultOptions {optTextDocumentSync = Just syncOptions} -- these `TextDocumentSyncOptions` are essential for receiving notifications from the client -- syncOptions :: TextDocumentSyncOptions diff --git a/src/Server/Handler/Monad.hs b/src/Server/Handler/Monad.hs new file mode 100644 index 0000000..863060b --- /dev/null +++ b/src/Server/Handler/Monad.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Server.Handler.Monad + ( MonadAgdaLib (..), + useAgdaLib, + MonadAgdaFile (..), + useAgdaFile, + withAgdaFile, + ) +where + +import Agda.Interaction.Options (CommandLineOptions (optPragmaOptions), PragmaOptions) +import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv, TCM, TCMT (..), TCState (stPersistentState), modifyTCLens, setTCLens, stPragmaOptions, useTC) +import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) +import Agda.Utils.Lens (Lens', locally, over, use, view, (<&>), (^.)) +import Agda.Utils.Monad (bracket_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks) +import Control.Monad.Trans (MonadTrans, lift) +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Types.Uri.More as LSP +import Language.LSP.Server (LspM) +import qualified Language.LSP.Server as LSP +import Monad (ServerM, askModel) +import Options (Config) +import qualified Server.Model as Model +import Server.Model.AgdaFile (AgdaFile) +import Server.Model.AgdaLib (AgdaLib, agdaLibTcEnv, agdaLibTcStateRef) + +-------------------------------------------------------------------------------- + +class (MonadTCM m, ReadTCState m) => MonadAgdaLib m where + askAgdaLib :: m AgdaLib + localAgdaLib :: (AgdaLib -> AgdaLib) -> m a -> m a + +useAgdaLib :: (MonadAgdaLib m) => Lens' AgdaLib a -> m a +useAgdaLib lens = do + agdaLib <- askAgdaLib + return $ agdaLib ^. lens + +class (MonadAgdaLib m) => MonadAgdaFile m where + askAgdaFile :: m AgdaFile + localAgdaFile :: (AgdaFile -> AgdaFile) -> m a -> m a + +useAgdaFile :: (MonadAgdaFile m) => Lens' AgdaFile a -> m a +useAgdaFile lens = do + agdaFile <- askAgdaFile + return $ agdaFile ^. lens + +-------------------------------------------------------------------------------- + +defaultAskTC :: (MonadAgdaLib m) => m TCEnv +defaultAskTC = useAgdaLib agdaLibTcEnv + +defaultLocalTC :: (MonadAgdaLib m) => (TCEnv -> TCEnv) -> m a -> m a +defaultLocalTC f = localAgdaLib (over agdaLibTcEnv f) + +defaultGetTC :: (MonadAgdaLib m) => m TCState +defaultGetTC = do + tcStateRef <- useAgdaLib agdaLibTcStateRef + liftIO $ readIORef tcStateRef + +defaultPutTC :: (MonadAgdaLib m) => TCState -> m () +defaultPutTC tcState = do + tcStateRef <- useAgdaLib agdaLibTcStateRef + liftIO $ writeIORef tcStateRef tcState + +defaultModifyTC :: (MonadAgdaLib m) => (TCState -> TCState) -> m () +defaultModifyTC f = do + tcStateRef <- useAgdaLib agdaLibTcStateRef + liftIO $ modifyIORef' tcStateRef f + +-- Taken from TCMT implementation +defaultLocallyTCState :: (MonadAgdaLib m) => Lens' TCState a -> (a -> a) -> m b -> m b +defaultLocallyTCState lens f = bracket_ (useTC lens <* modifyTCLens lens f) (setTCLens lens) + +-- Taken from TCMT implementation +defaultPragmaOptionsImpl :: (MonadAgdaLib m) => m PragmaOptions +defaultPragmaOptionsImpl = useTC stPragmaOptions + +-- Taken from TCMT implementation +defaultCommandLineOptionsImpl :: (MonadAgdaLib m) => m CommandLineOptions +defaultCommandLineOptionsImpl = do + p <- useTC stPragmaOptions + cl <- stPersistentOptions . stPersistentState <$> getTC + return $ cl {optPragmaOptions = p} + +defaultLiftTCM :: (MonadAgdaLib m) => TCM a -> m a +defaultLiftTCM (TCM f) = do + tcStateRef <- useAgdaLib agdaLibTcStateRef + tcEnv <- useAgdaLib agdaLibTcEnv + liftIO $ f tcStateRef tcEnv + +-------------------------------------------------------------------------------- + +data WithAgdaFileEnv = WithAgdaFileEnv + { _withAgdaFileEnvAgdaLib :: !AgdaLib, + _withAgdaFileEnvAgdaFile :: !AgdaFile + } + +withAgdaFileEnvAgdaLib :: Lens' WithAgdaFileEnv AgdaLib +withAgdaFileEnvAgdaLib f a = f (_withAgdaFileEnvAgdaLib a) <&> \x -> a {_withAgdaFileEnvAgdaLib = x} + +withAgdaFileEnvAgdaFile :: Lens' WithAgdaFileEnv AgdaFile +withAgdaFileEnvAgdaFile f a = f (_withAgdaFileEnvAgdaFile a) <&> \x -> a {_withAgdaFileEnvAgdaFile = x} + +newtype WithAgdaFileT m a = WithAgdaFileT + {unWithAgdaFileT :: ReaderT WithAgdaFileEnv m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) + +runWithAgdaFileT :: AgdaLib -> AgdaFile -> WithAgdaFileT m a -> m a +runWithAgdaFileT agdaLib agdaFile = + let env = WithAgdaFileEnv agdaLib agdaFile + in flip runReaderT env . unWithAgdaFileT + +type WithAgdaFileM = WithAgdaFileT (ServerM (LspM Config)) + +type HandlerWithAgdaFile m = + LSP.TRequestMessage m -> + (Either (LSP.TResponseError m) (LSP.MessageResult m) -> WithAgdaFileM ()) -> + WithAgdaFileM () + +withAgdaFile :: + forall (m :: LSP.Method LSP.ClientToServer LSP.Request). + (LSP.HasTextDocument (LSP.MessageParams m) LSP.TextDocumentIdentifier) => + LSP.SMethod m -> + HandlerWithAgdaFile m -> + LSP.Handlers (ServerM (LspM Config)) +withAgdaFile m handler = LSP.requestHandler m $ \req responder -> do + let uri = req ^. LSP.params . LSP.textDocument . LSP.uri + normUri = LSP.toNormalizedUri uri + + model <- askModel + case Model.getAgdaFile normUri model of + Nothing -> do + let message = "Request for unknown Agda file at URI: " <> LSP.getUri uri + responder $ Left $ LSP.TResponseError (LSP.InR LSP.ErrorCodes_InvalidParams) message Nothing + Just agdaFile -> do + agdaLib <- Model.getAgdaLib normUri model + let responder' = lift . responder + runWithAgdaFileT agdaLib agdaFile $ handler req responder' + +instance (MonadIO m) => MonadAgdaLib (WithAgdaFileT m) where + askAgdaLib = WithAgdaFileT $ view withAgdaFileEnvAgdaLib + localAgdaLib f = WithAgdaFileT . locally withAgdaFileEnvAgdaLib f . unWithAgdaFileT + +instance (MonadIO m) => MonadAgdaFile (WithAgdaFileT m) where + askAgdaFile = WithAgdaFileT $ view withAgdaFileEnvAgdaFile + localAgdaFile f = WithAgdaFileT . locally withAgdaFileEnvAgdaFile f . unWithAgdaFileT + +instance (MonadIO m) => MonadTCEnv (WithAgdaFileT m) where + askTC = defaultAskTC + localTC = defaultLocalTC + +instance (MonadIO m) => MonadTCState (WithAgdaFileT m) where + getTC = defaultGetTC + putTC = defaultPutTC + modifyTC = defaultModifyTC + +instance (MonadIO m) => ReadTCState (WithAgdaFileT m) where + getTCState = defaultGetTC + locallyTCState = defaultLocallyTCState + +instance (MonadIO m) => HasOptions (WithAgdaFileT m) where + pragmaOptions = defaultPragmaOptionsImpl + commandLineOptions = defaultCommandLineOptionsImpl + +instance (MonadIO m) => MonadTCM (WithAgdaFileT m) where + liftTCM = defaultLiftTCM diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs new file mode 100644 index 0000000..71940b3 --- /dev/null +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -0,0 +1,18 @@ +module Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) where + +import Agda.Utils.Lens ((^.)) +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Server (LspM) +import qualified Language.LSP.Server as LSP +import Monad (ServerM) +import Options (Config) +import Server.Handler.Monad (useAgdaFile, withAgdaFile) +import qualified Server.Model as Model +import Server.Model.AgdaFile (agdaFileSymbols) + +documentSymbolHandler :: LSP.Handlers (ServerM (LspM Config)) +documentSymbolHandler = withAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do + symbols <- useAgdaFile agdaFileSymbols + return () diff --git a/src/Server/Model.hs b/src/Server/Model.hs index 90ae171..cc11217 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -1,15 +1,26 @@ -module Server.Model (Model, empty) where +module Server.Model (Model (Model), empty, getKnownAgdaLib, getAgdaLib, getAgdaFile) where +import Control.Monad.IO.Class (MonadIO) +import Data.Foldable (find) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.LSP.Protocol.Types as LSP import Server.Model.AgdaFile (AgdaFile) -import Server.Model.AgdaLib (AgdaLib) +import Server.Model.AgdaLib (AgdaLib, initAgdaLib, isAgdaLibForUri) data Model = Model { _modelAgdaLibs :: !([AgdaLib]), - _modelAgdaFiles :: !(Map LSP.Uri AgdaFile) + _modelAgdaFiles :: !(Map LSP.NormalizedUri AgdaFile) } empty :: Model empty = Model [] Map.empty + +getKnownAgdaLib :: LSP.NormalizedUri -> Model -> Maybe AgdaLib +getKnownAgdaLib uri = find (`isAgdaLibForUri` uri) . _modelAgdaLibs + +getAgdaLib :: (MonadIO m) => LSP.NormalizedUri -> Model -> m AgdaLib +getAgdaLib uri = maybe initAgdaLib return . getKnownAgdaLib uri + +getAgdaFile :: LSP.NormalizedUri -> Model -> Maybe AgdaFile +getAgdaFile uri = Map.lookup uri . _modelAgdaFiles diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index ce4d52c..afabdc6 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -1,10 +1,23 @@ -module Server.Model.AgdaFile (AgdaFile) where +module Server.Model.AgdaFile + ( AgdaFile, + emptyAgdaFile, + agdaFileSymbols, + ) +where import qualified Agda.Syntax.Abstract as A +import Agda.Utils.Lens (Lens', (<&>)) import Data.Map (Map) +import qualified Data.Map as Map import Server.Model.Symbol (Ref, SymbolInfo) data AgdaFile = AgdaFile { _agdaFileSymbols :: !(Map A.QName SymbolInfo), _agdaFileRefs :: !(Map A.QName [Ref]) } + +emptyAgdaFile :: AgdaFile +emptyAgdaFile = AgdaFile Map.empty Map.empty + +agdaFileSymbols :: Lens' AgdaFile (Map A.QName SymbolInfo) +agdaFileSymbols f a = f (_agdaFileSymbols a) <&> \x -> a {_agdaFileSymbols = x} diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index d65a78d..24b5df2 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -1,12 +1,17 @@ module Server.Model.AgdaLib - ( AgdaLib, + ( AgdaLib (AgdaLib), + initAgdaLib, + agdaLibIncludes, + agdaLibTcStateRef, + agdaLibTcEnv, isAgdaLibForUri, ) where import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.IORef (IORef) +import Agda.Utils.IORef (IORef, newIORef) import Agda.Utils.Lens (Lens', (<&>), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Map (Map) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP @@ -14,12 +19,24 @@ import Server.Model.AgdaFile (AgdaFile) data AgdaLib = AgdaLib { _agdaLibIncludes :: ![LSP.NormalizedUri], - _agdaLibTcState :: !(IORef TCM.TCState), + _agdaLibTcStateRef :: !(IORef TCM.TCState), _agdaLibTcEnv :: !TCM.TCEnv } +initAgdaLib :: (MonadIO m) => m AgdaLib +initAgdaLib = do + tcStateRef <- liftIO $ newIORef TCM.initState + let tcEnv = TCM.initEnv + return $ AgdaLib [] tcStateRef tcEnv + agdaLibIncludes :: Lens' AgdaLib [LSP.NormalizedUri] agdaLibIncludes f a = f (_agdaLibIncludes a) <&> \x -> a {_agdaLibIncludes = x} +agdaLibTcStateRef :: Lens' AgdaLib (IORef TCM.TCState) +agdaLibTcStateRef f a = f (_agdaLibTcStateRef a) <&> \x -> a {_agdaLibTcStateRef = x} + +agdaLibTcEnv :: Lens' AgdaLib TCM.TCEnv +agdaLibTcEnv f a = f (_agdaLibTcEnv a) <&> \x -> a {_agdaLibTcEnv = x} + isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) diff --git a/test/Test.hs b/test/Test.hs index cb14b2a..67d8960 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -9,6 +9,8 @@ import qualified Test.WASM as WASM #endif import Test.Tasty import Test.Tasty.Options +import qualified Test.Model as Model +import qualified Test.HandlerMonad as HandlerMonad -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -31,7 +33,9 @@ tests = askOption $ \(AlsPathOption alsPath) -> testGroup "Tests" [ SrcLoc.tests, - LSP.tests alsPath + LSP.tests alsPath, + Model.tests, + HandlerMonad.tests #if defined(wasm32_HOST_ARCH) , WASM.tests alsPath #endif diff --git a/test/Test/HandlerMonad.hs b/test/Test/HandlerMonad.hs new file mode 100644 index 0000000..768bb43 --- /dev/null +++ b/test/Test/HandlerMonad.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Test.HandlerMonad (tests) where + +import Agda.Utils.Either (isLeft, isRight) +import Agda.Utils.IORef (newIORef, readIORef, writeIORef) +import Agda.Utils.Lens ((^.)) +import Control.Concurrent (newChan) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap +import qualified Language.LSP.Server as LSP +import Monad (Env (Env, envModel), ServerM, createInitEnv, runServerM) +import Options (Config, defaultOptions, initConfig) +import qualified Server.CommandController as CommandController +import Server.Handler.Monad (MonadAgdaLib (askAgdaLib), withAgdaFile) +import Server.Model (Model) +import Server.Model.AgdaLib (agdaLibIncludes) +import qualified Server.ResponseController as ResponseController +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?), (@?=)) +import qualified TestData + +tests :: TestTree +tests = + testGroup + "Handler monads" + [ testGroup + "WithAgdaFileM" + [ testCase "gets known Agda file" $ do + let method = LSP.SMethod_TextDocumentDocumentSymbol + message = TestData.documentSymbolMessage TestData.fileUri1 + + let handlers = withAgdaFile method $ \req responder -> do + agdaLib <- askAgdaLib + liftIO $ length (agdaLib ^. agdaLibIncludes) @?= 3 + responder $ Right $ LSP.InL [] + + model <- TestData.getModel + result <- runHandler method message model handlers + + isRight result @? "didn't get known Agda file: " <> show result + + return (), + testCase "fails on unknown Agda file" $ do + let method = LSP.SMethod_TextDocumentDocumentSymbol + message = TestData.documentSymbolMessage TestData.fakeUri + + let handlers = withAgdaFile method $ \req responder -> do + responder $ Right $ LSP.InL [] + + model <- TestData.getModel + result <- runHandler method message model handlers + + isLeft result @? "got Agda file, but should be unknown" + + return () + ] + ] + +runHandler :: + forall (m :: LSP.Method LSP.ClientToServer LSP.Request). + (Show (LSP.ErrorData m)) => + LSP.SMethod m -> + LSP.TRequestMessage m -> + Model -> + LSP.Handlers (ServerM (LSP.LspM Config)) -> + IO (Either (LSP.TResponseError m) (LSP.MessageResult m)) +runHandler m request model handlers = do + resultRef <- newIORef Nothing + let callback = \response -> liftIO $ writeIORef resultRef (Just response) + + let Just (LSP.ClientMessageHandler handler) = SMethodMap.lookup m $ LSP.reqHandlers handlers + + LSP.runLspT undefined $ do + env <- + Env defaultOptions True initConfig + <$> liftIO newChan + <*> liftIO CommandController.new + <*> liftIO newChan + <*> liftIO ResponseController.new + <*> liftIO (newIORef model) + runServerM env $ do + handler request callback + + Just result <- readIORef resultRef + return result diff --git a/test/Test/Model.hs b/test/Test/Model.hs new file mode 100644 index 0000000..e4f5432 --- /dev/null +++ b/test/Test/Model.hs @@ -0,0 +1,59 @@ +module Test.Model (tests) where + +import Agda.Utils.Lens (set, (<&>), (^.)) +import Agda.Utils.Maybe (isJust, isNothing) +import qualified Data.Map as Map +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model (Model (Model)) +import qualified Server.Model as Model +import Server.Model.AgdaFile (emptyAgdaFile) +import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?), (@?=)) +import qualified TestData + +tests :: TestTree +tests = + testGroup + "Model" + [ testCase "getKnownAgdaLib gets known Agda lib" $ do + model <- TestData.getModel + + let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri1 model + length (agdaLib ^. agdaLibIncludes) @?= 3 + + let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri2 model + length (agdaLib ^. agdaLibIncludes) @?= 1 + + let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri3 model + length (agdaLib ^. agdaLibIncludes) @?= 3 + + return (), + testCase "getKnownAgdaLib fails on unknown Agda lib" $ do + model <- TestData.getModel + + let result = Model.getKnownAgdaLib TestData.fakeUri model + isNothing result @? "got Agda lib, but should be unknown" + + return (), + testCase "getAgdaFile gets known Agda file" $ do + model <- TestData.getModel + + let result = Model.getAgdaFile TestData.fileUri1 model + isJust result @? "didn't get known Agda file" + + let result = Model.getAgdaFile TestData.fileUri2 model + isJust result @? "didn't get known Agda file" + + let result = Model.getAgdaFile TestData.fileUri3 model + isJust result @? "didn't get known Agda file" + + return (), + testCase "getAgdaFile fails on unknown Agda file" $ do + model <- TestData.getModel + + let result = Model.getAgdaFile TestData.fakeUri model + isNothing result @? "got Agda file, but should be unknown" + + return () + ] diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 index 0000000..d2528ee --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} + +module TestData + ( documentSymbolMessage, + getModel, + fileUri1, + fileUri2, + fileUri3, + fakeUri, + ) +where + +import Agda.Utils.Lens (set, (<&>)) +import qualified Data.Map as Map +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model (Model (Model)) +import Server.Model.AgdaFile (emptyAgdaFile) +import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) + +documentSymbolMessage :: LSP.NormalizedUri -> LSP.TRequestMessage LSP.Method_TextDocumentDocumentSymbol +documentSymbolMessage uri = + let params = + LSP.DocumentSymbolParams + Nothing + Nothing + (LSP.TextDocumentIdentifier $ LSP.fromNormalizedUri uri) + in LSP.TRequestMessage + "2.0" + (LSP.IdInt 0) + LSP.SMethod_TextDocumentDocumentSymbol + params + +-------------------------------------------------------------------------------- + +fileUri1 :: LSP.NormalizedUri +fileUri1 = LSP.toNormalizedUri $ LSP.Uri "file:///home/user2/project2/A/B/C.agda" + +fileUri2 :: LSP.NormalizedUri +fileUri2 = LSP.toNormalizedUri $ LSP.Uri "file:///home/user/project2/X.agda" + +fileUri3 :: LSP.NormalizedUri +fileUri3 = LSP.toNormalizedUri $ LSP.Uri "https://example.com/agda/Main.agda" + +fakeUri :: LSP.NormalizedUri +fakeUri = LSP.toNormalizedUri $ LSP.Uri "file:///home/user2/project/Test.agda" + +getModel :: IO Model +getModel = do + let includes1 = + LSP.toNormalizedUri . LSP.Uri + <$> [ "file:///home/user/project1/", + "file:///home/user2/project2/", + "https://example.com/agda/" + ] + testLib1 <- + initAgdaLib + <&> set agdaLibIncludes includes1 + + let includes2 = + LSP.toNormalizedUri . LSP.Uri + <$> ["file:///home/user/project2/"] + testLib2 <- + initAgdaLib + <&> set agdaLibIncludes includes2 + + let libs = [testLib1, testLib2] + + let testFile1 = emptyAgdaFile + let testFile2 = emptyAgdaFile + let testFile3 = emptyAgdaFile + + let files = + Map.fromList + [ (fileUri1, testFile1), + (fileUri2, testFile2), + (fileUri3, testFile3) + ] + + return $ Model libs files From c6348c2b6d1f992f1118bac79bff75397b4b7679 Mon Sep 17 00:00:00 2001 From: nvarner Date: Tue, 12 Aug 2025 16:39:20 -0700 Subject: [PATCH 04/47] rough edged indexer --- agda-language-server.cabal | 20 +- src/Agda/Interaction/Imports/More.hs | 50 ++ src/Agda/Position.hs | 40 +- src/Indexer.hs | 127 ++++ src/Indexer/Indexer.hs | 622 ++++++++++++++++++ src/Indexer/Monad.hs | 218 ++++++ src/Language/LSP/Protocol/Types/More.hs | 24 + .../Handler/TextDocument/DocumentSymbol.hs | 18 - src/Server/Model/AgdaFile.hs | 27 +- src/Server/{Handler => Model}/Monad.hs | 49 +- src/Server/Model/Symbol.hs | 62 +- test/Test.hs | 28 +- test/Test/Indexer/Invariants.hs | 54 ++ test/Test/Indexer/NoOverlap.hs | 152 +++++ test/Test/{HandlerMonad.hs => ModelMonad.hs} | 18 +- test/TestData.hs | 19 + test/data/Indexer/Basic.agda | 54 ++ 17 files changed, 1512 insertions(+), 70 deletions(-) create mode 100644 src/Agda/Interaction/Imports/More.hs create mode 100644 src/Indexer.hs create mode 100644 src/Indexer/Indexer.hs create mode 100644 src/Indexer/Monad.hs create mode 100644 src/Language/LSP/Protocol/Types/More.hs delete mode 100644 src/Server/Handler/TextDocument/DocumentSymbol.hs rename src/Server/{Handler => Model}/Monad.hs (81%) create mode 100644 test/Test/Indexer/Invariants.hs create mode 100644 test/Test/Indexer/NoOverlap.hs rename test/Test/{HandlerMonad.hs => ModelMonad.hs} (87%) create mode 100644 test/data/Indexer/Basic.agda diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 7b83d61..7592b1b 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -49,10 +49,15 @@ library exposed-modules: Agda Agda.Convert + Agda.Interaction.Imports.More Agda.IR Agda.Parser Agda.Position Control.Concurrent.SizedChan + Indexer + Indexer.Indexer + Indexer.Monad + Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad Options @@ -71,11 +76,10 @@ library Server Server.CommandController Server.Handler - Server.Handler.Monad - Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.Monad Server.Model.Symbol Server.ResponseController Switchboard @@ -175,18 +179,25 @@ test-suite als-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: - Test.HandlerMonad + Test.Indexer.Invariants + Test.Indexer.NoOverlap Test.LSP Test.Model + Test.ModelMonad Test.SrcLoc Test.WASM TestData Agda Agda.Convert + Agda.Interaction.Imports.More Agda.IR Agda.Parser Agda.Position Control.Concurrent.SizedChan + Indexer + Indexer.Indexer + Indexer.Monad + Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad Options @@ -205,11 +216,10 @@ test-suite als-test Server Server.CommandController Server.Handler - Server.Handler.Monad - Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.Monad Server.Model.Symbol Server.ResponseController Switchboard diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs new file mode 100644 index 0000000..37ac8d5 --- /dev/null +++ b/src/Agda/Interaction/Imports/More.hs @@ -0,0 +1,50 @@ +-- | This module reexports unexported functions +module Agda.Interaction.Imports.More + ( setOptionsFromSourcePragmas, + checkModuleName', + ) +where + +import Agda.Interaction.FindFile (SourceFile, checkModuleName) +import Agda.Interaction.Imports (Source) +import qualified Agda.Interaction.Imports as Imp +import Agda.Interaction.Library (OptionsPragma (..), _libPragmas) +import Agda.Syntax.Common (TopLevelModuleName') +import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.Position (Range) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) +import Agda.TypeChecking.Monad (Interface, TCM, checkAndSetOptionsFromPragma, setCurrentRange, setOptionsFromPragma, setTCLens, stPragmaOptions, useTC) +import Agda.Utils.Monad (bracket_) + +srcDefaultPragmas :: Imp.Source -> [OptionsPragma] +srcDefaultPragmas src = map _libPragmas (Imp.srcProjectLibs src) + +srcFilePragmas :: Imp.Source -> [OptionsPragma] +srcFilePragmas src = pragmas + where + cpragmas = C.modPragmas (Imp.srcModule src) + pragmas = + [ OptionsPragma + { pragmaStrings = opts, + pragmaRange = r + } + | C.OptionsPragma r opts <- cpragmas + ] + +-- | Set options from a 'Source' pragma, using the source +-- ranges of the pragmas for error reporting. Flag to check consistency. +setOptionsFromSourcePragmas :: Bool -> Imp.Source -> TCM () +setOptionsFromSourcePragmas checkOpts src = do + mapM_ setOpts (srcDefaultPragmas src) + mapM_ setOpts (srcFilePragmas src) + where + setOpts + | checkOpts = checkAndSetOptionsFromPragma + | otherwise = setOptionsFromPragma + +-- Andreas, 2016-07-11, issue 2092 +-- The error range should be set to the file with the wrong module name +-- not the importing one (which would be the default). +checkModuleName' :: TopLevelModuleName' Range -> SourceFile -> TCM () +checkModuleName' m f = + setCurrentRange m $ checkModuleName m f Nothing diff --git a/src/Agda/Position.hs b/src/Agda/Position.hs index 3e65b88..4122326 100644 --- a/src/Agda/Position.hs +++ b/src/Agda/Position.hs @@ -10,8 +10,8 @@ module Agda.Position toAgdaPositionWithoutFile, toAgdaRange, prettyPositionWithoutFile, - -- , toLSPRange - -- , toLSPPosition + toLspRange, + toLspPosition, ) where @@ -64,6 +64,31 @@ prettyPositionWithoutFile pos@(Pn () offset _line _col) = -------------------------------------------------------------------------------- +-- | Agda source locations => LSP source locations + +intervalStart :: Interval -> PositionWithoutFile +intervalEnd :: Interval -> PositionWithoutFile + +#if MIN_VERSION_Agda(2,8,0) +intervalStart (Interval _ start _end) = start +intervalEnd (Interval _ _start end) = end +#else +intervalStart (Interval start _end) = start +intervalEnd (Interval _start end) = end +#endif + +-- | Agda Range -> LSP Range +toLspRange :: Range -> LSP.Range +toLspRange range = case rangeToIntervalWithFile range of + Nothing -> LSP.Range (LSP.Position (-1) (-1)) (LSP.Position (-1) (-1)) + Just interval -> LSP.Range (toLspPosition $ intervalStart interval) (toLspPosition $ intervalEnd interval) + +-- | Agda Position -> LSP Position +toLspPosition :: Position' a -> LSP.Position +toLspPosition (Pn _ offset line col) = LSP.Position (fromIntegral line - 1) (fromIntegral col - 1) + +-------------------------------------------------------------------------------- + -- | Positon => Offset convertion -- Keeps record of offsets of every line break ("\n", "\r" and "\r\n") @@ -142,14 +167,3 @@ makeFromOffset = go (Accum previous n l table) '\r' = Accum (Just '\r') (1 + n) (1 + l) (IntMap.insert (1 + n) (1 + l) table) go (Accum previous n l table) char = Accum (Just char) (1 + n) l table - --- -------------------------------------------------------------------------------- --- -- | Agda Highlighting Range -> Agda Range - --- fromAgdaHighlightingRangeToLSPRange :: Range -> LSP.Range --- fromAgdaHighlightingRangeToLSPRange range = case rangeToIntervalWithFile range of --- Nothing -> LSP.Range (LSP.Position (-1) (-1)) (LSP.Position (-1) (-1)) --- Just (Interval start end) -> LSP.Range (toLSPPosition start) (toLSPPosition end) - --- toLSPPosition :: Position -> LSP.Position --- toLSPPosition (Pn _ offset line col) = LSP.Position (fromIntegral line - 1) (fromIntegral col - 1) diff --git a/src/Indexer.hs b/src/Indexer.hs new file mode 100644 index 0000000..315c4c9 --- /dev/null +++ b/src/Indexer.hs @@ -0,0 +1,127 @@ +module Indexer (indexFile) where + +import Agda.Interaction.FindFile (SourceFile (SourceFile)) +import qualified Agda.Interaction.FindFile as Imp +import qualified Agda.Interaction.Imports as Imp +import qualified Agda.Interaction.Imports.More as Imp +import Agda.Interaction.Library (getPrimitiveLibDir) +import Agda.Interaction.Options (defaultOptions, optLoadPrimitives) +import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel)) +import Agda.Syntax.Translation.ReflectedToAbstract (toAbstract_) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.FileName (AbsolutePath, filePath, mkAbsolute) +import Agda.Utils.Monad (bracket_, unlessM, when) +import qualified Agda.Utils.Trie as Trie +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Strict as Strict +import Indexer.Indexer (abstractToIndex) +import Server.Model.AgdaFile (AgdaFile) +import Server.Model.Monad (MonadAgdaLib, WithAgdaLibM) +import System.FilePath (()) + +indexFile :: + Imp.Source -> + WithAgdaLibM AgdaFile +indexFile src = do + currentOptions <- TCM.useTC TCM.stPragmaOptions + + TCM.liftTCM $ + TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ + -- Now reset the options + TCM.setCommandLineOptions . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC + + TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (Imp.srcFilePath $ Imp.srcOrigin src) + + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (Imp.srcFilePath $ Imp.srcOrigin src)}) $ do + let topLevel = + TopLevel + (Imp.srcFilePath $ Imp.srcOrigin src) + (Imp.srcModuleName src) + (C.modDecls $ Imp.srcModule src) + ast <- TCM.liftTCM $ toAbstract topLevel + abstractToIndex ast + +-- let options = defaultOptions + +-- TCM.liftTCM TCM.resetState + +-- TCM.liftTCM $ TCM.setCommandLineOptions' rootPath options +-- TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src +-- loadPrims <- optLoadPrimitives <$> TCM.pragmaOptions + +-- when loadPrims $ do +-- libdirPrim <- liftIO getPrimitiveLibDir + +-- -- Turn off import-chasing messages. +-- -- We have to modify the persistent verbosity setting, since +-- -- getInterface resets the current verbosity settings to the persistent ones. + +-- bracket_ (TCM.getsTC TCM.getPersistentVerbosity) TCM.putPersistentVerbosity $ do +-- TCM.modifyPersistentVerbosity +-- (Strict.Just . Trie.insert [] 0 . Strict.fromMaybe Trie.empty) +-- -- set root verbosity to 0 + +-- -- We don't want to generate highlighting information for Agda.Primitive. +-- TCM.liftTCM $ +-- TCM.withHighlightingLevel TCM.None $ +-- forM_ (Set.map (libdirPrim ) TCM.primitiveModules) $ \f -> do +-- primSource <- Imp.parseSource (SourceFile $ mkAbsolute f) +-- Imp.checkModuleName' (Imp.srcModuleName primSource) (Imp.srcOrigin primSource) +-- void $ Imp.getNonMainInterface (Imp.srcModuleName primSource) (Just primSource) + +-- TCM.liftTCM $ Imp.checkModuleName' (Imp.srcModuleName src) (Imp.srcOrigin src) + +-- addImportCycleCheck (Imp.srcModuleName src) $ +-- TCM.localTC (\e -> e {TCM.envCurrentPath = Just $ TCM.srcFileId srcFile}) $ do +-- let topLevel = +-- C.TopLevel +-- srcFile +-- (Imp.srcModuleName src) +-- (C.modDecls $ Imp.srcModule src) +-- ast <- TCM.liftTCM $ C.toAbstract topLevel + +-- deps <- TCM.useTC TCM.stImportedModulesTransitive +-- moduleToSourceId <- TCM.useTC TCM.stModuleToSourceId +-- forM_ deps $ maybeUpdateCacheForDepFile moduleToSourceId + +-- cache <- getCache +-- let entries = LSP.fromNormalizedUri . fst <$> Cache.getAllEntries cache +-- alwaysReportSDoc "lsp.cache" 20 $ return (text "cache entries:" <+> pretty entries) + +-- let ds = C.topLevelDecls ast +-- let scope = C.topLevelScope ast + +-- TCM.liftTCM TCM.activateLoadedFileCache + +-- TCM.liftTCM TCM.cachingStarts +-- opts <- TCM.liftTCM $ TCM.useTC TCM.stPragmaOptions +-- me <- TCM.liftTCM TCM.readFromCachedLog +-- case me of +-- Just (TCM.Pragmas opts', _) +-- | opts == opts' -> +-- return () +-- _ -> TCM.liftTCM TCM.cleanCachedLog +-- TCM.liftTCM $ TCM.writeToCurrentLog $ TCM.Pragmas opts + +-- TCM.liftTCM $ +-- mapM_ TC.checkDeclCached ds `TCM.finally_` TCM.cacheCurrentLog + +-- TCM.liftTCM TCM.unfreezeMetas + +-- TCM.liftTCM $ TCM.setScope scope + +-- TCM.liftTCM $ +-- TCM.stCurrentModule +-- `TCM.setTCLens'` Just +-- ( C.topLevelModuleName ast, +-- Imp.srcModuleName src +-- ) + +-- file <- Index.abstractToIndex $ C.topLevelDecls ast + +-- -- return (file, moduleToSourceId, deps) +-- return file diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs new file mode 100644 index 0000000..a490936 --- /dev/null +++ b/src/Indexer/Indexer.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Indexer.Indexer (abstractToIndex) where + +import qualified Agda.Syntax.Abstract as A +import qualified Agda.Syntax.Common as C +import Agda.Syntax.Common.Pretty (render) +import qualified Agda.Syntax.Concrete as C +import qualified Agda.Syntax.Info as Info +import qualified Agda.Syntax.Internal as I +import qualified Agda.Syntax.Literal as Lit +import qualified Agda.Syntax.Scope.Base as Scope +import Agda.Syntax.Translation.ConcreteToAbstract (TopLevelInfo (TopLevelInfo)) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.TypeChecking.Pretty (prettyTCM) +import Agda.Utils.Functor ((<&>)) +import Agda.Utils.List1 (List1) +import qualified Agda.Utils.List1 as List1 +import Agda.Utils.Maybe (whenJust) +import Data.Foldable (forM_, traverse_) +import qualified Data.Set as Set +import Data.Void (absurd) +import Indexer.Monad + ( AmbiguousNameLike (..), + HasParamNames (..), + IndexerM, + NameLike (..), + NoType (NoType), + SymbolKindLike (..), + TypeLike (..), + UnknownType (UnknownType), + execIndexerM, + tellDecl, + tellDef, + tellImport, + tellNamedArgUsage, + tellParamNames, + tellUsage, + withParent, + ) +import qualified Language.LSP.Server as LSP +import Monad (ServerM) +import Options (Config) +import Server.Model.AgdaFile (AgdaFile) +import Server.Model.Monad (WithAgdaLibM) +import Server.Model.Symbol (SymbolKind (..)) + +abstractToIndex :: TopLevelInfo -> WithAgdaLibM AgdaFile +abstractToIndex (TopLevelInfo decls _scope) = execIndexerM $ index decls + +class Indexable a where + index :: a -> IndexerM () + default index :: (Foldable f, Indexable b, a ~ f b) => a -> IndexerM () + index = traverse_ index + +instance Indexable A.Declaration where + index = \case + A.Axiom kindOfName defInfo _argInfo _polarities name type' -> do + tellDecl name kindOfName type' + index defInfo + index type' + A.Generalize _generalizeVars defInfo _argInfo name type' -> do + tellDecl name GeneralizeVar type' + index defInfo + index type' + A.Field defInfo name type' -> do + tellDecl name Field type' + index defInfo + index type' + A.Primitive defInfo name type' -> do + tellDecl name Prim type' + index defInfo + index type' + A.Mutual _mutualInfo decls -> + index decls + A.Section _range _erased moduleName genTel decls -> do + tellDecl moduleName Module NoType + tellParamNames moduleName genTel + index genTel + withParent moduleName $ do + index decls + A.Apply _moduleInfo _erased moduleName moduleApp _scopeCopyInfo importDirective -> do + tellUsage moduleName + index moduleApp + index importDirective + A.Import _moduleInfo moduleName importDirective -> do + tellUsage moduleName + index importDirective + A.Pragma _range pragma -> + index pragma + A.Open _moduleInfo moduleName importDirective -> do + tellUsage moduleName + index importDirective + A.FunDef _defInfo name clauses -> do + withParent name $ do + index clauses + A.DataSig defInfo _erased name genTel type' -> do + tellDecl name Data type' + index defInfo + index genTel + index type' + A.DataDef defInfo name _univCheck dataDefParams constructors -> do + tellDef name Data UnknownType + index defInfo + index dataDefParams + index constructors + A.RecSig defInfo _erased name genTel type' -> do + tellDecl name Record type' + index defInfo + index genTel + index type' + A.RecDef defInfo name _univCheck recDirectives dataDefParams type' decls -> do + tellDef name Record type' + index defInfo + index dataDefParams + index type' + withParent name $ do + index recDirectives + index decls + A.PatternSynDef name bindings pat -> do + tellDecl name PatternSyn UnknownType + forM_ bindings $ \(C.WithHiding _hiding binding) -> + tellDef binding Param UnknownType + let pat' :: A.Pattern = fmap absurd pat + index pat' + A.UnquoteDecl _mutualInfo defInfos names expr -> do + forM_ names $ \name -> + tellDef name Unknown UnknownType + index defInfos + index expr + A.UnquoteDef defInfos names expr -> do + forM_ names $ \name -> + tellDef name Unknown UnknownType + index defInfos + index expr + A.UnquoteData defInfos name _univCheck conDefInfos conNames expr -> do + tellDef name Data UnknownType + forM_ conNames $ \conName -> + tellDef conName Con UnknownType + index defInfos + index conDefInfos + index expr + A.ScopedDecl _scope decls -> + index decls + A.UnfoldingDecl _range names -> + forM_ names $ \name -> + tellUsage name + +instance Indexable A.Expr where + index = \case + A.Var name -> + tellUsage name + A.Def' name _suffix -> + tellUsage name + A.Proj _origin ambiguousName -> + tellUsage ambiguousName + A.Con ambiguousName -> + tellUsage ambiguousName + A.PatternSyn ambiguousName -> + tellUsage ambiguousName + A.Macro name -> + tellUsage name + A.Lit _exprInfo lit -> + index lit + A.QuestionMark _metaInfo _interactionId -> + return () + A.Underscore _metaInfo -> + return () + A.Dot _exprInfo expr' -> + index expr' + A.App _appInfo exprF exprArg -> do + index exprF + case funNameFromExpr exprF of + Just name -> indexNamedArgs name [exprArg] + Nothing -> index $ C.namedThing $ C.unArg exprArg + A.WithApp _appInfo exprF exprArgs -> do + index exprF + index exprArgs + A.Lam _exprInfo binding body -> do + index binding + index body + A.AbsurdLam _exprInfo _hiding -> + return () + A.ExtendedLam _exprInfo defInfo _erased _generatedFn clauses -> do + index defInfo + index clauses + A.Pi _exprInfo tel type' -> do + index tel + index type' + A.Generalized _generalizeVars type' -> do + index type' + A.Fun _exprInfo dom codom -> do + index dom + index codom + A.Let _exprInfo bindings body -> do + index bindings + index body + A.Rec _exprInfo recAssigns -> + index recAssigns + A.RecUpdate _exprInfo exprRec assigns -> do + index exprRec + index assigns + A.ScopedExpr _scope expr' -> + index expr' + A.Quote _exprInfo -> return () + A.QuoteTerm _exprInfo -> return () + A.Unquote _exprInfo -> return () + A.DontCare expr' -> index expr' + +funNameFromExpr :: A.Expr -> Maybe A.AmbiguousQName +funNameFromExpr = \case + A.Var name -> Just $ A.unambiguous $ A.qualify_ name + A.Def' name _suffix -> Just $ A.unambiguous name + A.Proj _origin name -> Just name + A.Con name -> Just name + A.PatternSyn name -> Just name + A.Dot _exprInfo expr -> funNameFromExpr expr + A.App _appInfo exprF _exprArgs -> funNameFromExpr exprF + A.WithApp _appInfo exprF _exprArgs -> funNameFromExpr exprF + A.ScopedExpr _scopeInfo expr -> funNameFromExpr expr + A.DontCare expr -> funNameFromExpr expr + _noFunName -> Nothing + +instance (Indexable a) => Indexable (A.Pattern' a) where + index = \case + A.VarP binding -> do + tellDef binding Local UnknownType + A.ConP _conPatInfo ambiguousName naps -> do + tellUsage ambiguousName + indexNamedArgs ambiguousName naps + A.ProjP _patInfo _projOrigin ambiguousName -> + tellUsage ambiguousName + A.DefP _patInfo ambiguousName naps -> do + tellUsage ambiguousName + indexNamedArgs ambiguousName naps + A.WildP _patInfo -> return () + A.AsP _patInfo binding pat' -> do + tellDef binding Local UnknownType + index pat' + A.DotP _patInfo expr -> + index expr + A.AbsurdP _patInfo -> return () + A.LitP _patInfo lit -> + index lit + A.PatternSynP _patInfo ambiguousName naps -> do + tellUsage ambiguousName + indexNamedArgs ambiguousName naps + A.EqualP _patInfo exprPairs -> + forM_ exprPairs $ \(lhs, rhs) -> do + index lhs + index rhs + A.WithP _patInfo pat' -> + index pat' + A.RecP _conPatInfo fieldAssignments -> + index fieldAssignments + A.AnnP _patInfo type' pat' -> do + index type' + index pat' + +instance (Indexable a) => Indexable (Maybe a) + +instance (Indexable a) => Indexable [a] + +instance (Indexable a) => Indexable (List1 a) + +instance (Indexable a) => Indexable (C.Arg a) + +instance Indexable A.TacticAttribute + +instance Indexable A.DefInfo where + index = index . Info.defTactic + +indexNamedArgs :: (AmbiguousNameLike n, Indexable a) => n -> [C.NamedArg a] -> IndexerM () +indexNamedArgs headNameLike args = do + let headName = toAmbiguousQName headNameLike + forM_ args $ \(C.Arg _argInfo (C.Named maybeName x)) -> do + whenJust maybeName $ tellNamedArgUsage headName + index x + +indexWithExpr :: A.WithExpr -> IndexerM () +indexWithExpr (C.Named maybeName (C.Arg _argInfo expr)) = do + whenJust maybeName $ \(A.BindName name) -> + tellDef name Param UnknownType + index expr + +instance Indexable Lit.Literal where + index = \case + Lit.LitQName name -> tellUsage name + _otherLit -> return () + +instance (Indexable a) => Indexable (C.FieldAssignment' a) where + index (C.FieldAssignment fieldCName expr) = do + scope <- TCM.getScope + let fieldNames = Scope.anameName <$> Scope.scopeLookup (C.QName fieldCName) scope + List1.ifNull fieldNames (return ()) $ \fieldNames1 -> do + let fieldName = A.AmbQ fieldNames1 + tellUsage fieldName + index expr + +instance Indexable A.RecordAssign where + index = \case + Left assign -> + index assign + Right moduleName -> + tellUsage moduleName + +instance Indexable A.WhereDeclarations where + index whereDecls = case whereDecls of + A.WhereDecls (Just moduleName) _ decl -> do + tellDecl moduleName Module NoType + withParent moduleName $ + index decl + A.WhereDecls Nothing _ decl -> + index decl + +instance (Indexable a) => Indexable (A.LHSCore' a) where + index core = case core of + A.LHSHead name pats -> do + tellDef name Param UnknownType + indexNamedArgs name pats + A.LHSProj destructor focus pats -> do + tellUsage destructor + -- TODO: what does the named arg in `focus` mean? + indexNamedArgs destructor [focus] + indexNamedArgs destructor pats + A.LHSWith lhsHead withPatterns pats -> do + index lhsHead + index withPatterns + -- TODO: what do the named args mean? + forM_ pats $ \(C.Arg _argInfo (C.Named _name pat)) -> + index pat + +instance Indexable A.LHS where + index (A.LHS lhsInfo core) = case Info.lhsEllipsis lhsInfo of + C.ExpandedEllipsis _range _withArgs -> return () + C.NoEllipsis -> index core + +instance Indexable A.RewriteEqn where + index eqn = case eqn of + C.Rewrite exprs -> + forM_ exprs $ \(_name, expr) -> + index expr + C.Invert _generatedFn bindings -> + forM_ bindings $ \(C.Named maybeName (pat, expr)) -> do + whenJust maybeName $ \bindName -> + tellDef bindName Param UnknownType + index pat + index expr + C.LeftLet bindings -> + forM_ bindings $ \(pat, expr) -> do + index pat + index expr + +instance Indexable A.RHS where + index rhs = case rhs of + A.RHS expr _concrete -> + index expr + A.AbsurdRHS -> + return () + A.WithRHS _generatedFn withExprs clauses -> do + forM_ withExprs indexWithExpr + index clauses + A.RewriteRHS rewriteExprs _strippedPats rewriteRhs whereDecls -> do + index rewriteExprs + index rewriteRhs + index whereDecls + +instance (Indexable a) => Indexable (A.Clause' a) where + index (A.Clause lhs _strippedPats rhs whereDecls _catchall) = do + index lhs + index rhs + index whereDecls + +instance Indexable A.ModuleApplication where + index = \case + A.SectionApp tele moduleName args -> do + index tele + tellUsage moduleName + indexNamedArgs moduleName args + A.RecordModuleInstance moduleName -> + tellUsage moduleName + +-- Since `HidingDirective' a b` is just `[ImportedName' a b]`, it's much more +-- explicit to give it a special function than try to use instance resolution. +indexHidingDirective :: C.HidingDirective' A.QName A.ModuleName -> IndexerM () +indexHidingDirective = traverse_ tellUsage + +instance Indexable A.Renaming where + index (C.Renaming fromName toName _toFixity _toRange) = do + tellUsage fromName + let toNameKind = case toName of + C.ImportedModule _moduleName -> Module + C.ImportedName _name -> Unknown + tellImport fromName + -- TODO: better handling of renamed imports + tellDef toName toNameKind UnknownType + +instance Indexable (C.Using' A.QName A.ModuleName) where + index using = case using of + C.UseEverything -> return () + C.Using importedNames -> traverse_ tellImport importedNames + +instance Indexable A.ImportDirective where + index (C.ImportDirective _range using hiding renaming _publicRange) = do + index using + indexHidingDirective hiding + index renaming + +instance Indexable A.LetBinding where + index = \case + A.LetBind _letInfo _argInfo boundName type' expr -> do + tellDef boundName Local type' + index type' + index expr + A.LetPatBind _letInfo pat expr -> do + index pat + index expr + A.LetApply _moduleInfo _erased moduleName moduleApp _scopeCopyInfo importDirective -> do + tellUsage moduleName + index moduleApp + index importDirective + A.LetOpen _moduleInfo moduleName importDirective -> do + tellUsage moduleName + index importDirective + A.LetDeclaredVariable boundName -> + tellDef boundName Local UnknownType + +indexNamedArgBinder :: + (TypeLike t, HasParamNames t) => + C.NamedArg A.Binder -> t -> IndexerM () +indexNamedArgBinder namedArgBinder typeLike = do + let A.Binder pat name = C.namedThing $ C.unArg namedArgBinder + tellDef name Param typeLike + index pat + +instance Indexable A.TypedBinding where + index = \case + A.TBind _range typedBindInfo binders type' -> do + index $ A.tbTacticAttr typedBindInfo + forM_ binders $ \binder -> + indexNamedArgBinder binder type' + index type' + A.TLet _range letBindings -> index letBindings + +instance Indexable A.LamBinding where + index lamBinding = case lamBinding of + A.DomainFree tacticAttr binder -> do + index tacticAttr + indexNamedArgBinder binder UnknownType + A.DomainFull binding -> + index binding + +instance Indexable A.GeneralizeTelescope where + index (A.GeneralizeTel _generalizeVars tel) = index tel + +instance Indexable A.DataDefParams where + index (A.DataDefParams _generalizeParams params) = index params + +instance Indexable A.RecordDirectives where + index = \case + (C.RecordDirectives inductive _hasEta _patRange (Just conName)) -> + tellDef conName (constructorSymbolKind inductive) UnknownType + _noUserConstructor -> return () + where + constructorSymbolKind :: Maybe (C.Ranged C.Induction) -> SymbolKind + constructorSymbolKind (Just (C.Ranged _range C.CoInductive)) = CoCon + constructorSymbolKind _inductive = Con + +instance Indexable A.Pragma where + index = \case + A.OptionsPragma _options -> + return () + A.BuiltinPragma _rstring resolvedName -> + whenJust (resolvedNameToAmbiguousQName resolvedName) $ \name -> + tellUsage name + A.BuiltinNoDefPragma _rstring kindOfName name -> do + tellDef name kindOfName UnknownType + A.RewritePragma _range ruleNames -> + forM_ ruleNames $ \ruleName -> + tellUsage ruleName + A.CompilePragma _backendName name _compileAs -> + tellUsage name + A.StaticPragma name -> + tellUsage name + A.EtaPragma name -> + tellUsage name + A.InjectivePragma name -> + tellUsage name + A.InjectiveForInferencePragma name -> + tellUsage name + A.InlinePragma _shouldInline name -> + tellUsage name + A.NotProjectionLikePragma name -> + tellUsage name + A.OverlapPragma name _overlapMode -> + tellUsage name + A.DisplayPragma name args displayExpr -> do + tellUsage name + indexNamedArgs name args + index displayExpr + +-------------------------------------------------------------------------------- + +instance NameLike A.QName where + toQName = id + +instance NameLike A.ModuleName where + toQName = A.mnameToQName + +instance NameLike A.Name where + toQName = A.qualify_ + +instance NameLike A.BindName where + toQName = toQName . A.unBind + +instance (NameLike n, NameLike m) => NameLike (C.ImportedName' n m) where + toQName (C.ImportedModule moduleName) = toQName moduleName + toQName (C.ImportedName name) = toQName name + +instance AmbiguousNameLike A.AmbiguousQName where + toAmbiguousQName = id + +instance AmbiguousNameLike A.QName where + toAmbiguousQName = A.unambiguous + +instance AmbiguousNameLike A.ModuleName where + toAmbiguousQName = toAmbiguousQName . A.mnameToQName + +instance AmbiguousNameLike A.Name where + toAmbiguousQName = toAmbiguousQName . A.qualify_ + +instance AmbiguousNameLike A.BindName where + toAmbiguousQName = toAmbiguousQName . A.unBind + +instance AmbiguousNameLike Scope.AbstractName where + toAmbiguousQName = toAmbiguousQName . Scope.anameName + +instance (AmbiguousNameLike n, AmbiguousNameLike m) => AmbiguousNameLike (C.ImportedName' n m) where + toAmbiguousQName (C.ImportedModule moduleName) = toAmbiguousQName moduleName + toAmbiguousQName (C.ImportedName name) = toAmbiguousQName name + +resolvedNameToAmbiguousQName :: Scope.ResolvedName -> Maybe A.AmbiguousQName +resolvedNameToAmbiguousQName = \case + Scope.VarName name _bindingSource -> Just $ toAmbiguousQName name + Scope.DefinedName _access name _suffix -> Just $ toAmbiguousQName name + Scope.FieldName name -> Just $ toAmbiguousQName name + Scope.ConstructorName _inductive name -> Just $ toAmbiguousQName name + Scope.PatternSynResName name -> Just $ toAmbiguousQName name + Scope.UnknownName -> Nothing + +instance SymbolKindLike SymbolKind where + toSymbolKind = id + +instance SymbolKindLike Scope.KindOfName where + toSymbolKind = \case + Scope.ConName -> Con + Scope.CoConName -> CoCon + Scope.FldName -> Field + Scope.PatternSynName -> PatternSyn + Scope.GeneralizeName -> GeneralizeVar + Scope.DisallowedGeneralizeName -> GeneralizeVar + Scope.MacroName -> Macro + Scope.QuotableName -> Unknown + Scope.DataName -> Data + Scope.RecName -> Record + Scope.FunName -> Fun + Scope.AxiomName -> Axiom + Scope.PrimName -> Prim + Scope.OtherDefName -> Unknown + +instance SymbolKindLike TCM.Defn where + toSymbolKind = \case + TCM.AxiomDefn _axiomData -> Axiom + TCM.DataOrRecSigDefn _dataOrRecSigData -> Unknown + TCM.GeneralizableVar -> GeneralizeVar + TCM.AbstractDefn defn -> toSymbolKind defn + TCM.FunctionDefn _functionData -> Fun + TCM.DatatypeDefn _datatypeData -> Data + TCM.RecordDefn _recordData -> Record + TCM.ConstructorDefn _constructorData -> Con + TCM.PrimitiveDefn _primitiveData -> Prim + TCM.PrimitiveSortDefn _primitiveSortData -> Prim + +instance (TypeLike t) => TypeLike (C.Arg t) where + toTypeString = toTypeString . C.unArg + +instance TypeLike A.Type where + toTypeString = fmap (Just . render) . TCM.liftTCM . prettyTCM + +instance TypeLike I.Type where + toTypeString = fmap (Just . render) . TCM.liftTCM . prettyTCM + +instance (HasParamNames p) => HasParamNames (C.Arg p) where + getParamNames = getParamNames . C.unArg + +instance (HasParamNames p) => HasParamNames [p] + +instance (HasParamNames p) => HasParamNames (List1 p) + +instance HasParamNames A.Type where + getParamNames = \case + A.Pi _exprInfo tel codom -> + getParamNames tel <> getParamNames codom + A.Fun _exprInfo _dom codom -> getParamNames codom + A.Generalized varNames codom -> + Set.toList varNames <> getParamNames codom + A.ScopedExpr _scopeInfo expr -> getParamNames expr + _noMoreParams -> [] + +instance HasParamNames A.TypedBinding where + getParamNames = \case + A.TBind _range _typedBindingInfo binders' _type -> + List1.toList binders' + <&> C.namedThing . C.unArg + <&> (A.qualify_ . A.unBind . A.binderName) + A.TLet _range _letBindings -> [] + +instance HasParamNames A.GeneralizeTelescope where + getParamNames (A.GeneralizeTel _vars tel) = getParamNames tel diff --git a/src/Indexer/Monad.hs b/src/Indexer/Monad.hs new file mode 100644 index 0000000..61d4fcf --- /dev/null +++ b/src/Indexer/Monad.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Indexer.Monad + ( IndexerM, + execIndexerM, + tellParamNames, + tellDef, + tellDecl, + tellUsage, + tellImport, + tellNamedArgUsage, + withParent, + NameLike (..), + AmbiguousNameLike (..), + SymbolKindLike (..), + TypeLike (..), + HasParamNames (..), + UnknownType (UnknownType), + NoType (NoType), + ) +where + +import Agda.Position (toLspRange) +import qualified Agda.Syntax.Abstract as A +import qualified Agda.Syntax.Common as C +import Agda.Syntax.Position (HasRange, getRange) +import Agda.Utils.IORef (IORef, modifyIORef', newIORef, readIORef) +import Agda.Utils.Lens (over) +import Agda.Utils.List1 (List1, concatMap1) +import Agda.Utils.Maybe (isNothing) +import Control.Applicative ((<|>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks) +import Control.Monad.Trans (lift) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Language.LSP.Server as LSP +import Monad (ServerM) +import Options (Config) +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs, agdaFileSymbols, emptyAgdaFile, insertRef, insertSymbolInfo) +import Server.Model.Monad (WithAgdaLibM) +import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..)) + +data NamedArgUsage = NamedArgUsage + { nauHead :: !A.AmbiguousQName, + nauArg :: !C.NamedName + } + +data Env = Env + { envAgdaFile :: !(IORef AgdaFile), + envParent :: !(Maybe A.QName), + -- | Parameter names in implicit arguments, such as x in `f {x = y} = y` and + -- `g y = f {x = y}`, are represented by strings in abstract syntax. This is + -- because we need type checking information to resolve these names, not + -- just scope checking information. + -- + -- Agda doesn't seem to expose its internal type checker resolution of these + -- names. We hack around it by storing the implicit parameter names for each + -- function ourselves, then looking up the strings at the end and emitting + -- them as references. Ideally, this solution is eventually replaced by + -- changing the type checker so it emits this information for us. + -- + -- These are the stored parameter names, indexed by the name of the function + -- (or other defined symbol). + envParamNames :: !(IORef (Map A.QName [A.QName])), + envNamedArgUsages :: !(IORef [NamedArgUsage]) + } + +initEnv :: (MonadIO m) => m Env +initEnv = do + agdaFile <- liftIO $ newIORef emptyAgdaFile + let parent = Nothing + paramNames <- liftIO $ newIORef Map.empty + namedArgUsages <- liftIO $ newIORef [] + return $ Env agdaFile parent paramNames namedArgUsages + +type IndexerM = ReaderT Env WithAgdaLibM + +execIndexerM :: IndexerM a -> WithAgdaLibM AgdaFile +execIndexerM x = do + env <- initEnv + _ <- runReaderT x env + -- TODO: resolve named arg usages + liftIO $ readIORef $ envAgdaFile env + +-------------------------------------------------------------------------------- + +-- Used when inserting a new `SymbolInfo` into a map already containing a +-- `SymbolInfo` for the given symbol +updateSymbolInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo +updateSymbolInfo new old = + SymbolInfo + (symbolKind old <> symbolKind new) + (symbolType old <|> symbolType new) + (symbolParent old <|> symbolParent new) + +tellSymbolInfo' :: A.QName -> SymbolInfo -> IndexerM () +tellSymbolInfo' name symbolInfo = do + agdaFileRef <- asks envAgdaFile + liftIO $ modifyIORef' agdaFileRef $ insertSymbolInfo updateSymbolInfo name symbolInfo + +tellSymbolInfo :: + (NameLike n, SymbolKindLike s, TypeLike t) => + n -> s -> t -> IndexerM () +tellSymbolInfo nameLike symbolKindLike typeLike = do + let name = toQName nameLike + symbolKind = toSymbolKind symbolKindLike + type' <- lift $ toTypeString typeLike + parent <- asks envParent + let symbolInfo = SymbolInfo symbolKind type' parent + tellSymbolInfo' name symbolInfo + +tellRef' :: A.AmbiguousQName -> Ref -> IndexerM () +tellRef' ambiguousName ref = do + agdaFileRef <- asks envAgdaFile + liftIO $ modifyIORef' agdaFileRef $ insertRef ambiguousName ref + +tellRef :: + (AmbiguousNameLike n) => + n -> RefKind -> IndexerM () +tellRef nameLike refKind = do + let name = toAmbiguousQName nameLike + range = toLspRange $ getRange name + ref = Ref refKind range (A.isAmbiguous name) + tellRef' name ref + +tellParamNames :: (NameLike n, HasParamNames p) => n -> p -> IndexerM () +tellParamNames nameLike hasParamNames = do + let name = toQName nameLike + let paramNames = getParamNames hasParamNames + paramNamesRef <- asks envParamNames + liftIO $ modifyIORef' paramNamesRef $ Map.insert name paramNames + +tellDef :: + (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => + n -> s -> t -> IndexerM () +tellDef n s t = do + tellSymbolInfo n s t + tellRef n Def + tellParamNames n t + +tellDecl :: + (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => + n -> s -> t -> IndexerM () +tellDecl n s t = do + tellSymbolInfo n s t + tellRef n Decl + tellParamNames n t + +tellUsage :: (AmbiguousNameLike n) => n -> IndexerM () +tellUsage n = tellRef n Usage + +tellImport :: (AmbiguousNameLike n) => n -> IndexerM () +tellImport n = tellRef n Import + +tellNamedArgUsage :: (AmbiguousNameLike n) => n -> C.NamedName -> IndexerM () +tellNamedArgUsage headNameLike argName = do + let headName = toAmbiguousQName headNameLike + namedArgUsage = NamedArgUsage headName argName + namedArgUsagesRef <- asks envNamedArgUsages + liftIO $ modifyIORef' namedArgUsagesRef $ (namedArgUsage :) + +withParent :: (NameLike n) => n -> IndexerM a -> IndexerM a +withParent nameLike = local $ \e -> e {envParent = Just $ toQName nameLike} + +-------------------------------------------------------------------------------- + +class (AmbiguousNameLike n) => NameLike n where + toQName :: n -> A.QName + +class AmbiguousNameLike n where + toAmbiguousQName :: n -> A.AmbiguousQName + +instance (AmbiguousNameLike n) => AmbiguousNameLike (List1 n) where + toAmbiguousQName = A.AmbQ . concatMap1 (A.unAmbQ . toAmbiguousQName) + +class SymbolKindLike a where + toSymbolKind :: a -> SymbolKind + +class HasParamNames p where + getParamNames :: p -> [A.QName] + default getParamNames :: (Foldable f, HasParamNames b, p ~ f b) => p -> [A.QName] + getParamNames = foldMap getParamNames + +instance (HasParamNames p) => HasParamNames (Maybe p) where + getParamNames = maybe [] getParamNames + +class TypeLike t where + -- | Try to render a type to a @String@. Strings were chosen because: + -- - they are easily obtained from abstract and internal terms + -- - they do not depend on the scope, context, or other TC state + -- - they have a low memory footprint compared to unrendered @Doc@s + -- + -- However, strings do lose semantic information otherwise available to us, + -- so this representation may be switched in the future if that information is + -- needed. + toTypeString :: t -> WithAgdaLibM (Maybe String) + +instance (TypeLike t) => TypeLike (Maybe t) where + toTypeString = maybe (return Nothing) toTypeString + +data UnknownType = UnknownType + +instance HasParamNames UnknownType where + getParamNames UnknownType = [] + +instance TypeLike UnknownType where + toTypeString UnknownType = return Nothing + +data NoType = NoType + +instance HasParamNames NoType where + getParamNames NoType = [] + +instance TypeLike NoType where + toTypeString NoType = return Nothing diff --git a/src/Language/LSP/Protocol/Types/More.hs b/src/Language/LSP/Protocol/Types/More.hs new file mode 100644 index 0000000..c64f51f --- /dev/null +++ b/src/Language/LSP/Protocol/Types/More.hs @@ -0,0 +1,24 @@ +module Language.LSP.Protocol.Types.More () where + +import Agda.Syntax.Common.Pretty +import Agda.Utils.Lens ((^.)) +import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Types as LSP + +instance Pretty LSP.Uri where + pretty = text . Text.unpack . LSP.getUri + +instance Pretty LSP.Position where + pretty pos = pshow (pos ^. LSP.line + 1) <> text ":" <> pshow (pos ^. LSP.character + 1) + +instance Pretty LSP.Range where + pretty range = + if range ^. LSP.start . LSP.line == range ^. LSP.end . LSP.line + then + pshow (range ^. LSP.start . LSP.line + 1) + <> text ":" + <> pshow (range ^. LSP.start . LSP.character + 1) + <> text "-" + <> pshow (range ^. LSP.end . LSP.character + 1) + else pretty (range ^. LSP.start) <> text "-" <> pretty (range ^. LSP.end) diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs deleted file mode 100644 index 71940b3..0000000 --- a/src/Server/Handler/TextDocument/DocumentSymbol.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) where - -import Agda.Utils.Lens ((^.)) -import qualified Language.LSP.Protocol.Lens as LSP -import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Server (LspM) -import qualified Language.LSP.Server as LSP -import Monad (ServerM) -import Options (Config) -import Server.Handler.Monad (useAgdaFile, withAgdaFile) -import qualified Server.Model as Model -import Server.Model.AgdaFile (agdaFileSymbols) - -documentSymbolHandler :: LSP.Handlers (ServerM (LspM Config)) -documentSymbolHandler = withAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do - symbols <- useAgdaFile agdaFileSymbols - return () diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index afabdc6..3298f97 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -2,13 +2,19 @@ module Server.Model.AgdaFile ( AgdaFile, emptyAgdaFile, agdaFileSymbols, + agdaFileRefs, + insertSymbolInfo, + insertRef, ) where import qualified Agda.Syntax.Abstract as A -import Agda.Utils.Lens (Lens', (<&>)) +import Agda.Utils.Lens (Lens', over, (<&>)) +import Control.Monad (forM) +import Data.Foldable (fold) import Data.Map (Map) import qualified Data.Map as Map +import Data.Monoid (Endo (Endo, appEndo)) import Server.Model.Symbol (Ref, SymbolInfo) data AgdaFile = AgdaFile @@ -21,3 +27,22 @@ emptyAgdaFile = AgdaFile Map.empty Map.empty agdaFileSymbols :: Lens' AgdaFile (Map A.QName SymbolInfo) agdaFileSymbols f a = f (_agdaFileSymbols a) <&> \x -> a {_agdaFileSymbols = x} + +agdaFileRefs :: Lens' AgdaFile (Map A.QName [Ref]) +agdaFileRefs f a = f (_agdaFileRefs a) <&> \x -> a {_agdaFileRefs = x} + +insertSymbolInfo :: + (SymbolInfo -> SymbolInfo -> SymbolInfo) -> + A.QName -> + SymbolInfo -> + AgdaFile -> + AgdaFile +insertSymbolInfo update name symbolInfo = over agdaFileSymbols $ Map.insertWith update name symbolInfo + +insertRef :: A.AmbiguousQName -> Ref -> AgdaFile -> AgdaFile +insertRef ambiguousName ref = + over agdaFileRefs $ + appEndo $ + foldMap (\name -> Endo $ Map.insertWith (<>) name [ref]) (A.unAmbQ ambiguousName) + +-- Map.insertWith (<>) name [ref] diff --git a/src/Server/Handler/Monad.hs b/src/Server/Model/Monad.hs similarity index 81% rename from src/Server/Handler/Monad.hs rename to src/Server/Model/Monad.hs index 863060b..a4068c3 100644 --- a/src/Server/Handler/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -1,16 +1,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} -module Server.Handler.Monad +module Server.Model.Monad ( MonadAgdaLib (..), useAgdaLib, MonadAgdaFile (..), useAgdaFile, withAgdaFile, + WithAgdaLibM, + withAgdaLibFor, ) where @@ -20,7 +24,7 @@ import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) import Agda.Utils.Lens (Lens', locally, over, use, view, (<&>), (^.)) import Agda.Utils.Monad (bracket_) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks) +import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask, asks) import Control.Monad.Trans (MonadTrans, lift) import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP @@ -100,6 +104,47 @@ defaultLiftTCM (TCM f) = do -------------------------------------------------------------------------------- +newtype WithAgdaLibT m a = WithAgdaLibT {unWithAgdaLibT :: ReaderT AgdaLib m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) + +runWithAgdaLibT :: AgdaLib -> WithAgdaLibT m a -> m a +runWithAgdaLibT agdaLib = flip runReaderT agdaLib . unWithAgdaLibT + +type WithAgdaLibM = WithAgdaLibT (ServerM (LspM Config)) + +withAgdaLibFor :: LSP.Uri -> WithAgdaLibM a -> ServerM (LspM Config) a +withAgdaLibFor uri x = do + let normUri = LSP.toNormalizedUri uri + model <- askModel + agdaLib <- Model.getAgdaLib normUri model + runWithAgdaLibT agdaLib x + +instance (MonadIO m) => MonadAgdaLib (WithAgdaLibT m) where + askAgdaLib = WithAgdaLibT ask + localAgdaLib f = WithAgdaLibT . local f . unWithAgdaLibT + +instance (MonadIO m) => MonadTCEnv (WithAgdaLibT m) where + askTC = defaultAskTC + localTC = defaultLocalTC + +instance (MonadIO m) => MonadTCState (WithAgdaLibT m) where + getTC = defaultGetTC + putTC = defaultPutTC + modifyTC = defaultModifyTC + +instance (MonadIO m) => ReadTCState (WithAgdaLibT m) where + getTCState = defaultGetTC + locallyTCState = defaultLocallyTCState + +instance (MonadIO m) => HasOptions (WithAgdaLibT m) where + pragmaOptions = defaultPragmaOptionsImpl + commandLineOptions = defaultCommandLineOptionsImpl + +instance (MonadIO m) => MonadTCM (WithAgdaLibT m) where + liftTCM = defaultLiftTCM + +-------------------------------------------------------------------------------- + data WithAgdaFileEnv = WithAgdaFileEnv { _withAgdaFileEnvAgdaLib :: !AgdaLib, _withAgdaFileEnvAgdaFile :: !AgdaFile diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index 5506f15..e50727f 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -1,8 +1,16 @@ -module Server.Model.Symbol (SymbolInfo, Ref) where +module Server.Model.Symbol + ( SymbolKind (..), + SymbolInfo (..), + RefKind (..), + Ref (..), + ) +where import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parens, pretty, pshow, text, (<+>)) import Agda.Syntax.Position (Position, PositionWithoutFile) import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types.More () data SymbolKind = Con @@ -20,15 +28,55 @@ data SymbolKind | Param | Local | Unknown - deriving (Show) + deriving (Show, Eq) + +instance Semigroup SymbolKind where + Unknown <> k = k + k <> _k = k data SymbolInfo = SymbolInfo - { _symbolKind :: !SymbolKind, - _symbolType :: !(Maybe String), - _symbolParent :: !(Maybe A.QName) + { symbolKind :: !SymbolKind, + symbolType :: !(Maybe String), + symbolParent :: !(Maybe A.QName) } +data RefKind + = -- | The symbol is being declared. There should be at most one declaration + -- for any given symbol (in correct Agda code). Roughly speaking, this is + -- the "single most important defining reference" + -- + -- For example, a function's name in its signature + Decl + | -- | The symbol is being defined, but is not being declared in the sense + -- that @Decl@ would apply. Typically, this means the definition may be + -- split into several parts, and this is one of the "less important" parts + -- + -- For example, a function's name in the LHS of a clause in its definition + Def + | -- | The symbol is (expected to be) already defined and is being used + -- + -- For example, a function's name in function application + Usage + | -- | The symbol is being imported here + Import + deriving (Show, Eq) + +instance Pretty RefKind where + pretty = pshow + data Ref = Ref - { _refSymbol :: !A.QName, - _refRange :: !LSP.Range + { refKind :: !RefKind, + refRange :: !LSP.Range, + refIsAmbiguous :: !Bool } + +prettyAmbiguity :: Ref -> Doc +prettyAmbiguity ref = + if refIsAmbiguous ref + then text "ambiguous" + else text "unambiguous" + +instance Pretty Ref where + pretty ref = + ((prettyAmbiguity ref <+> pretty (refKind ref)) <> comma) + <+> pretty (refRange ref) diff --git a/test/Test.hs b/test/Test.hs index 67d8960..34aa3eb 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,7 +10,8 @@ import qualified Test.WASM as WASM import Test.Tasty import Test.Tasty.Options import qualified Test.Model as Model -import qualified Test.HandlerMonad as HandlerMonad +import qualified Test.ModelMonad as ModelMonad +import qualified Test.Indexer.Invariants as IndexerInvariants -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -26,17 +27,20 @@ main :: IO () main = do let opts = [Option (Proxy :: Proxy AlsPathOption)] ingredients = includingOptions opts : defaultIngredients - defaultMainWithIngredients ingredients tests + defaultMainWithIngredients ingredients =<< tests -tests :: TestTree -tests = askOption $ \(AlsPathOption alsPath) -> - testGroup - "Tests" - [ SrcLoc.tests, - LSP.tests alsPath, - Model.tests, - HandlerMonad.tests +tests :: IO TestTree +tests = do + indexerInvariantsTest <- IndexerInvariants.tests + return $ askOption $ \(AlsPathOption alsPath) -> + testGroup + "Tests" + [ SrcLoc.tests, + LSP.tests alsPath, + Model.tests, + ModelMonad.tests, + indexerInvariantsTest #if defined(wasm32_HOST_ARCH) - , WASM.tests alsPath + , WASM.tests alsPath #endif - ] \ No newline at end of file + ] \ No newline at end of file diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs new file mode 100644 index 0000000..dca595e --- /dev/null +++ b/test/Test/Indexer/Invariants.hs @@ -0,0 +1,54 @@ +module Test.Indexer.Invariants (tests) where + +import Agda.Interaction.FindFile (SourceFile (SourceFile)) +import qualified Agda.Interaction.Imports as Imp +import Agda.Interaction.Options (defaultOptions) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.FileName (absolute) +import Agda.Utils.Lens ((^.)) +import Control.Monad (forM) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (traverse_) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Indexer (indexFile) +import Indexer.Indexer (abstractToIndex) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import Monad (runServerM) +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) +import Server.Model.Monad (withAgdaLibFor) +import System.FilePath (takeBaseName) +import Test.Indexer.NoOverlap (testNoOverlap) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden (findByExtension) +import Test.Tasty.HUnit (testCase) +import qualified TestData + +tests :: IO TestTree +tests = do + inPaths <- findByExtension [".agda"] "test/data/Indexer" + namedFiles <- forM inPaths $ \inPath -> do + let testName = takeBaseName inPath + uri = LSP.filePathToUri inPath + model <- TestData.getModel + + file <- LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerM env $ do + withAgdaLibFor uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + indexFile src + + return (testName, file) + + return $ + testGroup + "Invariants" + [ testGroup "No reference overlap" (uncurry testNoOverlap <$> namedFiles) + ] diff --git a/test/Test/Indexer/NoOverlap.hs b/test/Test/Indexer/NoOverlap.hs new file mode 100644 index 0000000..9470604 --- /dev/null +++ b/test/Test/Indexer/NoOverlap.hs @@ -0,0 +1,152 @@ +module Test.Indexer.NoOverlap (testNoOverlap) where + +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common.Pretty (Doc, Pretty (prettyList), align, parens, pretty, prettyShow, text, vcat, (<+>)) +import Agda.Utils.Lens ((^.)) +import Control.Monad (forM, forM_) +import Control.Monad.Writer.CPS (Writer, execWriter, tell) +import Data.Foldable (foldrM) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) +import Server.Model.Symbol (Ref (refRange), refIsAmbiguous) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase) + +data OverlapError = OverlapError + { oeLineNum :: !Int, + oePart1 :: !LinePart, + oePart2 :: !LinePart + } + +instance Pretty OverlapError where + pretty err = + vcat + [ text "Overlap error at line number" + <+> pretty (oeLineNum err + 1) + <+> linePartPrettyRange (oePart1 err) + <+> text "and" + <+> linePartPrettyRange (oePart2 err), + pretty (linePartName (oePart1 err)) + <+> pretty (linePartRef (oePart1 err)), + pretty (linePartName (oePart2 err)) + <+> pretty (linePartRef (oePart2 err)) + ] + + prettyList = \case + [] -> text "No overlap errors" + [err] -> pretty err + errs -> align 5 $ (\err -> ("-", vcat [pretty err, text ""])) <$> errs + +type OverlapResult = Writer [OverlapError] + +data LinePart + = RangePart !A.QName !Ref !Int !Int + | ToEndPart !A.QName !Ref !Int + +linePartPrettyRange :: LinePart -> Doc +linePartPrettyRange (RangePart _ _ start end) = text "from" <+> pretty start <+> text "to" <+> pretty end +linePartPrettyRange (ToEndPart _ _ start) = text "from" <+> pretty start <+> text "to the end of the line" + +linePartName :: LinePart -> A.QName +linePartName (RangePart name _ _ _) = name +linePartName (ToEndPart name _ _) = name + +linePartRef :: LinePart -> Ref +linePartRef (RangePart _ ref _ _) = ref +linePartRef (ToEndPart _ ref _) = ref + +assertPartsNonoverlapping :: Int -> LinePart -> LinePart -> OverlapResult () +assertPartsNonoverlapping lineNum part1 part2 = case (part1, part2) of + -- Allow refs known to be ambiguous + (_, _) + | refIsAmbiguous (linePartRef part1) + && refIsAmbiguous (linePartRef part2) -> + return () + (ToEndPart _ _ _, ToEndPart _ _ _) -> err + (RangePart _ _ _ rangeEnd, ToEndPart _ _ toEndStart) + | rangeEnd > toEndStart -> err + (ToEndPart _ _ toEndStart, RangePart _ _ _ rangeEnd) + | rangeEnd > toEndStart -> err + (RangePart _ _ start1 end1, RangePart _ _ start2 end2) + | (start1 <= start2 && end1 > start2) + || (start2 <= start1 && end2 > start1) -> + err + _ -> return () + where + err = tell $ [OverlapError lineNum part1 part2] + +newtype Line = Line [LinePart] + +rangePart :: (Integral n) => A.QName -> Ref -> n -> n -> Line +rangePart name ref start end = Line [RangePart name ref (fromIntegral start) (fromIntegral end)] + +toEndPart :: (Integral n) => A.QName -> Ref -> n -> Line +toEndPart name ref start = Line [ToEndPart name ref (fromIntegral start)] + +tryInsertPart :: Int -> LinePart -> Line -> OverlapResult (Line) +tryInsertPart lineNum part (Line parts) = do + forM_ parts $ \part2 -> + assertPartsNonoverlapping lineNum part part2 + return $ Line $ part : parts + +tryMerge :: Int -> Line -> Line -> OverlapResult (Line) +tryMerge lineNum (Line newParts) line = foldrM (tryInsertPart lineNum) line newParts + +rangeToLines :: A.QName -> Ref -> LSP.Range -> [(Int, Line)] +rangeToLines name ref range = + if startLine == endLine + then + [ ( startLine, + rangePart + name + ref + (range ^. LSP.start . LSP.character) + (range ^. LSP.end . LSP.character) + ) + ] + else + let start = (startLine, toEndPart name ref $ range ^. LSP.start . LSP.character) + end = (endLine, rangePart name ref 0 $ range ^. LSP.end . LSP.character) + middle = do + lineNum <- [startLine + 1 .. endLine - 1] + return (lineNum, toEndPart name ref 0) + in [start] <> middle <> [end] + where + startLine = fromIntegral $ range ^. LSP.start . LSP.line + endLine = fromIntegral $ range ^. LSP.end . LSP.line + +newtype FileRanges = FileRanges (IntMap (Line)) + +emptyFileRanges :: FileRanges +emptyFileRanges = FileRanges IntMap.empty + +tryInsertLine :: Int -> Line -> FileRanges -> OverlapResult (FileRanges) +tryInsertLine lineNum line (FileRanges ranges) = + FileRanges <$> IntMap.alterF helper lineNum ranges + where + helper Nothing = return $ Just line + helper (Just oldLine) = Just <$> tryMerge lineNum line oldLine + +tryInsertRange :: A.QName -> Ref -> LSP.Range -> FileRanges -> OverlapResult (FileRanges) +tryInsertRange name ref range fileRanges = do + let lines = rangeToLines name ref range + foldrM (uncurry tryInsertLine) fileRanges lines + +testNoOverlap :: String -> AgdaFile -> TestTree +testNoOverlap name file = testCase name $ do + let refs = + concatMap (\(name, refs) -> (\ref -> (name, ref)) <$> refs) $ + Map.toList $ + file ^. agdaFileRefs + let fileRanges = emptyFileRanges + let errors = + execWriter $ + foldrM (\(name, ref) -> tryInsertRange name ref (refRange ref)) fileRanges refs + + case errors of + [] -> return () + _ -> assertFailure $ prettyShow errors diff --git a/test/Test/HandlerMonad.hs b/test/Test/ModelMonad.hs similarity index 87% rename from test/Test/HandlerMonad.hs rename to test/Test/ModelMonad.hs index 768bb43..e96eb19 100644 --- a/test/Test/HandlerMonad.hs +++ b/test/Test/ModelMonad.hs @@ -3,8 +3,9 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} -module Test.HandlerMonad (tests) where +module Test.ModelMonad (tests) where +import qualified Agda.Compiler.Backend as TestData import Agda.Utils.Either (isLeft, isRight) import Agda.Utils.IORef (newIORef, readIORef, writeIORef) import Agda.Utils.Lens ((^.)) @@ -18,9 +19,9 @@ import qualified Language.LSP.Server as LSP import Monad (Env (Env, envModel), ServerM, createInitEnv, runServerM) import Options (Config, defaultOptions, initConfig) import qualified Server.CommandController as CommandController -import Server.Handler.Monad (MonadAgdaLib (askAgdaLib), withAgdaFile) import Server.Model (Model) import Server.Model.AgdaLib (agdaLibIncludes) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib), withAgdaFile) import qualified Server.ResponseController as ResponseController import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) @@ -29,7 +30,7 @@ import qualified TestData tests :: TestTree tests = testGroup - "Handler monads" + "Model monads" [ testGroup "WithAgdaFileM" [ testCase "gets known Agda file" $ do @@ -78,15 +79,8 @@ runHandler m request model handlers = do let Just (LSP.ClientMessageHandler handler) = SMethodMap.lookup m $ LSP.reqHandlers handlers LSP.runLspT undefined $ do - env <- - Env defaultOptions True initConfig - <$> liftIO newChan - <*> liftIO CommandController.new - <*> liftIO newChan - <*> liftIO ResponseController.new - <*> liftIO (newIORef model) - runServerM env $ do - handler request callback + env <- TestData.getServerEnv model + runServerM env $ handler request callback Just result <- readIORef resultRef return result diff --git a/test/TestData.hs b/test/TestData.hs index d2528ee..d9d9e00 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -7,16 +7,24 @@ module TestData fileUri2, fileUri3, fakeUri, + getServerEnv, ) where +import Agda.Utils.IORef (newIORef) import Agda.Utils.Lens (set, (<&>)) +import Control.Concurrent (newChan) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map as Map import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP +import Monad (Env (Env)) +import Options (defaultOptions, initConfig) +import qualified Server.CommandController as CommandController import Server.Model (Model (Model)) import Server.Model.AgdaFile (emptyAgdaFile) import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import qualified Server.ResponseController as ResponseController documentSymbolMessage :: LSP.NormalizedUri -> LSP.TRequestMessage LSP.Method_TextDocumentDocumentSymbol documentSymbolMessage uri = @@ -78,3 +86,14 @@ getModel = do ] return $ Model libs files + +-------------------------------------------------------------------------------- + +getServerEnv :: (MonadIO m) => Model -> m Env +getServerEnv model = + Env defaultOptions True initConfig + <$> liftIO newChan + <*> liftIO CommandController.new + <*> liftIO newChan + <*> liftIO ResponseController.new + <*> liftIO (newIORef model) diff --git a/test/data/Indexer/Basic.agda b/test/data/Indexer/Basic.agda new file mode 100644 index 0000000..3ddbb80 --- /dev/null +++ b/test/data/Indexer/Basic.agda @@ -0,0 +1,54 @@ +module Basic where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat + +one : Nat +one = suc zero + +two : Nat +two = suc one + +data Test : Set where + test : Test + +data Test' : Set where + test : Test' + +hello : Test +hello = test + +data Empty : Set where + +Not : Set -> Set +Not A = A -> Empty + +Goodbye : Set +Goodbye = Not Test + +postulate A : Test -> Set + +testId : Test -> Test +testId test = test + +id : {A : Set} -> A -> A +id = \where x -> x + +id' : {A : Set} -> A -> A +id' = \x -> let x = x in x + +id'' : {A : Set} -> A -> A +id'' {A = A} x = + let x = x + A = A + in x + +record World : Set where + field + north : Test + south : Test' + +earth : World +earth .World.north = test +earth .World.south = test From 78f67857bbadc5f718569be6df79aff258dcb326 Mon Sep 17 00:00:00 2001 From: nvarner Date: Tue, 12 Aug 2025 19:06:54 -0700 Subject: [PATCH 05/47] check that we don't miss Refs --- agda-language-server.cabal | 1 + src/Indexer.hs | 9 ++-- src/Server/Model/AgdaFile.hs | 12 +++-- src/Server/Model/Symbol.hs | 10 +++- test/Test/Indexer/Invariants.hs | 25 +++++++--- test/Test/Indexer/NoMissing.hs | 82 +++++++++++++++++++++++++++++++++ test/Test/Indexer/NoOverlap.hs | 2 + test/data/Indexer/Basic.agda | 21 +++++++++ test/data/Indexer/Small.agda | 1 + 9 files changed, 148 insertions(+), 15 deletions(-) create mode 100644 test/Test/Indexer/NoMissing.hs create mode 100644 test/data/Indexer/Small.agda diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 7592b1b..e04e290 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -180,6 +180,7 @@ test-suite als-test main-is: Test.hs other-modules: Test.Indexer.Invariants + Test.Indexer.NoMissing Test.Indexer.NoOverlap Test.LSP Test.Model diff --git a/src/Indexer.hs b/src/Indexer.hs index 315c4c9..9b65b45 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -1,7 +1,6 @@ module Indexer (indexFile) where -import Agda.Interaction.FindFile (SourceFile (SourceFile)) -import qualified Agda.Interaction.FindFile as Imp +import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) import qualified Agda.Interaction.Imports as Imp import qualified Agda.Interaction.Imports.More as Imp import Agda.Interaction.Library (getPrimitiveLibDir) @@ -34,12 +33,12 @@ indexFile src = do -- Now reset the options TCM.setCommandLineOptions . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC - TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (Imp.srcFilePath $ Imp.srcOrigin src) + TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (Imp.srcFilePath $ Imp.srcOrigin src)}) $ do + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) $ do let topLevel = TopLevel - (Imp.srcFilePath $ Imp.srcOrigin src) + (srcFilePath $ Imp.srcOrigin src) (Imp.srcModuleName src) (C.modDecls $ Imp.srcModule src) ast <- TCM.liftTCM $ toAbstract topLevel diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index 3298f97..b6c0941 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -9,7 +9,8 @@ module Server.Model.AgdaFile where import qualified Agda.Syntax.Abstract as A -import Agda.Utils.Lens (Lens', over, (<&>)) +import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyAssign, prettyMap, text, vcat) +import Agda.Utils.Lens (Lens', over, (<&>), (^.)) import Control.Monad (forM) import Data.Foldable (fold) import Data.Map (Map) @@ -22,6 +23,13 @@ data AgdaFile = AgdaFile _agdaFileRefs :: !(Map A.QName [Ref]) } +instance Pretty AgdaFile where + pretty agdaFile = + vcat + [ prettyAssign (text "symbols", prettyMap $ Map.toList $ agdaFile ^. agdaFileSymbols), + prettyAssign (text "refs", prettyMap $ Map.toList $ agdaFile ^. agdaFileRefs) + ] + emptyAgdaFile :: AgdaFile emptyAgdaFile = AgdaFile Map.empty Map.empty @@ -44,5 +52,3 @@ insertRef ambiguousName ref = over agdaFileRefs $ appEndo $ foldMap (\name -> Endo $ Map.insertWith (<>) name [ref]) (A.unAmbQ ambiguousName) - --- Map.insertWith (<>) name [ref] diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index e50727f..1ea8f02 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -7,7 +7,7 @@ module Server.Model.Symbol where import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parens, pretty, pshow, text, (<+>)) +import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parens, parensNonEmpty, pretty, pshow, text, (<+>)) import Agda.Syntax.Position (Position, PositionWithoutFile) import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.More () @@ -30,6 +30,9 @@ data SymbolKind | Unknown deriving (Show, Eq) +instance Pretty SymbolKind where + pretty = pshow + instance Semigroup SymbolKind where Unknown <> k = k k <> _k = k @@ -40,6 +43,11 @@ data SymbolInfo = SymbolInfo symbolParent :: !(Maybe A.QName) } +instance Pretty SymbolInfo where + pretty symbolInfo = + pretty (symbolKind symbolInfo) + <+> parensNonEmpty (pretty $ symbolType symbolInfo) + data RefKind = -- | The symbol is being declared. There should be at most one declaration -- for any given symbol (in correct Agda code). Roughly speaking, this is diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index dca595e..bdc067c 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -1,6 +1,6 @@ module Test.Indexer.Invariants (tests) where -import Agda.Interaction.FindFile (SourceFile (SourceFile)) +import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Options (defaultOptions) import qualified Agda.TypeChecking.Monad as TCM @@ -20,6 +20,7 @@ import Monad (runServerM) import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) import Server.Model.Monad (withAgdaLibFor) import System.FilePath (takeBaseName) +import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension) @@ -29,26 +30,38 @@ import qualified TestData tests :: IO TestTree tests = do inPaths <- findByExtension [".agda"] "test/data/Indexer" - namedFiles <- forM inPaths $ \inPath -> do + files <- forM inPaths $ \inPath -> do let testName = takeBaseName inPath uri = LSP.filePathToUri inPath model <- TestData.getModel - file <- LSP.runLspT undefined $ do + (file, interface) <- LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerM env $ do + interface <- withAgdaLibFor uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) + checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src + return $ Imp.crInterface checkResult + withAgdaLibFor uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath let srcFile = SourceFile absInPath src <- TCM.liftTCM $ Imp.parseSource srcFile - indexFile src + agdaFile <- indexFile src + return (agdaFile, interface) - return (testName, file) + return (testName, file, interface) return $ testGroup "Invariants" - [ testGroup "No reference overlap" (uncurry testNoOverlap <$> namedFiles) + [ testGroup "No reference overlap" ((\(name, file, _interface) -> testNoOverlap name file) <$> files), + testGroup "No missing references" ((\(name, file, interface) -> testNoMissing name file interface) <$> files) ] diff --git a/test/Test/Indexer/NoMissing.hs b/test/Test/Indexer/NoMissing.hs new file mode 100644 index 0000000..69525ce --- /dev/null +++ b/test/Test/Indexer/NoMissing.hs @@ -0,0 +1,82 @@ +-- | Check that highlighting data doesn't show more references than we have +-- `Ref`s. We expect to sometimes pick up references that highlighting does not, +-- so it's okay if we have more. +module Test.Indexer.NoMissing (testNoMissing) where + +import Agda.Interaction.Highlighting.Precise (Aspects, HighlightingInfo) +import qualified Agda.Interaction.Highlighting.Precise as HL +import Agda.Position (FromOffset, fromOffset, makeFromOffset) +import Agda.Syntax.Common.Pretty (Pretty, align, pretty, prettyList, prettyShow, pshow, text, vcat, (<+>)) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.Lens ((^.)) +import Agda.Utils.Maybe (isJust, isNothing) +import Agda.Utils.RangeMap (PairInt (PairInt), RangeMap (rangeMap)) +import Control.Monad (forM_, guard) +import Control.Monad.Writer.CPS (Writer, execWriter, tell) +import qualified Data.Map as Map +import Data.Strict (Pair ((:!:))) +import qualified Data.Strict as Strict +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) +import Server.Model.Symbol (Ref (refRange)) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase) + +data MissingRefError = MissingRefError + { mreAspects :: !Aspects, + mreRange :: !LSP.Range + } + +instance Pretty MissingRefError where + pretty err = + text "Missing ref error at" + <+> pretty (mreRange err) + <+> text "with aspects" + <+> pshow (mreAspects err) + + prettyList = \case + [] -> text "No missing ref errors" + [err] -> pretty err + errs -> align 5 $ (\err -> ("-", vcat [pretty err, text ""])) <$> errs + +areAspectsRef :: Aspects -> Bool +areAspectsRef aspects = case HL.aspect aspects of + Just HL.PrimitiveType -> True + Just (HL.Name _ _) -> True + _ -> False + +highlightingRefRanges :: FromOffset -> HighlightingInfo -> [(Aspects, LSP.Range)] +highlightingRefRanges table highlightingInfo = do + (startOffset, PairInt (endOffset :!: aspects)) <- Map.toList $ rangeMap highlightingInfo + guard $ areAspectsRef aspects + let (startLine, startChar) = fromOffset table startOffset + startPos = LSP.Position (fromIntegral startLine) (fromIntegral startChar - 1) + (endLine, endChar) = fromOffset table (endOffset - 1) + endPos = LSP.Position (fromIntegral endLine) (fromIntegral endChar) + range = LSP.Range startPos endPos + return (aspects, range) + +hasCorrespondingRef :: AgdaFile -> Aspects -> LSP.Range -> Bool +hasCorrespondingRef agdaFile aspects range = + let refs = concat $ Map.elems $ agdaFile ^. agdaFileRefs + in isNothing (HL.definitionSite aspects) + || any (\ref -> refRange ref == range) refs + +checkCorrespondingRef :: AgdaFile -> Aspects -> LSP.Range -> Writer [MissingRefError] () +checkCorrespondingRef agdaFile aspects range = + if hasCorrespondingRef agdaFile aspects range + then return () + else tell $ [MissingRefError aspects range] + +testNoMissing :: String -> AgdaFile -> TCM.Interface -> TestTree +testNoMissing name agdaFile interface = testCase name $ do + let highlighting = TCM.iHighlighting interface + let table = makeFromOffset $ Strict.toStrict $ TCM.iSource interface + let highlightingRanges = highlightingRefRanges table highlighting + + let errors = execWriter $ forM_ highlightingRanges $ \(aspects, range) -> + checkCorrespondingRef agdaFile aspects range + + case errors of + [] -> return () + _ -> assertFailure $ prettyShow errors diff --git a/test/Test/Indexer/NoOverlap.hs b/test/Test/Indexer/NoOverlap.hs index 9470604..9f24df3 100644 --- a/test/Test/Indexer/NoOverlap.hs +++ b/test/Test/Indexer/NoOverlap.hs @@ -1,3 +1,5 @@ +-- | Check that `Ref`s don't overlap, so that there is only one `Ref` instance +-- per actual reference. module Test.Indexer.NoOverlap (testNoOverlap) where import qualified Agda.Syntax.Abstract as A diff --git a/test/data/Indexer/Basic.agda b/test/data/Indexer/Basic.agda index 3ddbb80..43a86ef 100644 --- a/test/data/Indexer/Basic.agda +++ b/test/data/Indexer/Basic.agda @@ -52,3 +52,24 @@ record World : Set where earth : World earth .World.north = test earth .World.south = test + +interleaved mutual + record MutualRecord (A : Set) : Set + data MutualData : Set + data MutualData' : Set + mutualFun : MutualRecord MutualData -> MutualRecord MutualData + + record MutualRecord A where + constructor makeMutualRecord + field + mutFieldX : A + field mutFieldY : Nat + + data MutualData where + mutCtorX : MutualData + + data _ where + mutCtorX' : MutualData' + mutCtorY : MutualData + + mutualFun = id diff --git a/test/data/Indexer/Small.agda b/test/data/Indexer/Small.agda new file mode 100644 index 0000000..56db13e --- /dev/null +++ b/test/data/Indexer/Small.agda @@ -0,0 +1 @@ +module Small where \ No newline at end of file From 6e77a52970d555ab806e248bb59ad3626f0ca37a Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 16:52:53 -0400 Subject: [PATCH 06/47] respect arg info origin in indexer --- agda-language-server.cabal | 8 +- src/Agda/Syntax/Abstract/More.hs | 181 +++++++++++++++++++++++ src/Indexer/Indexer.hs | 45 ++++-- test/data/AST/Basic | 237 ++++++++++++++++++++++++++++++ test/data/AST/FunWithoutDeclOrDef | 34 +++++ test/data/AST/Module | 42 ++++++ test/data/AST/Mutual | 133 +++++++++++++++++ test/data/AST/Record | 68 +++++++++ test/data/AST/Small | 6 + test/data/Indexer/Module.agda | 12 ++ 10 files changed, 747 insertions(+), 19 deletions(-) create mode 100644 src/Agda/Syntax/Abstract/More.hs create mode 100644 test/data/AST/Basic create mode 100644 test/data/AST/FunWithoutDeclOrDef create mode 100644 test/data/AST/Module create mode 100644 test/data/AST/Mutual create mode 100644 test/data/AST/Record create mode 100644 test/data/AST/Small create mode 100644 test/data/Indexer/Module.agda diff --git a/agda-language-server.cabal b/agda-language-server.cabal index e04e290..e8b0e64 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -53,6 +53,7 @@ library Agda.IR Agda.Parser Agda.Position + Agda.Syntax.Abstract.More Control.Concurrent.SizedChan Indexer Indexer.Indexer @@ -171,8 +172,7 @@ executable als if arch(wasm32) build-depends: unix >=2.8.0.0 && <2.9 - ghc-options: -with-rtsopts=-V1 - else + if !arch(wasm32) ghc-options: -threaded -with-rtsopts=-N test-suite als-test @@ -194,6 +194,7 @@ test-suite als-test Agda.IR Agda.Parser Agda.Position + Agda.Syntax.Abstract.More Control.Concurrent.SizedChan Indexer Indexer.Indexer @@ -270,6 +271,5 @@ test-suite als-test if arch(wasm32) build-depends: unix >=2.8.0.0 && <2.9 - ghc-options: -with-rtsopts=-V1 - else + if !arch(wasm32) ghc-options: -threaded -with-rtsopts=-N diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs new file mode 100644 index 0000000..7582e9b --- /dev/null +++ b/src/Agda/Syntax/Abstract/More.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Agda.Syntax.Abstract.More () where + +import Agda.Syntax.Abstract +import Agda.Syntax.Common +import Agda.Syntax.Common (ArgInfo (argInfoOrigin)) +import Agda.Syntax.Common.Pretty +import Agda.Syntax.Concrete (TacticAttribute' (theTacticAttribute)) +import Agda.Syntax.Info +import Agda.Utils.Functor ((<&>)) +import Data.Foldable (Foldable (toList)) +import qualified Data.Map as Map + +instance Pretty Declaration where + pretty decl = prettyAssign $ case decl of + Axiom kindOfName _defInfo _argInfo _polarities name type' -> + ( text "Axiom", + prettyMap + [ (text "kindOfName", pshow kindOfName), + (text "name", pretty name), + (text "type", pretty type') + ] + ) + Generalize _namesInType _defInfo _argInfo name type' -> + ( text "Generalize", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type') + ] + ) + Field _defInfo name type' -> + ( text "Field", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type') + ] + ) + Primitive _defInfo name type' -> + ( text "Primitive", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type') + ] + ) + Mutual _mutualInfo decls -> (text "Mutual", pretty decls) + Section _range _erased moduleName genTel decls -> + ( text "Section", + prettyMap + [ (text "moduleName", pretty moduleName), + (text "genTel", pretty genTel), + (text "decls", pretty decls) + ] + ) + Apply _moduleInfo _erased moduleName _moduleApp _scopeCopyInfo _importDirective -> + (text "Apply", pretty moduleName) + Import _moduleInfo moduleName _importDirective -> (text "Import", pretty moduleName) + Pragma _range _pragma -> (text "Pragma", mempty) + Open _moduleInfo moduleName _importDirective -> + (text "Open", pretty moduleName) + FunDef _defInfo name clauses -> + ( text "FunDef", + prettyMap + [ (text "name", pretty name), + (text "clauses", pretty clauses) + ] + ) + DataSig _defInfo _erased name _genTel type' -> + ( text "DataSig", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type') + ] + ) + DataDef _defIngo name _univCheck _dataDefParams _ctors -> + (text "DataDef", prettyMap [(text "name", pretty name)]) + RecSig _defInfo _erased name genTel type' -> + ( text "RecSig", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type') + ] + ) + RecDef _defInfo name _univCheck _recDirs _dataDefParams type' decls -> + ( text "RecDef", + prettyMap + [ (text "name", pretty name), + (text "type", pretty type'), + (text "decls", pretty decls) + ] + ) + PatternSynDef name _args _body -> (text "PatternSynDef", pretty name) + -- ... + ScopedDecl scopeInfo decls -> (text "ScopedDecl", pretty decls) + -- ... + _ -> ("Decl", mempty) + +instance Pretty Expr where + pretty expr = prettyAssign $ case expr of + Var name -> (text "Var", pretty name) + Def' name _suffix -> (text "Def'", pretty name) + Proj _origin name -> (text "Proj", pretty name) + Con name -> (text "Con", pretty name) + PatternSyn name -> (text "PatternSyn", pretty name) + Macro name -> (text "Macro", pretty name) + -- ... + App _appInfo f arg -> + ( text "App", + prettyMap + [ (text "f", pretty f), + (text "arg", pretty arg) + ] + ) + -- ... + Pi _exprInfo dom codom -> + ( text "Pi", + prettyMap + [ (text "dom", pretty dom), + (text "codom", pretty codom) + ] + ) + Generalized dom codom -> + ( text "Generalized", + prettyMap + [ (text "dom", pretty $ toList dom), + (text "codom", pretty codom) + ] + ) + Fun _exprInfo dom codom -> + ( text "Fun", + prettyMap + [ (text "dom", pretty dom), + (text "codom", pretty codom) + ] + ) + -- ... + ScopedExpr _scopeInfo expr -> (text "ScopedExpr", pretty expr) + -- ... + _ -> ("Expr", mempty) + +debugNamedBinder :: NamedArg Binder -> Doc +debugNamedBinder (Arg argInfo binder) = pshow (argInfoOrigin argInfo) <+> pretty binder + +instance Pretty TypedBinding where + pretty = \case + TBind _range _typedBindingInfo binders type' -> + parens (prettyList (debugNamedBinder <$> toList binders) <+> colon <+> pretty type') + TLet _range _letBindings -> text "TLet" + +instance Pretty LetBinding where + pretty = \case + LetBind _letInfo _argInfo name type' expr -> + text "let" <+> pretty (unBind name) <+> text "=" <+> pretty expr + LetPatBind _letInfo pat expr -> + text "letPat" <+> pretty pat <+> text "=" <+> pretty expr + _ -> text "LetBinding" + +instance Pretty Binder where + pretty binder = pretty $ unBind $ binderName binder + +instance (Pretty t) => Pretty (DefInfo' t) where + pretty defInfo = + align + 20 + [("DefInfo", prettyMap [(text "defTactic", defTactic defInfo)])] + +instance Pretty GeneralizeTelescope where + pretty genTel = + align + 20 + [ ( "GeneralizeTelescope", + prettyMap + [ (text "generalizeTelVars", prettyMap $ Map.toList $ generalizeTelVars genTel), + (text "generalizeTel", pretty $ show <$> generalizeTel genTel) + ] + ) + ] + +instance Pretty (Clause' lhs) where + pretty clause = text "clause" diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index a490936..3f87951 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -20,6 +20,7 @@ import Agda.Utils.Functor ((<&>)) import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe (whenJust) +import Agda.Utils.Monad (when) import Data.Foldable (forM_, traverse_) import qualified Data.Set as Set import Data.Void (absurd) @@ -59,10 +60,13 @@ class Indexable a where instance Indexable A.Declaration where index = \case A.Axiom kindOfName defInfo _argInfo _polarities name type' -> do + -- TODO: what does the `ArgInfo` mean? + -- Includes postulates, function declarations tellDecl name kindOfName type' index defInfo index type' A.Generalize _generalizeVars defInfo _argInfo name type' -> do + -- TODO: what does the `ArgInfo` mean? tellDecl name GeneralizeVar type' index defInfo index type' @@ -175,7 +179,9 @@ instance Indexable A.Expr where index exprF case funNameFromExpr exprF of Just name -> indexNamedArgs name [exprArg] - Nothing -> index $ C.namedThing $ C.unArg exprArg + Nothing -> + when (C.argInfoOrigin (C.argInfo exprArg) == C.UserWritten) $ do + index $ C.namedThing $ C.unArg exprArg A.WithApp _appInfo exprF exprArgs -> do index exprF index exprArgs @@ -266,7 +272,10 @@ instance (Indexable a) => Indexable [a] instance (Indexable a) => Indexable (List1 a) -instance (Indexable a) => Indexable (C.Arg a) +instance (Indexable a) => Indexable (C.Arg a) where + index (C.Arg argInfo x) = + when (C.argInfoOrigin argInfo == C.UserWritten) $ + index x instance Indexable A.TacticAttribute @@ -276,15 +285,17 @@ instance Indexable A.DefInfo where indexNamedArgs :: (AmbiguousNameLike n, Indexable a) => n -> [C.NamedArg a] -> IndexerM () indexNamedArgs headNameLike args = do let headName = toAmbiguousQName headNameLike - forM_ args $ \(C.Arg _argInfo (C.Named maybeName x)) -> do - whenJust maybeName $ tellNamedArgUsage headName - index x + forM_ args $ \(C.Arg argInfo (C.Named maybeName x)) -> + when (C.argInfoOrigin argInfo == C.UserWritten) $ do + whenJust maybeName $ tellNamedArgUsage headName + index x indexWithExpr :: A.WithExpr -> IndexerM () -indexWithExpr (C.Named maybeName (C.Arg _argInfo expr)) = do - whenJust maybeName $ \(A.BindName name) -> - tellDef name Param UnknownType - index expr +indexWithExpr (C.Named maybeName (C.Arg argInfo expr)) = + when (C.argInfoOrigin argInfo == C.UserWritten) $ do + whenJust maybeName $ \(A.BindName name) -> + tellDef name Param UnknownType + index expr instance Indexable Lit.Literal where index = \case @@ -330,8 +341,9 @@ instance (Indexable a) => Indexable (A.LHSCore' a) where index lhsHead index withPatterns -- TODO: what do the named args mean? - forM_ pats $ \(C.Arg _argInfo (C.Named _name pat)) -> - index pat + forM_ pats $ \(C.Arg argInfo (C.Named _name pat)) -> + when (C.argInfoOrigin argInfo == C.UserWritten) $ + index pat instance Indexable A.LHS where index (A.LHS lhsInfo core) = case Info.lhsEllipsis lhsInfo of @@ -412,6 +424,7 @@ instance Indexable A.ImportDirective where instance Indexable A.LetBinding where index = \case A.LetBind _letInfo _argInfo boundName type' expr -> do + -- TODO: what does the `ArgInfo` mean? tellDef boundName Local type' index type' index expr @@ -431,10 +444,12 @@ instance Indexable A.LetBinding where indexNamedArgBinder :: (TypeLike t, HasParamNames t) => C.NamedArg A.Binder -> t -> IndexerM () -indexNamedArgBinder namedArgBinder typeLike = do - let A.Binder pat name = C.namedThing $ C.unArg namedArgBinder - tellDef name Param typeLike - index pat +indexNamedArgBinder + (C.Arg argInfo (C.Named _maybeArgName (A.Binder pat name))) + typeLike = + when (C.argInfoOrigin argInfo == C.UserWritten) $ do + tellDef name Param typeLike + index pat instance Indexable A.TypedBinding where index = \case diff --git a/test/data/AST/Basic b/test/data/AST/Basic new file mode 100644 index 0000000..49fe7d5 --- /dev/null +++ b/test/data/AST/Basic @@ -0,0 +1,237 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> Basic, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Basic.Nat, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Basic.Nat, dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.one, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.Nat}], + ScopedDecl -> + [FunDef -> + {name -> Basic.one, + clauses -> + [lhs = ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Con -> Basic.Nat.suc, + arg -> ScopedExpr -> Con -> Basic.Nat.zero}]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.two, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.Nat}], + ScopedDecl -> + [FunDef -> + {name -> Basic.two, + clauses -> + [lhs = ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Con -> Basic.Nat.suc, + arg -> ScopedExpr -> Def' -> Basic.one}]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Basic.Test, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Basic.Test, dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Basic.Test', + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Basic.Test', dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.hello, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.Test}], + ScopedDecl -> + [FunDef -> + {name -> Basic.hello, + clauses -> + [lhs = ScopedExpr -> + Con -> Basic.Test.test | Basic.Test'.test]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Basic.Empty, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Basic.Empty, dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.Not, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Agda.Primitive.Set, + codom -> ScopedExpr -> Def' -> Agda.Primitive.Set}}], + ScopedDecl -> + [FunDef -> + {name -> Basic.Not, + clauses -> + [lhs = ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Var -> A, + codom -> ScopedExpr -> Def' -> Basic.Empty}]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.Goodbye, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [FunDef -> + {name -> Basic.Goodbye, + clauses -> + [lhs = ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Def' -> Basic.Not, + arg -> ScopedExpr -> Def' -> Basic.Test}]}]]], + ScopedDecl -> + [Axiom -> + {kindOfName -> AxiomName, name -> Basic.A, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Basic.Test, + codom -> ScopedExpr -> Def' -> Agda.Primitive.Set}}], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.testId, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Basic.Test, + codom -> ScopedExpr -> Def' -> Basic.Test}}], + ScopedDecl -> + [FunDef -> + {name -> Basic.testId, + clauses -> + [lhs = ScopedExpr -> + Con -> Basic.Test.test | Basic.Test'.test]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.id, + type -> + ScopedExpr -> + ScopedExpr -> + Pi -> + {dom -> + [([UserWritten A] : ScopedExpr -> Def' -> Agda.Primitive.Set)], + codom -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Var -> A, + codom -> ScopedExpr -> Var -> A}}}], + ScopedDecl -> + [FunDef -> + {name -> Basic.id, clauses -> [lhs = ScopedExpr -> Expr ->]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.id', + type -> + ScopedExpr -> + ScopedExpr -> + Pi -> + {dom -> + [([UserWritten A] : ScopedExpr -> Def' -> Agda.Primitive.Set)], + codom -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Var -> A, + codom -> ScopedExpr -> Var -> A}}}], + ScopedDecl -> + [FunDef -> + {name -> Basic.id', clauses -> [lhs = ScopedExpr -> Expr ->]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.id'', + type -> + ScopedExpr -> + ScopedExpr -> + Pi -> + {dom -> + [([UserWritten A] : ScopedExpr -> Def' -> Agda.Primitive.Set)], + codom -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Var -> A, + codom -> ScopedExpr -> Var -> A}}}], + ScopedDecl -> + [FunDef -> + {name -> Basic.id'', + clauses -> + [lhs = ScopedExpr -> + Let -> + {bindings -> + [letDeclared x, let x = ScopedExpr -> Var -> x, letDeclared A, + let A = ScopedExpr -> Var -> A], + body -> ScopedExpr -> Var -> x}]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [RecSig -> + {name -> Basic.World, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + type -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [RecDef -> + {name -> Basic.World, dataDefParams -> [], + decls -> + [ScopedDecl -> + [Field -> + {name -> Basic.World.north, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.Test}], + ScopedDecl -> + [Field -> + {name -> Basic.World.south, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.Test'}]]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Basic.earth, + type -> ScopedExpr -> ScopedExpr -> Def' -> Basic.World}], + ScopedDecl -> + [FunDef -> + {name -> Basic.earth, + clauses -> + [lhs = ScopedExpr -> Con -> Basic.Test.test | Basic.Test'.test, + lhs = ScopedExpr -> + Con -> Basic.Test.test | Basic.Test'.test]}]]]]}] \ No newline at end of file diff --git a/test/data/AST/FunWithoutDeclOrDef b/test/data/AST/FunWithoutDeclOrDef new file mode 100644 index 0000000..b731557 --- /dev/null +++ b/test/data/AST/FunWithoutDeclOrDef @@ -0,0 +1,34 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> FunWithoutDeclOrDef, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> FunWithoutDeclOrDef.Nat, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> + {name -> FunWithoutDeclOrDef.Nat, dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> FunWithoutDeclOrDef.sucsuc, + type -> ScopedExpr -> Expr ->}], + ScopedDecl -> + [FunDef -> + {name -> FunWithoutDeclOrDef.sucsuc, + clauses -> [lhs = ScopedExpr -> Expr ->]}]]], + ScopedDecl -> + [Axiom -> + {kindOfName -> AxiomName, name -> FunWithoutDeclOrDef.sucsucsuc, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> FunWithoutDeclOrDef.Nat, + codom -> ScopedExpr -> Def' -> FunWithoutDeclOrDef.Nat}}]]}] \ No newline at end of file diff --git a/test/data/AST/Module b/test/data/AST/Module new file mode 100644 index 0000000..69683cc --- /dev/null +++ b/test/data/AST/Module @@ -0,0 +1,42 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> Module, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Module.Nat, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Module.Nat, dataDefParams -> []}]]], + ScopedDecl -> + [Section -> + {moduleName -> Module.M, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Module.M.f, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Module.Nat, + codom -> ScopedExpr -> Def' -> Module.Nat}}], + ScopedDecl -> + [FunDef -> + {name -> Module.M.f, clauses -> [lhs = ScopedExpr -> Var -> n]}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Module.M.N, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Module.M.N, dataDefParams -> []}]]]]}]]}] \ No newline at end of file diff --git a/test/data/AST/Mutual b/test/data/AST/Mutual new file mode 100644 index 0000000..3afcbad --- /dev/null +++ b/test/data/AST/Mutual @@ -0,0 +1,133 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> Mutual, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Mutual.Nat, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Mutual.Nat, dataDefParams -> []}]]], + ScopedDecl -> + [Section -> + {moduleName -> Mutual.Forward, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [RecSig -> + {name -> Mutual.Forward.MutualRecord, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, + generalizeTel -> + [([UserWritten A] : ScopedExpr -> + Def' -> + Agda.Primitive.Set), + ([UserWritten n] : ScopedExpr -> + Def' -> Mutual.Nat)]}, + type -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataSig -> + {name -> Mutual.Forward.MutualData, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataSig -> + {name -> Mutual.Forward.MutualData', + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Mutual.Nat, + codom -> ScopedExpr -> Def' -> Agda.Primitive.Set}}], + ScopedDecl -> + [Axiom -> + {kindOfName -> FunName, name -> Mutual.Forward.mutualFun, + type -> + ScopedExpr -> + ScopedExpr -> + Fun -> + {dom -> + ScopedExpr -> + App -> + {f -> + ScopedExpr -> + App -> + {f -> + ScopedExpr -> + Def' -> Mutual.Forward.MutualRecord, + arg -> + ScopedExpr -> + Def' -> Mutual.Forward.MutualData}, + arg -> ScopedExpr -> Con -> Mutual.Nat.zero}, + codom -> + ScopedExpr -> + ScopedExpr -> + App -> + {f -> + ScopedExpr -> + App -> + {f -> + ScopedExpr -> + Def' -> Mutual.Forward.MutualRecord, + arg -> + ScopedExpr -> + Def' -> Mutual.Forward.MutualData}, + arg -> ScopedExpr -> Con -> Mutual.Nat.zero}}}], + ScopedDecl -> + [RecDef -> + {name -> Mutual.Forward.MutualRecord, + dataDefParams -> [UserWritten A, UserWritten m], + decls -> + [ScopedDecl -> + [Field -> + {name -> Mutual.Forward.MutualRecord.mutFieldX, + type -> ScopedExpr -> ScopedExpr -> Var -> A}], + ScopedDecl -> + [Field -> + {name -> Mutual.Forward.MutualRecord.mutFieldY, + type -> ScopedExpr -> ScopedExpr -> Def' -> Mutual.Nat}]]}], + ScopedDecl -> + [DataDef -> + {name -> Mutual.Forward.MutualData, dataDefParams -> []}], + ScopedDecl -> + [DataDef -> + {name -> Mutual.Forward.MutualData', + dataDefParams -> [UserWritten A]}], + ScopedDecl -> + [FunDef -> + {name -> Mutual.Forward.mutualFun, + clauses -> [lhs = ScopedExpr -> Var -> x]}]]]]}], + ScopedDecl -> + [Section -> + {moduleName -> Mutual.Backward, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [Axiom -> + {kindOfName -> AxiomName, name -> Mutual.Backward.MutualData, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [Axiom -> + {kindOfName -> AxiomName, name -> Mutual.Backward.MutualData', + type -> + ScopedExpr -> + ScopedExpr -> + Pi -> + {dom -> + [([UserWritten A] : ScopedExpr -> + Def' -> Agda.Primitive.Set)], + codom -> + ScopedExpr -> + Fun -> + {dom -> ScopedExpr -> Def' -> Mutual.Nat, + codom -> + ScopedExpr -> Def' -> Agda.Primitive.Set}}}]]]]}]]}] \ No newline at end of file diff --git a/test/data/AST/Record b/test/data/AST/Record new file mode 100644 index 0000000..85f93a6 --- /dev/null +++ b/test/data/AST/Record @@ -0,0 +1,68 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> Record, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> + [ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [DataSig -> + {name -> Record.Nat, + type -> ScopedExpr -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [DataDef -> {name -> Record.Nat, dataDefParams -> []}]]], + ScopedDecl -> + [Mutual -> + [ScopedDecl -> + [RecSig -> + {name -> Record.R, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, + generalizeTel -> + [([UserWritten n] : ScopedExpr -> Def' -> Record.Nat), + ([UserWritten A] : ScopedExpr -> + Fun -> + {dom -> + ScopedExpr -> + Def' -> Record.Nat, + codom -> + ScopedExpr -> + Def' -> + Agda.Primitive.Set}), + ([UserWritten x] : ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Var -> A, + arg -> + ScopedExpr -> Var -> n})]}, + type -> ScopedExpr -> Def' -> Agda.Primitive.Set}], + ScopedDecl -> + [RecDef -> + {name -> Record.R, + dataDefParams -> [UserWritten n, UserWritten A, UserWritten x], + decls -> + [ScopedDecl -> + [Field -> + {name -> Record.R.fieldX, + type -> ScopedExpr -> ScopedExpr -> Def' -> Record.Nat}], + ScopedDecl -> + [Field -> + {name -> Record.R.fieldY, + type -> + ScopedExpr -> + ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Var -> A, + arg -> ScopedExpr -> Var -> n}}], + ScopedDecl -> + [Field -> + {name -> Record.R.fieldZ, + type -> + ScopedExpr -> + ScopedExpr -> + ScopedExpr -> + App -> + {f -> ScopedExpr -> Var -> A, + arg -> ScopedExpr -> Proj -> Record.R.fieldX}}]]}]]]]}] \ No newline at end of file diff --git a/test/data/AST/Small b/test/data/AST/Small new file mode 100644 index 0000000..5651642 --- /dev/null +++ b/test/data/AST/Small @@ -0,0 +1,6 @@ +[ScopedDecl -> [Import -> Agda.Primitive], + Section -> + {moduleName -> Small, + genTel -> + GeneralizeTelescope {generalizeTelVars -> {}, generalizeTel -> []}, + decls -> []}] \ No newline at end of file diff --git a/test/data/Indexer/Module.agda b/test/data/Indexer/Module.agda new file mode 100644 index 0000000..6685305 --- /dev/null +++ b/test/data/Indexer/Module.agda @@ -0,0 +1,12 @@ +module Module where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat + +module M where + f : Nat -> Nat + f n = n + + data N : Set where + n : N From 7af7bd24939fb97c34c271ee98edc9db5a96c5be Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 16:55:09 -0400 Subject: [PATCH 07/47] deduplicate simultaneous declaration/definition --- src/Indexer/Monad.hs | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Indexer/Monad.hs b/src/Indexer/Monad.hs index 61d4fcf..1af5b42 100644 --- a/src/Indexer/Monad.hs +++ b/src/Indexer/Monad.hs @@ -27,13 +27,14 @@ import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Common as C import Agda.Syntax.Position (HasRange, getRange) import Agda.Utils.IORef (IORef, modifyIORef', newIORef, readIORef) -import Agda.Utils.Lens (over) +import Agda.Utils.Lens (over, (^.)) import Agda.Utils.List1 (List1, concatMap1) import Agda.Utils.Maybe (isNothing) import Control.Applicative ((<|>)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks) import Control.Monad.Trans (lift) +import Data.Foldable (find) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.LSP.Server as LSP @@ -41,7 +42,7 @@ import Monad (ServerM) import Options (Config) import Server.Model.AgdaFile (AgdaFile, agdaFileRefs, agdaFileSymbols, emptyAgdaFile, insertRef, insertSymbolInfo) import Server.Model.Monad (WithAgdaLibM) -import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..)) +import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..), refKind, refRange) data NamedArgUsage = NamedArgUsage { nauHead :: !A.AmbiguousQName, @@ -81,8 +82,7 @@ type IndexerM = ReaderT Env WithAgdaLibM execIndexerM :: IndexerM a -> WithAgdaLibM AgdaFile execIndexerM x = do env <- initEnv - _ <- runReaderT x env - -- TODO: resolve named arg usages + _ <- runReaderT (x >> postprocess) env liftIO $ readIORef $ envAgdaFile env -------------------------------------------------------------------------------- @@ -167,6 +167,27 @@ withParent nameLike = local $ \e -> e {envParent = Just $ toQName nameLike} -------------------------------------------------------------------------------- +postprocess :: IndexerM () +postprocess = do + agdaFileRef <- asks envAgdaFile + -- TODO: resolve named arg usages + liftIO $ modifyIORef' agdaFileRef $ over agdaFileRefs $ Map.map dedupSimultaneousDeclDef + +-- | We sometimes emit a `Decl` and `Def` for the same source range. For +-- example, we must emit a distinct `Decl` and `Def` when a `data` is declared +-- and defined separately, but not when it is declared and defined all at once. +-- It is harder distinguish these in abstract syntax than to idenfify and +-- correct them at the end. +dedupSimultaneousDeclDef :: [Ref] -> [Ref] +dedupSimultaneousDeclDef refs = + case find (\ref -> refKind ref == Decl) refs of + Nothing -> refs + Just decl -> + let pred ref = not (refKind ref == Def && refRange ref == refRange decl) + in filter pred refs + +-------------------------------------------------------------------------------- + class (AmbiguousNameLike n) => NameLike n where toQName :: n -> A.QName From f5bf5efca701202665a7dc86cdbc036354c44685 Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 17:21:00 -0400 Subject: [PATCH 08/47] write ASTs to file for debugging purposes --- .gitignore | 1 + src/Indexer.hs | 49 +++++++++++++++++++++++++++------ test/Test/Indexer/Invariants.hs | 18 ++++++++++-- 3 files changed, 57 insertions(+), 11 deletions(-) diff --git a/.gitignore b/.gitignore index 14ce36d..c978c7c 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ cabal-dev dist dist-* +test/data/AST/ node_modules/ *.o *.hi diff --git a/src/Indexer.hs b/src/Indexer.hs index 9b65b45..d9e1b5f 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -1,12 +1,21 @@ -module Indexer (indexFile) where - -import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) +{-# LANGUAGE CPP #-} + +module Indexer + ( withAstFor, + indexFile, + ) +where + +#if MIN_VERSION_Agda(2,8,0) +#else +import Agda.Interaction.FindFile (srcFilePath) +#endif import qualified Agda.Interaction.Imports as Imp import qualified Agda.Interaction.Imports.More as Imp import Agda.Interaction.Library (getPrimitiveLibDir) import Agda.Interaction.Options (defaultOptions, optLoadPrimitives) import qualified Agda.Syntax.Concrete as C -import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel)) +import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel), TopLevelInfo) import Agda.Syntax.Translation.ReflectedToAbstract (toAbstract_) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.FileName (AbsolutePath, filePath, mkAbsolute) @@ -22,10 +31,26 @@ import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (MonadAgdaLib, WithAgdaLibM) import System.FilePath (()) -indexFile :: - Imp.Source -> - WithAgdaLibM AgdaFile -indexFile src = do +withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a +#if MIN_VERSION_Agda(2,8,0) +withAstFor src f = do + TCM.liftTCM $ + TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ + -- Now reset the options + TCM.setCommandLineOptions . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC + + TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) + + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) $ do + let topLevel = + TopLevel + (Imp.srcOrigin src) + (Imp.srcModuleName src) + (C.modDecls $ Imp.srcModule src) + ast <- TCM.liftTCM $ toAbstract topLevel + f ast +#else +withAstFor src f = do currentOptions <- TCM.useTC TCM.stPragmaOptions TCM.liftTCM $ @@ -42,7 +67,13 @@ indexFile src = do (Imp.srcModuleName src) (C.modDecls $ Imp.srcModule src) ast <- TCM.liftTCM $ toAbstract topLevel - abstractToIndex ast + f ast +#endif + +indexFile :: + Imp.Source -> + WithAgdaLibM AgdaFile +indexFile src = withAstFor src abstractToIndex -- let options = defaultOptions diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index bdc067c..8873aba 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -3,6 +3,9 @@ module Test.Indexer.Invariants (tests) where import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Options (defaultOptions) +import Agda.Syntax.Abstract.More () +import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Syntax.Translation.ConcreteToAbstract (TopLevelInfo (topLevelDecls)) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.FileName (absolute) import Agda.Utils.Lens ((^.)) @@ -12,14 +15,14 @@ import Data.Foldable (traverse_) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import Indexer (indexFile) +import Indexer (indexFile, withAstFor) import Indexer.Indexer (abstractToIndex) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerM) import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) import Server.Model.Monad (withAgdaLibFor) -import System.FilePath (takeBaseName) +import System.FilePath (takeBaseName, ()) import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) @@ -48,6 +51,17 @@ tests = do checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src return $ Imp.crInterface checkResult + ast <- withAgdaLibFor uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + withAstFor src return + + -- Write the AST to a file for debugging purposes + liftIO $ writeFile ("test/data/AST" testName) $ prettyShow $ topLevelDecls ast + withAgdaLibFor uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath From aef4fc1cf71f2d36633159587dbaa8943847bf9f Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 17:42:08 -0400 Subject: [PATCH 09/47] don't reindex record type --- src/Indexer/Indexer.hs | 8 +++++--- test/data/Indexer/Record.agda | 12 ++++++++++++ 2 files changed, 17 insertions(+), 3 deletions(-) create mode 100644 test/data/Indexer/Record.agda diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 3f87951..e57627e 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -116,11 +116,13 @@ instance Indexable A.Declaration where index defInfo index genTel index type' - A.RecDef defInfo name _univCheck recDirectives dataDefParams type' decls -> do - tellDef name Record type' + A.RecDef defInfo name _univCheck recDirectives dataDefParams _type' decls -> do + -- The type associated with a `RecDef` is a Pi type including the record's + -- fields, which is not what we want. The `RecSig` does have the type we + -- want, so we use that instead. + tellDef name Record UnknownType index defInfo index dataDefParams - index type' withParent name $ do index recDirectives index decls diff --git a/test/data/Indexer/Record.agda b/test/data/Indexer/Record.agda new file mode 100644 index 0000000..3330b2c --- /dev/null +++ b/test/data/Indexer/Record.agda @@ -0,0 +1,12 @@ +module Record where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat + +record R (n : Nat) (A : Nat -> Set) (x : A n) : Set where + constructor makeR + field + fieldX : Nat + fieldY : A n + fieldZ : A fieldX From 2f5152480b1098eed6ed1339c31bf8570a38f3c8 Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 18:22:26 -0400 Subject: [PATCH 10/47] deduplicate decl/defs in let bindings --- src/Agda/Syntax/Abstract/More.hs | 30 +++++++++++++++++++++++++----- src/Indexer/Indexer.hs | 2 +- 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs index 7582e9b..cc003ce 100644 --- a/src/Agda/Syntax/Abstract/More.hs +++ b/src/Agda/Syntax/Abstract/More.hs @@ -79,14 +79,14 @@ instance Pretty Declaration where ( text "RecSig", prettyMap [ (text "name", pretty name), + (text "genTel", pretty genTel), (text "type", pretty type') ] ) - RecDef _defInfo name _univCheck _recDirs _dataDefParams type' decls -> + RecDef _defInfo name _univCheck _recDirs _dataDefParams _type' decls -> ( text "RecDef", prettyMap [ (text "name", pretty name), - (text "type", pretty type'), (text "decls", pretty decls) ] ) @@ -134,11 +134,21 @@ instance Pretty Expr where (text "codom", pretty codom) ] ) + Let _exprInfo bindings body -> + ( text "Let", + prettyMap + [ (text "bindings", pretty bindings), + (text "body", pretty body) + ] + ) -- ... ScopedExpr _scopeInfo expr -> (text "ScopedExpr", pretty expr) -- ... _ -> ("Expr", mempty) +instance (Pretty a) => Pretty (Pattern' a) where + pretty _pat = text "pat" + debugNamedBinder :: NamedArg Binder -> Doc debugNamedBinder (Arg argInfo binder) = pshow (argInfoOrigin argInfo) <+> pretty binder @@ -154,6 +164,7 @@ instance Pretty LetBinding where text "let" <+> pretty (unBind name) <+> text "=" <+> pretty expr LetPatBind _letInfo pat expr -> text "letPat" <+> pretty pat <+> text "=" <+> pretty expr + LetDeclaredVariable name -> text "letDeclared" <+> pretty (unBind name) _ -> text "LetBinding" instance Pretty Binder where @@ -172,10 +183,19 @@ instance Pretty GeneralizeTelescope where [ ( "GeneralizeTelescope", prettyMap [ (text "generalizeTelVars", prettyMap $ Map.toList $ generalizeTelVars genTel), - (text "generalizeTel", pretty $ show <$> generalizeTel genTel) + (text "generalizeTel", pretty $ generalizeTel genTel) ] ) ] -instance Pretty (Clause' lhs) where - pretty clause = text "clause" +instance (Pretty lhs) => Pretty (Clause' lhs) where + pretty (Clause lhs _strippedPats rhs whereDecls _catchall) = + pretty lhs <+> text "=" <+> pretty rhs + +instance Pretty LHS where + pretty _lhs = text "lhs" + +instance Pretty RHS where + pretty = \case + RHS expr _concrete -> pretty expr + _ -> text "rhs" diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index e57627e..2d46f8a 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -441,7 +441,7 @@ instance Indexable A.LetBinding where tellUsage moduleName index importDirective A.LetDeclaredVariable boundName -> - tellDef boundName Local UnknownType + tellDecl boundName Local UnknownType indexNamedArgBinder :: (TypeLike t, HasParamNames t) => From 5b4f545922c6bc4e70d65820750a2be753c4f177 Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 15 Aug 2025 18:35:20 -0400 Subject: [PATCH 11/47] test functions without definitions/declarations --- test/data/Indexer/FunWithoutDeclOrDef.agda | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 test/data/Indexer/FunWithoutDeclOrDef.agda diff --git a/test/data/Indexer/FunWithoutDeclOrDef.agda b/test/data/Indexer/FunWithoutDeclOrDef.agda new file mode 100644 index 0000000..86f00bd --- /dev/null +++ b/test/data/Indexer/FunWithoutDeclOrDef.agda @@ -0,0 +1,11 @@ +module FunWithoutDeclOrDef where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat + +-- No declaration +sucsuc = \n -> suc (suc n) + +-- No definition +sucsucsuc : Nat -> Nat From 23c647b2d99cbb31689b877a772b2838ed15071d Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 18 Aug 2025 11:00:02 -0400 Subject: [PATCH 12/47] deduplicate data/record params --- agda-language-server.cabal | 2 + src/Agda/Syntax/Abstract/More.hs | 20 ++++- src/Indexer.hs | 24 ++---- src/Indexer/Indexer.hs | 86 +++++++++++---------- src/Indexer/Monad.hs | 128 +++++++++++++++++++------------ src/Indexer/Postprocess.hs | 57 ++++++++++++++ src/Server/Model/AgdaFile.hs | 26 ++++++- src/Server/Model/Symbol.hs | 11 ++- test/Test/Indexer/Invariants.hs | 7 -- test/data/Indexer/Basic.agda | 21 ----- test/data/Indexer/Mutual.agda | 41 ++++++++++ 11 files changed, 281 insertions(+), 142 deletions(-) create mode 100644 src/Indexer/Postprocess.hs create mode 100644 test/data/Indexer/Mutual.agda diff --git a/agda-language-server.cabal b/agda-language-server.cabal index e8b0e64..2356b16 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -58,6 +58,7 @@ library Indexer Indexer.Indexer Indexer.Monad + Indexer.Postprocess Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad @@ -199,6 +200,7 @@ test-suite als-test Indexer Indexer.Indexer Indexer.Monad + Indexer.Postprocess Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs index cc003ce..efd4131 100644 --- a/src/Agda/Syntax/Abstract/More.hs +++ b/src/Agda/Syntax/Abstract/More.hs @@ -73,8 +73,13 @@ instance Pretty Declaration where (text "type", pretty type') ] ) - DataDef _defIngo name _univCheck _dataDefParams _ctors -> - (text "DataDef", prettyMap [(text "name", pretty name)]) + DataDef _defIngo name _univCheck dataDefParams _ctors -> + ( text "DataDef", + prettyMap + [ (text "name", pretty name), + (text "dataDefParams", pretty dataDefParams) + ] + ) RecSig _defInfo _erased name genTel type' -> ( text "RecSig", prettyMap @@ -83,10 +88,11 @@ instance Pretty Declaration where (text "type", pretty type') ] ) - RecDef _defInfo name _univCheck _recDirs _dataDefParams _type' decls -> + RecDef _defInfo name _univCheck _recDirs dataDefParams _type' decls -> ( text "RecDef", prettyMap [ (text "name", pretty name), + (text "dataDefParams", pretty dataDefParams), (text "decls", pretty decls) ] ) @@ -170,6 +176,11 @@ instance Pretty LetBinding where instance Pretty Binder where pretty binder = pretty $ unBind $ binderName binder +instance Pretty LamBinding where + pretty = \case + DomainFree _tacticAttr namedArgBinder -> debugNamedBinder namedArgBinder + DomainFull binding -> pretty binding + instance (Pretty t) => Pretty (DefInfo' t) where pretty defInfo = align @@ -199,3 +210,6 @@ instance Pretty RHS where pretty = \case RHS expr _concrete -> pretty expr _ -> text "rhs" + +instance Pretty DataDefParams where + pretty (DataDefParams _generalized params) = pretty params diff --git a/src/Indexer.hs b/src/Indexer.hs index d9e1b5f..73b13fb 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -11,25 +11,15 @@ where import Agda.Interaction.FindFile (srcFilePath) #endif import qualified Agda.Interaction.Imports as Imp -import qualified Agda.Interaction.Imports.More as Imp -import Agda.Interaction.Library (getPrimitiveLibDir) -import Agda.Interaction.Options (defaultOptions, optLoadPrimitives) import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel), TopLevelInfo) -import Agda.Syntax.Translation.ReflectedToAbstract (toAbstract_) import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.FileName (AbsolutePath, filePath, mkAbsolute) -import Agda.Utils.Monad (bracket_, unlessM, when) -import qualified Agda.Utils.Trie as Trie -import Control.Monad (forM_, void) -import Control.Monad.IO.Class (liftIO) import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Strict as Strict -import Indexer.Indexer (abstractToIndex) +import Indexer.Indexer (indexAst) +import Indexer.Monad (execIndexerM) +import Indexer.Postprocess (postprocess) import Server.Model.AgdaFile (AgdaFile) -import Server.Model.Monad (MonadAgdaLib, WithAgdaLibM) -import System.FilePath (()) +import Server.Model.Monad (WithAgdaLibM) withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a #if MIN_VERSION_Agda(2,8,0) @@ -51,8 +41,6 @@ withAstFor src f = do f ast #else withAstFor src f = do - currentOptions <- TCM.useTC TCM.stPragmaOptions - TCM.liftTCM $ TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ -- Now reset the options @@ -73,7 +61,9 @@ withAstFor src f = do indexFile :: Imp.Source -> WithAgdaLibM AgdaFile -indexFile src = withAstFor src abstractToIndex +indexFile src = withAstFor src $ \ast -> execIndexerM $ do + indexAst ast + postprocess -- let options = defaultOptions diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 2d46f8a..5394729 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -module Indexer.Indexer (abstractToIndex) where +module Indexer.Indexer (indexAst) where import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Common as C @@ -26,6 +26,7 @@ import qualified Data.Set as Set import Data.Void (absurd) import Indexer.Monad ( AmbiguousNameLike (..), + BindingKind (..), HasParamNames (..), IndexerM, NameLike (..), @@ -33,24 +34,22 @@ import Indexer.Monad SymbolKindLike (..), TypeLike (..), UnknownType (UnknownType), - execIndexerM, + tellBinding, tellDecl, tellDef, + tellDefParams, + tellGenTel, tellImport, tellNamedArgUsage, tellParamNames, tellUsage, + withBindingKind, withParent, ) -import qualified Language.LSP.Server as LSP -import Monad (ServerM) -import Options (Config) -import Server.Model.AgdaFile (AgdaFile) -import Server.Model.Monad (WithAgdaLibM) import Server.Model.Symbol (SymbolKind (..)) -abstractToIndex :: TopLevelInfo -> WithAgdaLibM AgdaFile -abstractToIndex (TopLevelInfo decls _scope) = execIndexerM $ index decls +indexAst :: TopLevelInfo -> IndexerM () +indexAst (TopLevelInfo decls _scope) = index decls class Indexable a where index :: a -> IndexerM () @@ -98,34 +97,41 @@ instance Indexable A.Declaration where A.Open _moduleInfo moduleName importDirective -> do tellUsage moduleName index importDirective - A.FunDef _defInfo name clauses -> do + A.FunDef _defInfo name clauses -> withBindingKind DefBinding $ do + -- function declarations are captured by the `Axiom` case withParent name $ do index clauses - A.DataSig defInfo _erased name genTel type' -> do - tellDecl name Data type' - index defInfo - index genTel - index type' - A.DataDef defInfo name _univCheck dataDefParams constructors -> do - tellDef name Data UnknownType - index defInfo - index dataDefParams - index constructors - A.RecSig defInfo _erased name genTel type' -> do - tellDecl name Record type' - index defInfo - index genTel - index type' - A.RecDef defInfo name _univCheck recDirectives dataDefParams _type' decls -> do - -- The type associated with a `RecDef` is a Pi type including the record's - -- fields, which is not what we want. The `RecSig` does have the type we - -- want, so we use that instead. - tellDef name Record UnknownType - index defInfo - index dataDefParams - withParent name $ do - index recDirectives - index decls + A.DataSig defInfo _erased name genTel type' -> + withBindingKind DeclBinding $ do + tellDecl name Data type' + index defInfo + index genTel + tellGenTel name genTel + index type' + A.DataDef _defInfo name _univCheck dataDefParams constructors -> + withBindingKind DefBinding $ do + tellDef name Data UnknownType + index dataDefParams + tellDefParams name dataDefParams + index constructors + A.RecSig defInfo _erased name genTel type' -> + withBindingKind DeclBinding $ do + tellDecl name Record type' + index defInfo + index genTel + tellGenTel name genTel + index type' + A.RecDef _defInfo name _univCheck recDirectives dataDefParams _type' decls -> + withBindingKind DefBinding $ do + -- The type associated with a `RecDef` is a Pi type including the record's + -- fields, which is not what we want. The `RecSig` does have the type we + -- want, so we use that instead. + tellDef name Record UnknownType + index dataDefParams + tellDefParams name dataDefParams + withParent name $ do + index recDirectives + index decls A.PatternSynDef name bindings pat -> do tellDecl name PatternSyn UnknownType forM_ bindings $ \(C.WithHiding _hiding binding) -> @@ -391,7 +397,7 @@ instance (Indexable a) => Indexable (A.Clause' a) where instance Indexable A.ModuleApplication where index = \case A.SectionApp tele moduleName args -> do - index tele + withBindingKind DeclBinding $ index tele tellUsage moduleName indexNamedArgs moduleName args A.RecordModuleInstance moduleName -> @@ -427,7 +433,7 @@ instance Indexable A.LetBinding where index = \case A.LetBind _letInfo _argInfo boundName type' expr -> do -- TODO: what does the `ArgInfo` mean? - tellDef boundName Local type' + tellBinding boundName Local type' index type' index expr A.LetPatBind _letInfo pat expr -> do @@ -441,6 +447,7 @@ instance Indexable A.LetBinding where tellUsage moduleName index importDirective A.LetDeclaredVariable boundName -> + -- This is always a declaration tellDecl boundName Local UnknownType indexNamedArgBinder :: @@ -450,7 +457,7 @@ indexNamedArgBinder (C.Arg argInfo (C.Named _maybeArgName (A.Binder pat name))) typeLike = when (C.argInfoOrigin argInfo == C.UserWritten) $ do - tellDef name Param typeLike + tellBinding name Param typeLike index pat instance Indexable A.TypedBinding where @@ -474,7 +481,8 @@ instance Indexable A.GeneralizeTelescope where index (A.GeneralizeTel _generalizeVars tel) = index tel instance Indexable A.DataDefParams where - index (A.DataDefParams _generalizeParams params) = index params + index (A.DataDefParams _generalizeParams params) = + withBindingKind DefBinding $ index params instance Indexable A.RecordDirectives where index = \case diff --git a/src/Indexer/Monad.hs b/src/Indexer/Monad.hs index 1af5b42..ac16e94 100644 --- a/src/Indexer/Monad.hs +++ b/src/Indexer/Monad.hs @@ -5,13 +5,21 @@ module Indexer.Monad ( IndexerM, execIndexerM, + modifyAgdaFile', tellParamNames, + DataRecordParams (..), + tellDefParams, + tellGenTel, + getDataRecordParams, tellDef, tellDecl, + tellBinding, tellUsage, tellImport, tellNamedArgUsage, withParent, + BindingKind (..), + withBindingKind, NameLike (..), AmbiguousNameLike (..), SymbolKindLike (..), @@ -25,33 +33,45 @@ where import Agda.Position (toLspRange) import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Common as C -import Agda.Syntax.Position (HasRange, getRange) +import Agda.Syntax.Position (getRange) import Agda.Utils.IORef (IORef, modifyIORef', newIORef, readIORef) -import Agda.Utils.Lens (over, (^.)) import Agda.Utils.List1 (List1, concatMap1) -import Agda.Utils.Maybe (isNothing) import Control.Applicative ((<|>)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks) import Control.Monad.Trans (lift) -import Data.Foldable (find) import Data.Map (Map) import qualified Data.Map as Map -import qualified Language.LSP.Server as LSP -import Monad (ServerM) -import Options (Config) -import Server.Model.AgdaFile (AgdaFile, agdaFileRefs, agdaFileSymbols, emptyAgdaFile, insertRef, insertSymbolInfo) +import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile, insertRef, insertSymbolInfo) import Server.Model.Monad (WithAgdaLibM) -import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..), refKind, refRange) +import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..)) data NamedArgUsage = NamedArgUsage { nauHead :: !A.AmbiguousQName, nauArg :: !C.NamedName } +data DataRecordParams = DataRecordParams + { drpGenTel :: !(Maybe A.GeneralizeTelescope), + drpParams :: !(Maybe A.DataDefParams) + } + +instance Semigroup DataRecordParams where + DataRecordParams x y <> DataRecordParams x' y' = DataRecordParams (x <|> x') (y <|> y') + +instance Monoid DataRecordParams where + mempty = DataRecordParams Nothing Nothing + +data BindingKind = DeclBinding | DefBinding + +bindingKindToRefKind :: BindingKind -> RefKind +bindingKindToRefKind DeclBinding = Decl +bindingKindToRefKind DefBinding = Def + data Env = Env { envAgdaFile :: !(IORef AgdaFile), envParent :: !(Maybe A.QName), + envBindingKind :: !BindingKind, -- | Parameter names in implicit arguments, such as x in `f {x = y} = y` and -- `g y = f {x = y}`, are represented by strings in abstract syntax. This is -- because we need type checking information to resolve these names, not @@ -66,7 +86,8 @@ data Env = Env -- These are the stored parameter names, indexed by the name of the function -- (or other defined symbol). envParamNames :: !(IORef (Map A.QName [A.QName])), - envNamedArgUsages :: !(IORef [NamedArgUsage]) + envNamedArgUsages :: !(IORef [NamedArgUsage]), + envDataRecordParams :: !(IORef (Map A.QName DataRecordParams)) } initEnv :: (MonadIO m) => m Env @@ -75,31 +96,28 @@ initEnv = do let parent = Nothing paramNames <- liftIO $ newIORef Map.empty namedArgUsages <- liftIO $ newIORef [] - return $ Env agdaFile parent paramNames namedArgUsages + dataRecordParams <- liftIO $ newIORef mempty + return $ Env agdaFile parent DeclBinding paramNames namedArgUsages dataRecordParams type IndexerM = ReaderT Env WithAgdaLibM execIndexerM :: IndexerM a -> WithAgdaLibM AgdaFile execIndexerM x = do env <- initEnv - _ <- runReaderT (x >> postprocess) env + _ <- runReaderT x env liftIO $ readIORef $ envAgdaFile env -------------------------------------------------------------------------------- --- Used when inserting a new `SymbolInfo` into a map already containing a --- `SymbolInfo` for the given symbol -updateSymbolInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo -updateSymbolInfo new old = - SymbolInfo - (symbolKind old <> symbolKind new) - (symbolType old <|> symbolType new) - (symbolParent old <|> symbolParent new) +modifyAgdaFile' :: (AgdaFile -> AgdaFile) -> IndexerM () +modifyAgdaFile' f = do + agdaFileRef <- asks envAgdaFile + liftIO $ modifyIORef' agdaFileRef f tellSymbolInfo' :: A.QName -> SymbolInfo -> IndexerM () tellSymbolInfo' name symbolInfo = do agdaFileRef <- asks envAgdaFile - liftIO $ modifyIORef' agdaFileRef $ insertSymbolInfo updateSymbolInfo name symbolInfo + liftIO $ modifyIORef' agdaFileRef $ insertSymbolInfo name symbolInfo tellSymbolInfo :: (NameLike n, SymbolKindLike s, TypeLike t) => @@ -133,21 +151,51 @@ tellParamNames nameLike hasParamNames = do paramNamesRef <- asks envParamNames liftIO $ modifyIORef' paramNamesRef $ Map.insert name paramNames -tellDef :: +tellDefParams :: (NameLike n) => n -> A.DataDefParams -> IndexerM () +tellDefParams nameLike defParams = do + let name = toQName nameLike + dataRecordParamsRef <- asks envDataRecordParams + liftIO $ + modifyIORef' dataRecordParamsRef $ + Map.insertWith (<>) name (DataRecordParams Nothing (Just defParams)) + +tellGenTel :: (NameLike n) => n -> A.GeneralizeTelescope -> IndexerM () +tellGenTel nameLike genTel = do + let name = toQName nameLike + dataRecordParamsRef <- asks envDataRecordParams + liftIO $ + modifyIORef' dataRecordParamsRef $ + Map.insertWith (<>) name (DataRecordParams (Just genTel) Nothing) + +getDataRecordParams :: IndexerM (Map A.QName DataRecordParams) +getDataRecordParams = do + dataRecordParamsRef <- asks envDataRecordParams + liftIO $ readIORef dataRecordParamsRef + +tellBinding' :: (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => - n -> s -> t -> IndexerM () -tellDef n s t = do + BindingKind -> n -> s -> t -> IndexerM () +tellBinding' b n s t = do tellSymbolInfo n s t - tellRef n Def + tellRef n (bindingKindToRefKind b) tellParamNames n t +tellDef :: + (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => + n -> s -> t -> IndexerM () +tellDef = tellBinding' DefBinding + tellDecl :: (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => n -> s -> t -> IndexerM () -tellDecl n s t = do - tellSymbolInfo n s t - tellRef n Decl - tellParamNames n t +tellDecl = tellBinding' DeclBinding + +tellBinding :: + (NameLike n, SymbolKindLike s, TypeLike t, HasParamNames t) => + n -> s -> t -> IndexerM () +tellBinding n s t = do + b <- asks envBindingKind + tellBinding' b n s t tellUsage :: (AmbiguousNameLike n) => n -> IndexerM () tellUsage n = tellRef n Usage @@ -165,26 +213,8 @@ tellNamedArgUsage headNameLike argName = do withParent :: (NameLike n) => n -> IndexerM a -> IndexerM a withParent nameLike = local $ \e -> e {envParent = Just $ toQName nameLike} --------------------------------------------------------------------------------- - -postprocess :: IndexerM () -postprocess = do - agdaFileRef <- asks envAgdaFile - -- TODO: resolve named arg usages - liftIO $ modifyIORef' agdaFileRef $ over agdaFileRefs $ Map.map dedupSimultaneousDeclDef - --- | We sometimes emit a `Decl` and `Def` for the same source range. For --- example, we must emit a distinct `Decl` and `Def` when a `data` is declared --- and defined separately, but not when it is declared and defined all at once. --- It is harder distinguish these in abstract syntax than to idenfify and --- correct them at the end. -dedupSimultaneousDeclDef :: [Ref] -> [Ref] -dedupSimultaneousDeclDef refs = - case find (\ref -> refKind ref == Decl) refs of - Nothing -> refs - Just decl -> - let pred ref = not (refKind ref == Def && refRange ref == refRange decl) - in filter pred refs +withBindingKind :: BindingKind -> IndexerM a -> IndexerM a +withBindingKind bindingKind = local $ \e -> e {envBindingKind = bindingKind} -------------------------------------------------------------------------------- diff --git a/src/Indexer/Postprocess.hs b/src/Indexer/Postprocess.hs new file mode 100644 index 0000000..2ad2879 --- /dev/null +++ b/src/Indexer/Postprocess.hs @@ -0,0 +1,57 @@ +module Indexer.Postprocess (postprocess) where + +import qualified Agda.Syntax.Abstract as A +import qualified Agda.Syntax.Common as C +import Agda.Utils.Lens (over) +import Control.Arrow ((>>>)) +import Data.Foldable (Foldable (toList), find) +import qualified Data.Map as Map +import Indexer.Monad (DataRecordParams (DataRecordParams), IndexerM, getDataRecordParams, modifyAgdaFile') +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs, mergeSymbols) +import Server.Model.Symbol (Ref, RefKind (..), refKind, refRange) + +postprocess :: IndexerM () +postprocess = do + dataRecordParams <- Map.elems <$> getDataRecordParams + modifyAgdaFile' $ + dedupDataRecordParams dataRecordParams + >>> dedupSimultaneousDeclDef + +-- | We sometimes emit a `Decl` and `Def` for the same source range. For +-- example, we must emit a distinct `Decl` and `Def` when a `data` is declared +-- and defined separately, but not when it is declared and defined all at once. +-- It is harder distinguish these in abstract syntax than to idenfify and +-- correct them at the end. +dedupSimultaneousDeclDef :: AgdaFile -> AgdaFile +dedupSimultaneousDeclDef = over agdaFileRefs $ Map.map worker + where + worker :: [Ref] -> [Ref] + worker refs = + case find (\ref -> refKind ref == Decl) refs of + Nothing -> refs + Just decl -> + let pred ref = not (refKind ref == Def && refRange ref == refRange decl) + in filter pred refs + +dedupDataRecordParams :: [DataRecordParams] -> AgdaFile -> AgdaFile +dedupDataRecordParams dataRecordParams file = foldl' (flip worker) file dataRecordParams + where + namedArgBinderName :: C.NamedArg A.Binder -> A.QName + namedArgBinderName namedArgBinder = + A.qualify_ $ A.unBind $ A.binderName $ C.namedThing $ C.unArg namedArgBinder + typedBindingNames :: A.TypedBinding -> [A.QName] + typedBindingNames = \case + A.TBind _range _typedBindingInfo nabs _type' -> + namedArgBinderName <$> toList nabs + A.TLet _range _letBindings -> [] + lamBindingNames :: A.LamBinding -> [A.QName] + lamBindingNames = \case + A.DomainFree _tacticAttr nab -> [namedArgBinderName nab] + A.DomainFull typedBindings -> typedBindingNames typedBindings + worker :: DataRecordParams -> AgdaFile -> AgdaFile + worker (DataRecordParams (Just genTel) (Just params)) file = + let paramsNames = concatMap lamBindingNames $ A.dataDefParams params + genTelNames = concatMap typedBindingNames $ A.generalizeTel genTel + names = zip paramsNames genTelNames + in foldl' (\file (old, new) -> mergeSymbols old new file) file names + worker _missingParams file = file diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index b6c0941..2afad8d 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -5,14 +5,14 @@ module Server.Model.AgdaFile agdaFileRefs, insertSymbolInfo, insertRef, + mergeSymbols, ) where import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyAssign, prettyMap, text, vcat) import Agda.Utils.Lens (Lens', over, (<&>), (^.)) -import Control.Monad (forM) -import Data.Foldable (fold) +import Data.Function ((&)) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid (Endo (Endo, appEndo)) @@ -40,15 +40,33 @@ agdaFileRefs :: Lens' AgdaFile (Map A.QName [Ref]) agdaFileRefs f a = f (_agdaFileRefs a) <&> \x -> a {_agdaFileRefs = x} insertSymbolInfo :: - (SymbolInfo -> SymbolInfo -> SymbolInfo) -> A.QName -> SymbolInfo -> AgdaFile -> AgdaFile -insertSymbolInfo update name symbolInfo = over agdaFileSymbols $ Map.insertWith update name symbolInfo +insertSymbolInfo name symbolInfo = + over agdaFileSymbols $ Map.insertWith (<>) name symbolInfo insertRef :: A.AmbiguousQName -> Ref -> AgdaFile -> AgdaFile insertRef ambiguousName ref = over agdaFileRefs $ appEndo $ foldMap (\name -> Endo $ Map.insertWith (<>) name [ref]) (A.unAmbQ ambiguousName) + +mergeSymbols :: A.QName -> A.QName -> AgdaFile -> AgdaFile +mergeSymbols old new file = + file + & over + agdaFileSymbols + ( \symbols -> + let (oldSymbolInfo, symbols') = + Map.updateLookupWithKey (\_ _ -> Nothing) old symbols + in Map.alter (<> oldSymbolInfo) new symbols' + ) + & over + agdaFileRefs + ( \refs -> + let (oldRefs, refs') = + Map.updateLookupWithKey (\_ _ -> Nothing) old refs + in Map.alter (<> oldRefs) new refs' + ) diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index 1ea8f02..a45c7b2 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -7,8 +7,8 @@ module Server.Model.Symbol where import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parens, parensNonEmpty, pretty, pshow, text, (<+>)) -import Agda.Syntax.Position (Position, PositionWithoutFile) +import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parensNonEmpty, pretty, pshow, text, (<+>)) +import Control.Applicative ((<|>)) import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.More () @@ -48,6 +48,13 @@ instance Pretty SymbolInfo where pretty (symbolKind symbolInfo) <+> parensNonEmpty (pretty $ symbolType symbolInfo) +instance Semigroup SymbolInfo where + new <> old = + SymbolInfo + (symbolKind old <> symbolKind new) + (symbolType old <|> symbolType new) + (symbolParent old <|> symbolParent new) + data RefKind = -- | The symbol is being declared. There should be at most one declaration -- for any given symbol (in correct Agda code). Roughly speaking, this is diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index 8873aba..6884457 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -8,26 +8,19 @@ import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Translation.ConcreteToAbstract (TopLevelInfo (topLevelDecls)) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.FileName (absolute) -import Agda.Utils.Lens ((^.)) import Control.Monad (forM) import Control.Monad.IO.Class (liftIO) -import Data.Foldable (traverse_) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Indexer (indexFile, withAstFor) -import Indexer.Indexer (abstractToIndex) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerM) -import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) import Server.Model.Monad (withAgdaLibFor) import System.FilePath (takeBaseName, ()) import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension) -import Test.Tasty.HUnit (testCase) import qualified TestData tests :: IO TestTree diff --git a/test/data/Indexer/Basic.agda b/test/data/Indexer/Basic.agda index 43a86ef..3ddbb80 100644 --- a/test/data/Indexer/Basic.agda +++ b/test/data/Indexer/Basic.agda @@ -52,24 +52,3 @@ record World : Set where earth : World earth .World.north = test earth .World.south = test - -interleaved mutual - record MutualRecord (A : Set) : Set - data MutualData : Set - data MutualData' : Set - mutualFun : MutualRecord MutualData -> MutualRecord MutualData - - record MutualRecord A where - constructor makeMutualRecord - field - mutFieldX : A - field mutFieldY : Nat - - data MutualData where - mutCtorX : MutualData - - data _ where - mutCtorX' : MutualData' - mutCtorY : MutualData - - mutualFun = id diff --git a/test/data/Indexer/Mutual.agda b/test/data/Indexer/Mutual.agda new file mode 100644 index 0000000..68f4f07 --- /dev/null +++ b/test/data/Indexer/Mutual.agda @@ -0,0 +1,41 @@ +module Mutual where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat + +module Forward where + interleaved mutual + record MutualRecord (A : Set) (n : Nat) : Set + data MutualData : Set + data MutualData' (A : Set) : Nat -> Set + mutualFun : MutualRecord MutualData zero -> MutualRecord MutualData zero + + record MutualRecord A m where + constructor makeMutualRecord + field + mutFieldX : A + field mutFieldY : Nat + + data MutualData where + mutCtorX : MutualData + + data _ where + mutCtorX' : MutualData' A zero + mutCtorY : MutualData + + mutualFun x = x + +module Backward where + interleaved mutual + data MutualData where + mutCtorX : MutualData + + data MutualData' where + mutCtorX' : MutualData' A zero + + data MutualData where + mutCtorY : MutualData + + data MutualData : Set + data MutualData' (A : Set) : Nat -> Set From 63ae4b639922fe61480a65eb1b1bd65b50a5b7b8 Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 18 Aug 2025 12:07:14 -0400 Subject: [PATCH 13/47] check for duplicate declarations --- agda-language-server.cabal | 1 + test/Test/Indexer/Invariants.hs | 4 ++- test/Test/Indexer/NoDuplicateDecl.hs | 46 ++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 test/Test/Indexer/NoDuplicateDecl.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 2356b16..3c6c8a5 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -181,6 +181,7 @@ test-suite als-test main-is: Test.hs other-modules: Test.Indexer.Invariants + Test.Indexer.NoDuplicateDecl Test.Indexer.NoMissing Test.Indexer.NoOverlap Test.LSP diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index 6884457..793067d 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -17,6 +17,7 @@ import qualified Language.LSP.Server as LSP import Monad (runServerM) import Server.Model.Monad (withAgdaLibFor) import System.FilePath (takeBaseName, ()) +import Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) @@ -70,5 +71,6 @@ tests = do testGroup "Invariants" [ testGroup "No reference overlap" ((\(name, file, _interface) -> testNoOverlap name file) <$> files), - testGroup "No missing references" ((\(name, file, interface) -> testNoMissing name file interface) <$> files) + testGroup "No missing references" ((\(name, file, interface) -> testNoMissing name file interface) <$> files), + testGroup "No duplicate declarations" ((\(name, file, _interface) -> testNoDuplicateDecl name file) <$> files) ] diff --git a/test/Test/Indexer/NoDuplicateDecl.hs b/test/Test/Indexer/NoDuplicateDecl.hs new file mode 100644 index 0000000..d09869f --- /dev/null +++ b/test/Test/Indexer/NoDuplicateDecl.hs @@ -0,0 +1,46 @@ +module Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) where + +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common.Pretty (Pretty, align, pretty, prettyList, prettyShow, text, vcat, (<+>)) +import Agda.Utils.Lens ((^.)) +import Control.Monad (forM_) +import Control.Monad.Writer.CPS (Writer, execWriter, tell) +import qualified Data.Map as Map +import Server.Model.AgdaFile (AgdaFile, agdaFileRefs) +import Server.Model.Symbol (Ref, RefKind (..), refKind) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase) + +data DuplicateDecl = DuplicateDecl + { ddName :: A.QName, + ddDecls :: [Ref] + } + +instance Pretty DuplicateDecl where + pretty dupDecl = + vcat $ + [text "Duplicate declarations for" <+> pretty (ddName dupDecl)] + <> fmap pretty (ddDecls dupDecl) + + prettyList = \case + [] -> text "No duplicate declarations" + [err] -> pretty err + errs -> align 5 $ (\err -> ("-", vcat [pretty err, text ""])) <$> errs + +checkDupDecls :: A.QName -> [Ref] -> Writer [DuplicateDecl] () +checkDupDecls name refs = do + let decls = filter (\ref -> refKind ref == Decl) refs + if length decls > 1 + then tell [DuplicateDecl name decls] + else return () + +testNoDuplicateDecl :: String -> AgdaFile -> TestTree +testNoDuplicateDecl name agdaFile = + testCase name $ do + let symbolRefs = (Map.toList $ agdaFile ^. agdaFileRefs) + let dupDecls = execWriter $ forM_ symbolRefs $ \(name, refs) -> + checkDupDecls name refs + + case dupDecls of + [] -> return () + _ -> assertFailure $ prettyShow dupDecls From da1b1d090eb0662a29fa31b97f2d44261491493d Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 18 Aug 2025 13:47:24 -0400 Subject: [PATCH 14/47] rename ServerM to ServerT --- src/Agda.hs | 14 +++++++------- src/Agda/Parser.hs | 4 ++-- src/Monad.hs | 23 +++++++++++++---------- src/Server.hs | 4 ++-- src/Server/Handler.hs | 6 +++--- src/Server/Model/Monad.hs | 10 +++++----- test/Test/Indexer/Invariants.hs | 4 ++-- test/Test/ModelMonad.hs | 6 +++--- 8 files changed, 37 insertions(+), 34 deletions(-) diff --git a/src/Agda.hs b/src/Agda.hs index 53f7330..ff053b1 100644 --- a/src/Agda.hs +++ b/src/Agda.hs @@ -99,7 +99,7 @@ import Agda.Interaction.JSONTop () getAgdaVersion :: String getAgdaVersion = versionWithCommitInfo -start :: ServerM IO () +start :: ServerT IO () start = do env <- ask @@ -136,7 +136,7 @@ start = do Left _err -> return () Right _val -> return () where - loop :: Env -> ServerM CommandM () + loop :: Env -> ServerT CommandM () loop env = do Bench.reset done <- Bench.billTo [] $ do @@ -163,7 +163,7 @@ start = do -- | Convert "CommandReq" to "CommandRes" -sendCommand :: MonadIO m => Value -> ServerM m Value +sendCommand :: MonadIO m => Value -> ServerT m Value sendCommand value = do -- JSON Value => Request => Response case fromJSON value of @@ -179,7 +179,7 @@ sendCommand value = do JSON.Success request -> toJSON <$> handleCommandReq request -handleCommandReq :: MonadIO m => CommandReq -> ServerM m CommandRes +handleCommandReq :: MonadIO m => CommandReq -> ServerT m CommandRes handleCommandReq CmdReqSYN = return $ CmdResACK Agda.getAgdaVersion versionNumber handleCommandReq (CmdReq cmd) = do case parseIOTCM cmd of @@ -194,7 +194,7 @@ handleCommandReq (CmdReq cmd) = do -------------------------------------------------------------------------------- getCommandLineOptions - :: (HasOptions m, MonadIO m) => ServerM m CommandLineOptions + :: (HasOptions m, MonadIO m) => ServerT m CommandLineOptions getCommandLineOptions = do -- command line options from ARGV argv <- asks (optRawAgdaOptions . envOptions) @@ -215,10 +215,10 @@ getCommandLineOptions = do -- | Run a TCM action in IO and throw away all of the errors -- TODO: handle the caught errors -runAgda :: MonadIO m => ServerM TCM a -> ServerM m (Either String a) +runAgda :: MonadIO m => ServerT TCM a -> ServerT m (Either String a) runAgda p = do env <- ask - let p' = runServerM env p + let p' = runServerT env p liftIO $ runTCMTop' ( (Right <$> p') diff --git a/src/Agda/Parser.hs b/src/Agda/Parser.hs index 6e52b91..10cfc07 100644 --- a/src/Agda/Parser.hs +++ b/src/Agda/Parser.hs @@ -15,12 +15,12 @@ import Data.Text (Text, unpack) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server (LspM) -import Monad (ServerM) +import Monad (ServerM, ServerT) import Options (Config) -------------------------------------------------------------------------------- -tokenAt :: LSP.Uri -> Text -> PositionWithoutFile -> ServerM (LspM Config) (Maybe (Token, Text)) +tokenAt :: LSP.Uri -> Text -> PositionWithoutFile -> ServerM (Maybe (Token, Text)) tokenAt uri source position = case LSP.uriToFilePath uri of Nothing -> return Nothing Just filepath -> do diff --git a/src/Monad.hs b/src/Monad.hs index ff0d346..24c091d 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -24,7 +24,8 @@ import Data.Text ) import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server - ( MonadLsp, + ( LspM, + MonadLsp, getConfig, ) import Options @@ -62,30 +63,32 @@ createInitEnv options = -------------------------------------------------------------------------------- -- | OUR monad -type ServerM m = ReaderT Env m +type ServerT m = ReaderT Env m -runServerM :: Env -> ServerM m a -> m a -runServerM = flip runReaderT +type ServerM = ServerT (LspM Config) + +runServerT :: Env -> ServerT m a -> m a +runServerT = flip runReaderT -------------------------------------------------------------------------------- -writeLog :: (Monad m, MonadIO m) => Text -> ServerM m () +writeLog :: (Monad m, MonadIO m) => Text -> ServerT m () writeLog msg = do chan <- asks envLogChan liftIO $ writeChan chan msg -writeLog' :: (Monad m, MonadIO m, Show a) => a -> ServerM m () +writeLog' :: (Monad m, MonadIO m, Show a) => a -> ServerT m () writeLog' x = do chan <- asks envLogChan liftIO $ writeChan chan $ pack $ show x -askModel :: (MonadIO m) => ServerM m Model +askModel :: (MonadIO m) => ServerT m Model askModel = do modelVar <- asks envModel liftIO $ readIORef modelVar -- | Provider -provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerM m () +provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerT m () provideCommand iotcm = do controller <- asks envCommandController liftIO $ CommandController.put controller iotcm @@ -94,12 +97,12 @@ provideCommand iotcm = do consumeCommand :: (Monad m, MonadIO m) => Env -> m IOTCM consumeCommand env = liftIO $ CommandController.take (envCommandController env) -waitUntilResponsesSent :: (Monad m, MonadIO m) => ServerM m () +waitUntilResponsesSent :: (Monad m, MonadIO m) => ServerT m () waitUntilResponsesSent = do controller <- asks envResponseController liftIO $ ResponseController.setCheckpointAndWait controller -signalCommandFinish :: (Monad m, MonadIO m) => ServerM m () +signalCommandFinish :: (Monad m, MonadIO m) => ServerT m () signalCommandFinish = do writeLog "[Command] Finished" -- send `ResponseEnd` diff --git a/src/Server.hs b/src/Server.hs index db8cfbb..e78166c 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -74,7 +74,7 @@ run options = do staticHandlers = const handlers, interpretHandler = \(ctxEnv, env) -> Iso - { forward = runLspT ctxEnv . runServerM env, + { forward = runLspT ctxEnv . runServerT env, backward = liftIO }, options = lspOptions @@ -104,7 +104,7 @@ syncOptions = } -- handlers of the LSP server -handlers :: Handlers (ServerM (LspM Config)) +handlers :: Handlers ServerM handlers = mconcat [ -- custom methods, not part of LSP diff --git a/src/Server/Handler.hs b/src/Server/Handler.hs index 05f33d0..1f3b64a 100644 --- a/src/Server/Handler.hs +++ b/src/Server/Handler.hs @@ -81,7 +81,7 @@ import Options ( Config initialiseCommandQueue :: IO CommandQueue initialiseCommandQueue = CommandQueue <$> newTChanIO <*> newTVarIO Nothing -runCommandM :: CommandM a -> ServerM (LspM Config) (Either String a) +runCommandM :: CommandM a -> ServerM (Either String a) runCommandM program = do env <- ask runAgda $ do @@ -100,7 +100,7 @@ runCommandM program = do lift $ evalStateT program commandState inferTypeOfText - :: FilePath -> Text -> ServerM (LspM Config) (Either String String) + :: FilePath -> Text -> ServerM (Either String String) inferTypeOfText filepath text = runCommandM $ do -- load first cmd_load' filepath [] True Imp.TypeCheck $ \_ -> return () @@ -114,7 +114,7 @@ inferTypeOfText filepath text = runCommandM $ do render <$> prettyATop typ -onHover :: LSP.Uri -> LSP.Position -> ServerM (LspM Config) (LSP.Hover LSP.|? LSP.Null) +onHover :: LSP.Uri -> LSP.Position -> ServerM (LSP.Hover LSP.|? LSP.Null) onHover uri pos = do result <- LSP.getVirtualFile (LSP.toNormalizedUri uri) case result of diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index a4068c3..ae66e85 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -32,7 +32,7 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP -import Monad (ServerM, askModel) +import Monad (ServerM, ServerT, askModel) import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) @@ -110,9 +110,9 @@ newtype WithAgdaLibT m a = WithAgdaLibT {unWithAgdaLibT :: ReaderT AgdaLib m a} runWithAgdaLibT :: AgdaLib -> WithAgdaLibT m a -> m a runWithAgdaLibT agdaLib = flip runReaderT agdaLib . unWithAgdaLibT -type WithAgdaLibM = WithAgdaLibT (ServerM (LspM Config)) +type WithAgdaLibM = WithAgdaLibT ServerM -withAgdaLibFor :: LSP.Uri -> WithAgdaLibM a -> ServerM (LspM Config) a +withAgdaLibFor :: LSP.Uri -> WithAgdaLibM a -> ServerM a withAgdaLibFor uri x = do let normUri = LSP.toNormalizedUri uri model <- askModel @@ -165,7 +165,7 @@ runWithAgdaFileT agdaLib agdaFile = let env = WithAgdaFileEnv agdaLib agdaFile in flip runReaderT env . unWithAgdaFileT -type WithAgdaFileM = WithAgdaFileT (ServerM (LspM Config)) +type WithAgdaFileM = WithAgdaFileT ServerM type HandlerWithAgdaFile m = LSP.TRequestMessage m -> @@ -177,7 +177,7 @@ withAgdaFile :: (LSP.HasTextDocument (LSP.MessageParams m) LSP.TextDocumentIdentifier) => LSP.SMethod m -> HandlerWithAgdaFile m -> - LSP.Handlers (ServerM (LspM Config)) + LSP.Handlers ServerM withAgdaFile m handler = LSP.requestHandler m $ \req responder -> do let uri = req ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index 793067d..a39ee71 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -14,7 +14,7 @@ import qualified Data.Map as Map import Indexer (indexFile, withAstFor) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Monad (runServerM) +import Monad (runServerT) import Server.Model.Monad (withAgdaLibFor) import System.FilePath (takeBaseName, ()) import Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) @@ -34,7 +34,7 @@ tests = do (file, interface) <- LSP.runLspT undefined $ do env <- TestData.getServerEnv model - runServerM env $ do + runServerT env $ do interface <- withAgdaLibFor uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index e96eb19..bfc9c09 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -16,7 +16,7 @@ import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap import qualified Language.LSP.Server as LSP -import Monad (Env (Env, envModel), ServerM, createInitEnv, runServerM) +import Monad (Env (Env, envModel), ServerT, createInitEnv, runServerT) import Options (Config, defaultOptions, initConfig) import qualified Server.CommandController as CommandController import Server.Model (Model) @@ -70,7 +70,7 @@ runHandler :: LSP.SMethod m -> LSP.TRequestMessage m -> Model -> - LSP.Handlers (ServerM (LSP.LspM Config)) -> + LSP.Handlers (ServerT (LSP.LspM Config)) -> IO (Either (LSP.TResponseError m) (LSP.MessageResult m)) runHandler m request model handlers = do resultRef <- newIORef Nothing @@ -80,7 +80,7 @@ runHandler m request model handlers = do LSP.runLspT undefined $ do env <- TestData.getServerEnv model - runServerM env $ handler request callback + runServerT env $ handler request callback Just result <- readIORef resultRef return result From 8235f2886724ca6a2f3a34f08e4dfaa9effdc152 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 14 Sep 2025 16:24:03 -0500 Subject: [PATCH 15/47] preliminary document symbol handler --- agda-language-server.cabal | 2 + src/Indexer/Monad.hs | 2 +- src/Server.hs | 2 + .../Handler/TextDocument/DocumentSymbol.hs | 46 +++++++++++++++++++ src/Server/Model/AgdaFile.hs | 25 +++++++++- src/Server/Model/Symbol.hs | 38 ++++++++++++++- 6 files changed, 111 insertions(+), 4 deletions(-) create mode 100644 src/Server/Handler/TextDocument/DocumentSymbol.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 3c6c8a5..f1eff71 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -78,6 +78,7 @@ library Server Server.CommandController Server.Handler + Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib @@ -221,6 +222,7 @@ test-suite als-test Server Server.CommandController Server.Handler + Server.Handler.TextDocument.DocumentSymbol Server.Model Server.Model.AgdaFile Server.Model.AgdaLib diff --git a/src/Indexer/Monad.hs b/src/Indexer/Monad.hs index ac16e94..543c6d0 100644 --- a/src/Indexer/Monad.hs +++ b/src/Indexer/Monad.hs @@ -127,7 +127,7 @@ tellSymbolInfo nameLike symbolKindLike typeLike = do symbolKind = toSymbolKind symbolKindLike type' <- lift $ toTypeString typeLike parent <- asks envParent - let symbolInfo = SymbolInfo symbolKind type' parent + let symbolInfo = SymbolInfo name symbolKind type' parent tellSymbolInfo' name symbolInfo tellRef' :: A.AmbiguousQName -> Ref -> IndexerM () diff --git a/src/Server.hs b/src/Server.hs index e78166c..a2c7b16 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -28,6 +28,7 @@ import Options import qualified Server.Handler as Handler import Switchboard (Switchboard, agdaCustomMethod) import qualified Switchboard +import Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) #if defined(wasm32_HOST_ARCH) import Agda.Utils.IO (catchIO) @@ -117,6 +118,7 @@ handlers = let TRequestMessage _ _ _ (HoverParams (TextDocumentIdentifier uri) pos _workDone) = req result <- Handler.onHover uri pos responder $ Right result, + documentSymbolHandler, -- -- syntax highlighting -- , requestHandler STextDocumentSemanticTokensFull $ \req responder -> do -- result <- Handler.onHighlight (req ^. (params . textDocument . uri)) diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs new file mode 100644 index 0000000..9199d90 --- /dev/null +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -0,0 +1,46 @@ +module Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) where + +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Utils.Maybe (fromMaybe, mapMaybe) +import Control.Monad (forM) +import Control.Monad.Trans (lift) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import Monad (ServerM) +import Server.Model.AgdaFile (AgdaFile, agdaFileSymbols, defNameRange, symbolByName, symbolsByParent) +import Server.Model.Monad (MonadAgdaFile (askAgdaFile), useAgdaFile, withAgdaFile) +import Server.Model.Symbol (SymbolInfo (symbolName), lspSymbolKind, symbolShortName, symbolType) + +documentSymbolHandler :: LSP.Handlers ServerM +documentSymbolHandler = withAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do + file <- askAgdaFile + let symbols = symbolsByParent file + let topLevelNames = fromMaybe [] $ Map.lookup Nothing symbols + let topLevelSymbols = mapMaybe (symbolByName file) topLevelNames + topLevelDocumentSymbols <- lift $ forM topLevelSymbols $ symbolToDocumentSymbol file symbols + responder $ Right $ LSP.InR $ LSP.InL topLevelDocumentSymbols + +symbolToDocumentSymbol :: AgdaFile -> Map (Maybe A.QName) [A.QName] -> SymbolInfo -> ServerM LSP.DocumentSymbol +symbolToDocumentSymbol file symbolsByParent symbol = do + let name = symbolName symbol + let range = defNameRange file name + let childrenNames = fromMaybe [] $ Map.lookup (Just name) symbolsByParent + let childrenSymbols = mapMaybe (symbolByName file) childrenNames + childrenDocumentSymbols <- + forM childrenSymbols $ + symbolToDocumentSymbol file symbolsByParent + return $ + LSP.DocumentSymbol + (symbolShortName symbol) + (Text.pack <$> symbolType symbol) + (lspSymbolKind symbol) + Nothing + Nothing + range + range + (Just childrenDocumentSymbols) diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index 2afad8d..8b04452 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -6,17 +6,24 @@ module Server.Model.AgdaFile insertSymbolInfo, insertRef, mergeSymbols, + symbolByName, + symbolsByParent, + defNameRange, ) where +import Agda.Position (toLspRange) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyAssign, prettyMap, text, vcat) +import Agda.Syntax.Position (getRange) import Agda.Utils.Lens (Lens', over, (<&>), (^.)) +import Data.Foldable (find) import Data.Function ((&)) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid (Endo (Endo, appEndo)) -import Server.Model.Symbol (Ref, SymbolInfo) +import qualified Language.LSP.Protocol.Types as LSP +import Server.Model.Symbol (Ref, SymbolInfo, refIsDef, refRange, symbolParent) data AgdaFile = AgdaFile { _agdaFileSymbols :: !(Map A.QName SymbolInfo), @@ -70,3 +77,19 @@ mergeSymbols old new file = Map.updateLookupWithKey (\_ _ -> Nothing) old refs in Map.alter (<> oldRefs) new refs' ) + +symbolByName :: AgdaFile -> A.QName -> Maybe SymbolInfo +symbolByName agdaFile symbolName = Map.lookup symbolName $ agdaFile ^. agdaFileSymbols + +symbolsByParent :: AgdaFile -> Map (Maybe A.QName) [A.QName] +symbolsByParent agdaFile = + let symbols = Map.toList $ agdaFile ^. agdaFileSymbols + in Map.fromListWith (++) $ (\(symbolName, symbol) -> (symbolParent symbol, [symbolName])) <$> symbols + +refsByName :: AgdaFile -> A.QName -> [Ref] +refsByName agdaFile name = Map.findWithDefault [] name $ agdaFile ^. agdaFileRefs + +defNameRange :: AgdaFile -> A.QName -> LSP.Range +defNameRange agdaFile name = + let defs = find refIsDef $ refsByName agdaFile name + in maybe (toLspRange $ getRange name) refRange defs diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index a45c7b2..291a540 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -1,14 +1,19 @@ module Server.Model.Symbol ( SymbolKind (..), SymbolInfo (..), + symbolShortName, + lspSymbolKind, RefKind (..), Ref (..), + refIsDef, ) where import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parensNonEmpty, pretty, pshow, text, (<+>)) +import Agda.Syntax.Common.Pretty (Doc, Pretty, comma, parensNonEmpty, pretty, prettyShow, pshow, text, (<+>)) import Control.Applicative ((<|>)) +import Data.Text (Text) +import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.More () @@ -37,8 +42,27 @@ instance Semigroup SymbolKind where Unknown <> k = k k <> _k = k +toLspSymbolKind :: SymbolKind -> LSP.SymbolKind +toLspSymbolKind = \case + Con -> LSP.SymbolKind_Constructor + CoCon -> LSP.SymbolKind_Constructor + Field -> LSP.SymbolKind_Field + PatternSyn -> LSP.SymbolKind_Function + GeneralizeVar -> LSP.SymbolKind_Variable + Macro -> LSP.SymbolKind_Function + Data -> LSP.SymbolKind_Enum + Record -> LSP.SymbolKind_Struct + Fun -> LSP.SymbolKind_Function + Axiom -> LSP.SymbolKind_Constant + Prim -> LSP.SymbolKind_Constant + Module -> LSP.SymbolKind_Module + Param -> LSP.SymbolKind_Variable + Local -> LSP.SymbolKind_Variable + Unknown -> LSP.SymbolKind_Variable + data SymbolInfo = SymbolInfo - { symbolKind :: !SymbolKind, + { symbolName :: !A.QName, + symbolKind :: !SymbolKind, symbolType :: !(Maybe String), symbolParent :: !(Maybe A.QName) } @@ -51,10 +75,17 @@ instance Pretty SymbolInfo where instance Semigroup SymbolInfo where new <> old = SymbolInfo + (symbolName new) (symbolKind old <> symbolKind new) (symbolType old <|> symbolType new) (symbolParent old <|> symbolParent new) +symbolShortName :: SymbolInfo -> Text +symbolShortName = Text.pack . prettyShow . symbolName + +lspSymbolKind :: SymbolInfo -> LSP.SymbolKind +lspSymbolKind = toLspSymbolKind . symbolKind + data RefKind = -- | The symbol is being declared. There should be at most one declaration -- for any given symbol (in correct Agda code). Roughly speaking, this is @@ -95,3 +126,6 @@ instance Pretty Ref where pretty ref = ((prettyAmbiguity ref <+> pretty (refKind ref)) <> comma) <+> pretty (refRange ref) + +refIsDef :: Ref -> Bool +refIsDef ref = refKind ref == Def From 800901d7603276b5d39f9a599e50e02af9bfe106 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 28 Sep 2025 15:24:50 -0500 Subject: [PATCH 16/47] respond to files opening, closing, and saving --- agda-language-server.cabal | 4 + src/Agda/Interaction/Imports/More.hs | 188 +++++++++++++++++- src/Agda/Interaction/Library/More.hs | 39 ++++ src/Language/LSP/Protocol/Types/Uri/More.hs | 14 ++ src/Monad.hs | 30 ++- src/Server.hs | 9 +- .../Handler/TextDocument/DocumentSymbol.hs | 4 +- .../Handler/TextDocument/FileManagement.hs | 47 +++++ src/Server/Model.hs | 32 ++- src/Server/Model/AgdaLib.hs | 71 ++++++- src/Server/Model/Monad.hs | 35 +++- test/Test/Indexer/Invariants.hs | 8 +- test/Test/ModelMonad.hs | 6 +- 13 files changed, 451 insertions(+), 36 deletions(-) create mode 100644 src/Agda/Interaction/Library/More.hs create mode 100644 src/Server/Handler/TextDocument/FileManagement.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index f1eff71..787db94 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -50,6 +50,7 @@ library Agda Agda.Convert Agda.Interaction.Imports.More + Agda.Interaction.Library.More Agda.IR Agda.Parser Agda.Position @@ -79,6 +80,7 @@ library Server.CommandController Server.Handler Server.Handler.TextDocument.DocumentSymbol + Server.Handler.TextDocument.FileManagement Server.Model Server.Model.AgdaFile Server.Model.AgdaLib @@ -194,6 +196,7 @@ test-suite als-test Agda Agda.Convert Agda.Interaction.Imports.More + Agda.Interaction.Library.More Agda.IR Agda.Parser Agda.Position @@ -223,6 +226,7 @@ test-suite als-test Server.CommandController Server.Handler Server.Handler.TextDocument.DocumentSymbol + Server.Handler.TextDocument.FileManagement Server.Model Server.Model.AgdaFile Server.Model.AgdaLib diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 37ac8d5..549625b 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -1,20 +1,157 @@ --- | This module reexports unexported functions +{-# LANGUAGE CPP #-} + module Agda.Interaction.Imports.More - ( setOptionsFromSourcePragmas, + ( parseVirtualSource, + setOptionsFromSourcePragmas, checkModuleName', ) where -import Agda.Interaction.FindFile (SourceFile, checkModuleName) -import Agda.Interaction.Imports (Source) +import Agda.Interaction.FindFile ( + SourceFile (SourceFile), + checkModuleName, +#if MIN_VERSION_Agda(2,8,0) + rootNameModule, +#else + moduleName, +#endif + ) +import Agda.Interaction.Imports (Source (..)) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Library (OptionsPragma (..), _libPragmas) import Agda.Syntax.Common (TopLevelModuleName') import qualified Agda.Syntax.Concrete as C -import Agda.Syntax.Position (Range) -import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) -import Agda.TypeChecking.Monad (Interface, TCM, checkAndSetOptionsFromPragma, setCurrentRange, setOptionsFromPragma, setTCLens, stPragmaOptions, useTC) +import Agda.Syntax.Parser ( + moduleParser, + parseFile, +#if MIN_VERSION_Agda(2,8,0) + parse, + moduleNameParser, +#else + PM, + runPMIO, +#endif + ) +import Agda.Syntax.Position + ( Range, + Range' (Range), + RangeFile, + beginningOfFile, + getRange, + intervalToRange, + mkRangeFile, + posToRange, + posToRange', + startPos, +#if MIN_VERSION_Agda(2,8,0) + rangeFromAbsolutePath, +#endif + ) +import Agda.Syntax.TopLevelModuleName ( + TopLevelModuleName, + RawTopLevelModuleName (..), +#if MIN_VERSION_Agda(2,8,0) + rawTopLevelModuleNameForModule, +#endif + ) +import Agda.TypeChecking.Monad + ( AbsolutePath, + Interface, + TCM, + checkAndSetOptionsFromPragma, + setCurrentRange, + setOptionsFromPragma, + setTCLens, + stPragmaOptions, + useTC, +#if MIN_VERSION_Agda(2,8,0) + runPM, + runPMDropWarnings, +#endif + ) +import qualified Agda.TypeChecking.Monad as TCM +import qualified Agda.TypeChecking.Monad.Benchmark as Bench +#if MIN_VERSION_Agda(2,8,0) +#else +import Agda.TypeChecking.Warnings (runPM) +#endif import Agda.Utils.Monad (bracket_) +#if MIN_VERSION_Agda(2,8,0) +import qualified Data.Text as T +#endif +import qualified Data.Text.Lazy as TL +import Control.Monad.Error.Class ( +#if MIN_VERSION_Agda(2,8,0) + catchError, +#else + throwError, +#endif + ) +#if MIN_VERSION_Agda(2,8,0) +import Agda.Utils.Singleton (singleton) +#else +import Agda.Syntax.Common.Pretty (pretty) +#endif + +-- | Parse a source file without talking to the filesystem +parseVirtualSource :: + -- | Logical path of the source file. Used in ranges, not filesystem access. + SourceFile -> + -- | Logical contents of the source file + TL.Text -> + TCM Imp.Source +parseVirtualSource sourceFile source = Bench.billTo [Bench.Parsing] $ do + f <- srcFilePath sourceFile + let rf0 = mkRangeFile f Nothing + setCurrentRange (beginningOfFile rf0) $ do + parsedModName0 <- moduleName f . fst . fst =<< do + runPMDropWarnings $ parseFile moduleParser rf0 $ TL.unpack source + + let rf = mkRangeFile f $ Just parsedModName0 + ((parsedMod, attrs), fileType) <- runPM $ parseFile moduleParser rf $ TL.unpack source + parsedModName <- moduleName f parsedMod + + -- TODO: handle libs properly + let libs = [] + + return + Source + { srcText = source, + srcFileType = fileType, + srcOrigin = sourceFile, + srcModule = parsedMod, + srcModuleName = parsedModName, + srcProjectLibs = libs, + srcAttributes = attrs + } + +srcFilePath :: SourceFile -> TCM AbsolutePath +#if MIN_VERSION_Agda(2,8,0) +srcFilePath = TCM.srcFilePath +#else +srcFilePath (SourceFile f) = return f +#endif + +#if MIN_VERSION_Agda(2,8,0) +-- beginningOfFile was generalized in Agda 2.8.0 to support the features we +-- need, so we just import it +#else +beginningOfFile :: RangeFile -> Range +beginningOfFile rf = posToRange (startPos $ Just rf) (startPos $ Just rf) +#endif + +#if MIN_VERSION_Agda(2,8,0) +-- runPMDropWarnings was introduced in Agda 2.8.0, so we just import it +#else +runPMDropWarnings :: PM a -> TCM a +runPMDropWarnings m = do + (res, _ws) <- runPMIO m + case res of + Left e -> throwError $ TCM.Exception (getRange e) (pretty e) + Right a -> return a +#endif + +-- Unexported Agda functions srcDefaultPragmas :: Imp.Source -> [OptionsPragma] srcDefaultPragmas src = map _libPragmas (Imp.srcProjectLibs src) @@ -48,3 +185,40 @@ setOptionsFromSourcePragmas checkOpts src = do checkModuleName' :: TopLevelModuleName' Range -> SourceFile -> TCM () checkModuleName' m f = setCurrentRange m $ checkModuleName m f Nothing + +#if MIN_VERSION_Agda(2,8,0) +-- moduleName was exported until 2.8.0 + +-- | Computes the module name of the top-level module in the given file. +-- +-- If no top-level module name is given, then an attempt is made to +-- use the file name as a module name. + +moduleName :: + AbsolutePath + -- ^ The path to the file. + -> C.Module + -- ^ The parsed module. + -> TCM TopLevelModuleName +moduleName file parsedModule = Bench.billTo [Bench.ModuleName] $ do + let defaultName = rootNameModule file + raw = rawTopLevelModuleNameForModule parsedModule + TCM.topLevelModuleName =<< if C.isNoName raw + then setCurrentRange (rangeFromAbsolutePath file) $ do + m <- runPM (fst <$> parse moduleNameParser defaultName) + `catchError` \_ -> + TCM.typeError $ TCM.InvalidFileName file TCM.DoesNotCorrespondToValidModuleName + case m of + C.Qual{} -> + TCM.typeError $ TCM.InvalidFileName file $ + TCM.RootNameModuleNotAQualifiedModuleName $ T.pack defaultName + C.QName{} -> + return $ RawTopLevelModuleName + { rawModuleNameRange = getRange m + , rawModuleNameParts = singleton (T.pack defaultName) + , rawModuleNameInferred = True + -- Andreas, 2025-06-21, issue #7953: + -- Remember we made up this module name to improve errors. + } + else return raw +#endif diff --git a/src/Agda/Interaction/Library/More.hs b/src/Agda/Interaction/Library/More.hs new file mode 100644 index 0000000..72f98c7 --- /dev/null +++ b/src/Agda/Interaction/Library/More.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} + +module Agda.Interaction.Library.More + ( tryRunLibM, +#if MIN_VERSION_Agda(2,8,0) +#else + runLibErrorIO, +#endif + ) +where + +import Agda.Interaction.Library (LibM) +import Agda.Interaction.Library.Base (LibErrorIO) +import Agda.Utils.Either (maybeRight) +import Agda.Utils.Null (Null (empty)) +import Control.Category ((>>>)) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Lazy (evalStateT) +import Control.Monad.Writer.Lazy (runWriterT) + +#if MIN_VERSION_Agda(2,8,0) +-- Unneeded in 2.8.0 due to API changes +#else +runLibErrorIO :: (MonadIO m) => LibErrorIO a -> m a +runLibErrorIO = + runWriterT + >>> flip evalStateT empty + >>> fmap fst + >>> liftIO +#endif + +tryRunLibM :: (MonadIO m) => LibM a -> m (Maybe a) +tryRunLibM = + runExceptT + >>> runWriterT + >>> flip evalStateT empty + >>> fmap (fst >>> maybeRight) + >>> liftIO diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index f8c1b69..dea62db 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -1,11 +1,16 @@ module Language.LSP.Protocol.Types.Uri.More ( getNormalizedUri, isUriAncestorOf, + uriToPossiblyInvalidAbsolutePath, ) where +import Agda.Utils.FileName (AbsolutePath (AbsolutePath), absolute) +import Agda.Utils.Maybe (fromMaybe) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import qualified Data.Text as Text +import Language.LSP.Protocol.Types (uriToFilePath) import qualified Language.LSP.Protocol.Types as LSP getNormalizedUri :: LSP.NormalizedUri -> Text @@ -18,3 +23,12 @@ getNormalizedUri = LSP.getUri . LSP.fromNormalizedUri isUriAncestorOf :: LSP.NormalizedUri -> LSP.NormalizedUri -> Bool isUriAncestorOf ancestor descendant = getNormalizedUri ancestor `Text.isPrefixOf` getNormalizedUri descendant + +uriToPossiblyInvalidAbsolutePath :: (MonadIO m) => LSP.NormalizedUri -> m AbsolutePath +uriToPossiblyInvalidAbsolutePath uri = do + case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of + Just path -> liftIO $ absolute path + Nothing -> return $ uriToInvalidAbsolutePath uri + +uriToInvalidAbsolutePath :: LSP.NormalizedUri -> AbsolutePath +uriToInvalidAbsolutePath = AbsolutePath . getNormalizedUri diff --git a/src/Monad.hs b/src/Monad.hs index 24c091d..b84c362 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -6,6 +6,8 @@ module Monad where import Agda.IR import Agda.Interaction.Base (IOTCM) +import Agda.Interaction.Library (findProjectRoot) +import Agda.Interaction.Library.More (tryRunLibM) import Agda.TypeChecking.Monad (TCMT) import Agda.Utils.Lens (Lens', (^.)) import Control.Concurrent @@ -17,7 +19,7 @@ import Data.IORef readIORef, writeIORef, ) -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Text ( Text, pack, @@ -33,9 +35,10 @@ import Server.CommandController (CommandController) import qualified Server.CommandController as CommandController import Server.Model (Model) import qualified Server.Model as Model -import Server.Model.AgdaLib (AgdaLib) +import Server.Model.AgdaLib (AgdaLib, agdaLibFromFs, initAgdaLib) import Server.ResponseController (ResponseController) import qualified Server.ResponseController as ResponseController +import System.FilePath (takeDirectory) -------------------------------------------------------------------------------- @@ -87,6 +90,29 @@ askModel = do modelVar <- asks envModel liftIO $ readIORef modelVar +modifyModel :: (MonadIO m) => (Model -> Model) -> ServerT m () +modifyModel f = do + modelVar <- asks envModel + liftIO $ modifyIORef' modelVar f + +-- | Find cached 'AgdaLib', or else make one from @.agda-lib@ files on the file +-- system, or else provide a default +findAgdaLib :: (MonadIO m) => LSP.NormalizedUri -> ServerT m AgdaLib +findAgdaLib uri = do + model <- askModel + case Model.getKnownAgdaLib uri model of + Just lib -> return lib + Nothing -> do + lib <- case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of + Just path -> do + lib <- agdaLibFromFs $ takeDirectory path + case lib of + Just lib -> return lib + Nothing -> initAgdaLib + Nothing -> initAgdaLib + modifyModel $ Model.withAgdaLib lib + return lib + -- | Provider provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerT m () provideCommand iotcm = do diff --git a/src/Server.hs b/src/Server.hs index a2c7b16..bbebd50 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -29,6 +29,7 @@ import qualified Server.Handler as Handler import Switchboard (Switchboard, agdaCustomMethod) import qualified Switchboard import Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) +import Server.Handler.TextDocument.FileManagement (didOpenHandler, didCloseHandler, didSaveHandler) #if defined(wasm32_HOST_ARCH) import Agda.Utils.IO (catchIO) @@ -129,11 +130,11 @@ handlers = -- `workspace/didChangeConfiguration` notificationHandler SMethod_WorkspaceDidChangeConfiguration $ \_notification -> return (), -- `textDocument/didOpen` - notificationHandler SMethod_TextDocumentDidOpen $ \_notification -> return (), + didOpenHandler, -- `textDocument/didClose` - notificationHandler SMethod_TextDocumentDidClose $ \_notification -> return (), + didCloseHandler, -- `textDocument/didChange` notificationHandler SMethod_TextDocumentDidChange $ \_notification -> return (), -- `textDocument/didSave` - notificationHandler SMethod_TextDocumentDidSave $ \_notification -> return () - ] \ No newline at end of file + didSaveHandler + ] diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs index 9199d90..6e1b451 100644 --- a/src/Server/Handler/TextDocument/DocumentSymbol.hs +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -13,11 +13,11 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM) import Server.Model.AgdaFile (AgdaFile, agdaFileSymbols, defNameRange, symbolByName, symbolsByParent) -import Server.Model.Monad (MonadAgdaFile (askAgdaFile), useAgdaFile, withAgdaFile) +import Server.Model.Monad (MonadAgdaFile (askAgdaFile), requestHandlerWithAgdaFile, useAgdaFile) import Server.Model.Symbol (SymbolInfo (symbolName), lspSymbolKind, symbolShortName, symbolType) documentSymbolHandler :: LSP.Handlers ServerM -documentSymbolHandler = withAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do +documentSymbolHandler = requestHandlerWithAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do file <- askAgdaFile let symbols = symbolsByParent file let topLevelNames = fromMaybe [] $ Map.lookup Nothing symbols diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs new file mode 100644 index 0000000..2dda162 --- /dev/null +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -0,0 +1,47 @@ +module Server.Handler.TextDocument.FileManagement + ( didOpenHandler, + didCloseHandler, + didSaveHandler, + ) +where + +import Agda.Interaction.FindFile (SourceFile (SourceFile)) +import qualified Agda.Interaction.Imports.More as Imp +import Agda.TypeChecking.Monad (MonadTCM (liftTCM)) +import Agda.Utils.Lens ((^.)) +import Control.Monad.Trans (lift) +import Data.Strict (Strict (toLazy)) +import Indexer (indexFile) +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as VFS +import qualified Language.LSP.VFS as VFS +import Monad (ServerM, modifyModel) +import qualified Server.Model as Model +import Server.Model.Monad (notificationHandlerWithAgdaLib) + +didOpenHandler :: LSP.Handlers ServerM +didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen $ \notification uri -> do + sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri + let sourceText = toLazy $ notification ^. LSP.params . LSP.textDocument . LSP.text + src <- liftTCM $ Imp.parseVirtualSource sourceFile sourceText + agdaFile <- indexFile src + lift $ modifyModel $ Model.setAgdaFile uri agdaFile + +didCloseHandler :: LSP.Handlers ServerM +didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClose $ \notification uri -> do + lift $ modifyModel $ Model.deleteAgdaFile uri + +didSaveHandler :: LSP.Handlers ServerM +didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \notification uri -> do + sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri + virtualFile <- lift $ VFS.getVirtualFile uri + case virtualFile of + Nothing -> return () + Just virtualFile -> do + let sourceText = toLazy $ VFS.virtualFileText virtualFile + src <- liftTCM $ Imp.parseVirtualSource sourceFile sourceText + agdaFile <- indexFile src + lift $ modifyModel $ Model.setAgdaFile uri agdaFile diff --git a/src/Server/Model.hs b/src/Server/Model.hs index cc11217..8ed9001 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -1,7 +1,19 @@ -module Server.Model (Model (Model), empty, getKnownAgdaLib, getAgdaLib, getAgdaFile) where +module Server.Model + ( Model (Model), + empty, + getKnownAgdaLib, + getAgdaLib, + withAgdaLib, + getAgdaFile, + setAgdaFile, + deleteAgdaFile, + ) +where +import Agda.Utils.Lens (Lens', over) import Control.Monad.IO.Class (MonadIO) import Data.Foldable (find) +import Data.Functor ((<&>)) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.LSP.Protocol.Types as LSP @@ -16,11 +28,29 @@ data Model = Model empty :: Model empty = Model [] Map.empty +agdaLibs :: Lens' Model [AgdaLib] +agdaLibs f a = f (_modelAgdaLibs a) <&> \x -> a {_modelAgdaLibs = x} + +agdaFiles :: Lens' Model (Map LSP.NormalizedUri AgdaFile) +agdaFiles f a = f (_modelAgdaFiles a) <&> \x -> a {_modelAgdaFiles = x} + getKnownAgdaLib :: LSP.NormalizedUri -> Model -> Maybe AgdaLib getKnownAgdaLib uri = find (`isAgdaLibForUri` uri) . _modelAgdaLibs +-- | Get the Agda library for the given URI if known. Otherwise, get a generic +-- default Agda library. getAgdaLib :: (MonadIO m) => LSP.NormalizedUri -> Model -> m AgdaLib getAgdaLib uri = maybe initAgdaLib return . getKnownAgdaLib uri +-- | Add an 'AgdaLib' to the model +withAgdaLib :: AgdaLib -> Model -> Model +withAgdaLib lib model = model {_modelAgdaLibs = lib : _modelAgdaLibs model} + getAgdaFile :: LSP.NormalizedUri -> Model -> Maybe AgdaFile getAgdaFile uri = Map.lookup uri . _modelAgdaFiles + +setAgdaFile :: LSP.NormalizedUri -> AgdaFile -> Model -> Model +setAgdaFile uri agdaFile = over agdaFiles $ Map.insert uri agdaFile + +deleteAgdaFile :: LSP.NormalizedUri -> Model -> Model +deleteAgdaFile uri = over agdaFiles $ Map.delete uri diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index 24b5df2..aaa9b6b 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Server.Model.AgdaLib ( AgdaLib (AgdaLib), initAgdaLib, @@ -5,12 +7,30 @@ module Server.Model.AgdaLib agdaLibTcStateRef, agdaLibTcEnv, isAgdaLibForUri, + agdaLibFromFs, ) where +import Agda.Interaction.Library ( + AgdaLibFile (_libIncludes), + findProjectRoot, +#if MIN_VERSION_Agda(2,8,0) + getAgdaLibFile, +#else + getAgdaLibFiles', +#endif + ) +import Agda.Interaction.Library.More ( + tryRunLibM, +#if MIN_VERSION_Agda(2,8,0) +#else + runLibErrorIO, +#endif + ) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (IORef, newIORef) import Agda.Utils.Lens (Lens', (<&>), (^.)) +import Agda.Utils.Maybe (listToMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Map (Map) import qualified Language.LSP.Protocol.Types as LSP @@ -23,11 +43,19 @@ data AgdaLib = AgdaLib _agdaLibTcEnv :: !TCM.TCEnv } -initAgdaLib :: (MonadIO m) => m AgdaLib -initAgdaLib = do - tcStateRef <- liftIO $ newIORef TCM.initState +initAgdaLibWithIncludes :: (MonadIO m) => [LSP.NormalizedUri] -> m AgdaLib +initAgdaLibWithIncludes includes = do +#if MIN_VERSION_Agda(2,8,0) + tcState <- liftIO TCM.initStateIO +#else + let tcState = TCM.initState +#endif + tcStateRef <- liftIO $ newIORef tcState let tcEnv = TCM.initEnv - return $ AgdaLib [] tcStateRef tcEnv + return $ AgdaLib includes tcStateRef tcEnv + +initAgdaLib :: (MonadIO m) => m AgdaLib +initAgdaLib = initAgdaLibWithIncludes [] agdaLibIncludes :: Lens' AgdaLib [LSP.NormalizedUri] agdaLibIncludes f a = f (_agdaLibIncludes a) <&> \x -> a {_agdaLibIncludes = x} @@ -40,3 +68,38 @@ agdaLibTcEnv f a = f (_agdaLibTcEnv a) <&> \x -> a {_agdaLibTcEnv = x} isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) + +-- | Get an 'AgdaLib' from @.agda-lib@ files on the filesystem. These files are +-- searched for by traversing parent directories until one is found. +agdaLibFromFs :: + (MonadIO m) => + -- | Directory to start the search from + FilePath -> + m (Maybe AgdaLib) +agdaLibFromFs path = do + root <- tryRunLibM $ findProjectRoot path + case root of + Just (Just root) -> do + libFile <- tryGetLibFileFromRootPath root + case libFile of + Just libFile -> Just <$> agdaLibFromFile libFile + Nothing -> return Nothing + _noRoot -> return Nothing + +tryGetLibFileFromRootPath :: (MonadIO m) => FilePath -> m (Maybe AgdaLibFile) +#if MIN_VERSION_Agda(2,8,0) +tryGetLibFileFromRootPath root = do + maybeLibFiles <- tryRunLibM $ getAgdaLibFile root + case maybeLibFiles of + Just (libFile:_) -> return $ Just libFile + _ -> return Nothing +#else +tryGetLibFileFromRootPath root = do + libFiles <- runLibErrorIO $ getAgdaLibFiles' root + return $ listToMaybe libFiles +#endif + +agdaLibFromFile :: (MonadIO m) => AgdaLibFile -> m AgdaLib +agdaLibFromFile libFile = do + let includes = LSP.toNormalizedUri . LSP.filePathToUri <$> _libIncludes libFile + initAgdaLibWithIncludes includes diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index ae66e85..22a00cc 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -10,11 +10,12 @@ module Server.Model.Monad ( MonadAgdaLib (..), useAgdaLib, + notificationHandlerWithAgdaLib, MonadAgdaFile (..), useAgdaFile, - withAgdaFile, + requestHandlerWithAgdaFile, WithAgdaLibM, - withAgdaLibFor, + runWithAgdaLib, ) where @@ -32,7 +33,7 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP -import Monad (ServerM, ServerT, askModel) +import Monad (ServerM, ServerT, askModel, findAgdaLib) import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) @@ -112,13 +113,29 @@ runWithAgdaLibT agdaLib = flip runReaderT agdaLib . unWithAgdaLibT type WithAgdaLibM = WithAgdaLibT ServerM -withAgdaLibFor :: LSP.Uri -> WithAgdaLibM a -> ServerM a -withAgdaLibFor uri x = do +runWithAgdaLib :: LSP.Uri -> WithAgdaLibM a -> ServerM a +runWithAgdaLib uri x = do let normUri = LSP.toNormalizedUri uri model <- askModel agdaLib <- Model.getAgdaLib normUri model runWithAgdaLibT agdaLib x +type NotificationHandlerWithAgdaLib m = + LSP.TNotificationMessage m -> LSP.NormalizedUri -> WithAgdaLibM () + +notificationHandlerWithAgdaLib :: + forall (m :: LSP.Method LSP.ClientToServer LSP.Notification) textdoc. + (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => + LSP.SMethod m -> + NotificationHandlerWithAgdaLib m -> + LSP.Handlers ServerM +notificationHandlerWithAgdaLib m handler = LSP.notificationHandler m $ \notification -> do + let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + normUri = LSP.toNormalizedUri uri + + agdaLib <- findAgdaLib normUri + runWithAgdaLibT agdaLib $ handler notification normUri + instance (MonadIO m) => MonadAgdaLib (WithAgdaLibT m) where askAgdaLib = WithAgdaLibT ask localAgdaLib f = WithAgdaLibT . local f . unWithAgdaLibT @@ -167,18 +184,18 @@ runWithAgdaFileT agdaLib agdaFile = type WithAgdaFileM = WithAgdaFileT ServerM -type HandlerWithAgdaFile m = +type RequestHandlerWithAgdaFile m = LSP.TRequestMessage m -> (Either (LSP.TResponseError m) (LSP.MessageResult m) -> WithAgdaFileM ()) -> WithAgdaFileM () -withAgdaFile :: +requestHandlerWithAgdaFile :: forall (m :: LSP.Method LSP.ClientToServer LSP.Request). (LSP.HasTextDocument (LSP.MessageParams m) LSP.TextDocumentIdentifier) => LSP.SMethod m -> - HandlerWithAgdaFile m -> + RequestHandlerWithAgdaFile m -> LSP.Handlers ServerM -withAgdaFile m handler = LSP.requestHandler m $ \req responder -> do +requestHandlerWithAgdaFile m handler = LSP.requestHandler m $ \req responder -> do let uri = req ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index a39ee71..0a80b52 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -15,7 +15,7 @@ import Indexer (indexFile, withAstFor) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerT) -import Server.Model.Monad (withAgdaLibFor) +import Server.Model.Monad (runWithAgdaLib) import System.FilePath (takeBaseName, ()) import Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) import Test.Indexer.NoMissing (testNoMissing) @@ -35,7 +35,7 @@ tests = do (file, interface) <- LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - interface <- withAgdaLibFor uri $ do + interface <- runWithAgdaLib uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath let srcFile = SourceFile absInPath @@ -45,7 +45,7 @@ tests = do checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src return $ Imp.crInterface checkResult - ast <- withAgdaLibFor uri $ do + ast <- runWithAgdaLib uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath let srcFile = SourceFile absInPath @@ -56,7 +56,7 @@ tests = do -- Write the AST to a file for debugging purposes liftIO $ writeFile ("test/data/AST" testName) $ prettyShow $ topLevelDecls ast - withAgdaLibFor uri $ do + runWithAgdaLib uri $ do TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions absInPath <- liftIO $ absolute inPath let srcFile = SourceFile absInPath diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index bfc9c09..dbc310e 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -21,7 +21,7 @@ import Options (Config, defaultOptions, initConfig) import qualified Server.CommandController as CommandController import Server.Model (Model) import Server.Model.AgdaLib (agdaLibIncludes) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib), withAgdaFile) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib), requestHandlerWithAgdaFile) import qualified Server.ResponseController as ResponseController import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) @@ -37,7 +37,7 @@ tests = let method = LSP.SMethod_TextDocumentDocumentSymbol message = TestData.documentSymbolMessage TestData.fileUri1 - let handlers = withAgdaFile method $ \req responder -> do + let handlers = requestHandlerWithAgdaFile method $ \req responder -> do agdaLib <- askAgdaLib liftIO $ length (agdaLib ^. agdaLibIncludes) @?= 3 responder $ Right $ LSP.InL [] @@ -52,7 +52,7 @@ tests = let method = LSP.SMethod_TextDocumentDocumentSymbol message = TestData.documentSymbolMessage TestData.fakeUri - let handlers = withAgdaFile method $ \req responder -> do + let handlers = requestHandlerWithAgdaFile method $ \req responder -> do responder $ Right $ LSP.InL [] model <- TestData.getModel From a6754e18ac262b8d1f6da5e4ca9e5eea3c6dd43a Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 26 Oct 2025 19:16:16 -0500 Subject: [PATCH 17/47] refactor handlers, handle errors --- agda-language-server.cabal | 2 + src/Monad.hs | 10 ++ .../Handler/TextDocument/DocumentSymbol.hs | 3 +- .../Handler/TextDocument/FileManagement.hs | 8 +- src/Server/Model/Handler.hs | 93 +++++++++++++++++++ src/Server/Model/Monad.hs | 56 +++-------- test/Test/ModelMonad.hs | 3 +- 7 files changed, 124 insertions(+), 51 deletions(-) create mode 100644 src/Server/Model/Handler.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 787db94..86bd57d 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -84,6 +84,7 @@ library Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.Handler Server.Model.Monad Server.Model.Symbol Server.ResponseController @@ -230,6 +231,7 @@ test-suite als-test Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.Handler Server.Model.Monad Server.Model.Symbol Server.ResponseController diff --git a/src/Monad.hs b/src/Monad.hs index b84c362..e837de0 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -9,8 +9,11 @@ import Agda.Interaction.Base (IOTCM) import Agda.Interaction.Library (findProjectRoot) import Agda.Interaction.Library.More (tryRunLibM) import Agda.TypeChecking.Monad (TCMT) +import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.Lens (Lens', (^.)) import Control.Concurrent +import Control.Exception (Exception) +import qualified Control.Exception as E import Control.Monad.Reader import Data.IORef ( IORef, @@ -30,6 +33,7 @@ import Language.LSP.Server MonadLsp, getConfig, ) +import qualified Language.LSP.Server as LSP import Options import Server.CommandController (CommandController) import qualified Server.CommandController as CommandController @@ -113,6 +117,12 @@ findAgdaLib uri = do modifyModel $ Model.withAgdaLib lib return lib +catchTCError :: ServerM a -> (TCM.TCErr -> ServerM a) -> ServerM a +catchTCError m h = + ReaderT $ \env -> LSP.LspT $ ReaderT $ \lspEnv -> + LSP.runLspT lspEnv (runServerT env m) + `E.catch` \err -> LSP.runLspT lspEnv (runServerT env (h err)) + -- | Provider provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerT m () provideCommand iotcm = do diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs index 6e1b451..bd5b695 100644 --- a/src/Server/Handler/TextDocument/DocumentSymbol.hs +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -13,7 +13,8 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM) import Server.Model.AgdaFile (AgdaFile, agdaFileSymbols, defNameRange, symbolByName, symbolsByParent) -import Server.Model.Monad (MonadAgdaFile (askAgdaFile), requestHandlerWithAgdaFile, useAgdaFile) +import Server.Model.Handler (requestHandlerWithAgdaFile) +import Server.Model.Monad (MonadAgdaFile (askAgdaFile), useAgdaFile) import Server.Model.Symbol (SymbolInfo (symbolName), lspSymbolKind, symbolShortName, symbolType) documentSymbolHandler :: LSP.Handlers ServerM diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index 2dda162..a43d8f9 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -20,10 +20,10 @@ import qualified Language.LSP.Server as VFS import qualified Language.LSP.VFS as VFS import Monad (ServerM, modifyModel) import qualified Server.Model as Model -import Server.Model.Monad (notificationHandlerWithAgdaLib) +import Server.Model.Handler (notificationHandlerWithAgdaLib) didOpenHandler :: LSP.Handlers ServerM -didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen $ \notification uri -> do +didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen $ \uri notification -> do sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri let sourceText = toLazy $ notification ^. LSP.params . LSP.textDocument . LSP.text src <- liftTCM $ Imp.parseVirtualSource sourceFile sourceText @@ -31,11 +31,11 @@ didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen lift $ modifyModel $ Model.setAgdaFile uri agdaFile didCloseHandler :: LSP.Handlers ServerM -didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClose $ \notification uri -> do +didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClose $ \uri notification -> do lift $ modifyModel $ Model.deleteAgdaFile uri didSaveHandler :: LSP.Handlers ServerM -didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \notification uri -> do +didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \uri notification -> do sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri virtualFile <- lift $ VFS.getVirtualFile uri case virtualFile of diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs new file mode 100644 index 0000000..bef30ec --- /dev/null +++ b/src/Server/Model/Handler.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Server.Model.Handler + ( notificationHandlerWithAgdaLib, + requestHandlerWithAgdaFile, + ) +where + +import Agda.Syntax.Common (WithHiding (whHiding)) +import Agda.Syntax.Common.Pretty (prettyShow) +import qualified Agda.TypeChecking.Monad as TCM +import qualified Agda.TypeChecking.Pretty as TCM +import Agda.Utils.Either (fromRightM) +import Agda.Utils.Lens ((^.)) +import Control.Monad.Trans (MonadTrans, lift) +import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Lens as LSP +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Message as Lsp +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import Monad (ServerM, askModel, catchTCError, findAgdaLib) +import qualified Server.Model as Model +import Server.Model.Monad (WithAgdaFileM, WithAgdaLibM, runWithAgdaFileT, runWithAgdaLibT) + +tryTC :: ServerM a -> ServerM (Either TCM.TCErr a) +tryTC handler = (Right <$> handler) `catchTCError` (return . Left) + +-------------------------------------------------------------------------------- + +type NotificationHandlerWithAgdaLib + (m :: LSP.Method LSP.ClientToServer LSP.Notification) = + LSP.NormalizedUri -> LSP.TNotificationMessage m -> WithAgdaLibM () + +notificationHandlerWithAgdaLib :: + (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => + LSP.SMethod m -> + NotificationHandlerWithAgdaLib m -> + LSP.Handlers ServerM +notificationHandlerWithAgdaLib m handlerWithAgdaLib = LSP.notificationHandler m $ \notification -> do + let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + normUri = LSP.toNormalizedUri uri + agdaLib <- findAgdaLib normUri + + let notificationHandler = runWithAgdaLibT agdaLib . handlerWithAgdaLib normUri + let handler = tryTC $ notificationHandler notification + + let onErr = \err -> runWithAgdaLibT agdaLib $ do + message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) + lift $ LSP.sendNotification LSP.SMethod_WindowShowMessage $ LSP.ShowMessageParams LSP.MessageType_Error message + + fromRightM onErr handler + +-------------------------------------------------------------------------------- + +type RequestCallbackWithAgdaFile + (m :: LSP.Method LSP.ClientToServer LSP.Request) = + Either (LSP.TResponseError m) (LSP.MessageResult m) -> WithAgdaFileM () + +type RequestHandlerWithAgdaFile + (m :: LSP.Method LSP.ClientToServer LSP.Request) = + LSP.TRequestMessage m -> + RequestCallbackWithAgdaFile m -> + WithAgdaFileM () + +requestHandlerWithAgdaFile :: + (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => + LSP.SMethod m -> + RequestHandlerWithAgdaFile m -> + LSP.Handlers ServerM +requestHandlerWithAgdaFile m handlerWithAgdaFile = LSP.requestHandler m $ \req responder -> do + let uri = req ^. LSP.params . LSP.textDocument . LSP.uri + normUri = LSP.toNormalizedUri uri + + model <- askModel + case Model.getAgdaFile normUri model of + Nothing -> do + let message = "Request for unknown Agda file at URI: " <> LSP.getUri uri + responder $ Left $ LSP.TResponseError (LSP.InR LSP.ErrorCodes_InvalidParams) message Nothing + Just agdaFile -> do + agdaLib <- Model.getAgdaLib normUri model + let responderWithAgdaFile = lift . responder + let handler = tryTC $ runWithAgdaFileT agdaLib agdaFile $ handlerWithAgdaFile req responderWithAgdaFile + + let onErr = \err -> runWithAgdaFileT agdaLib agdaFile $ do + message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) + lift $ responder $ Left $ LSP.TResponseError (LSP.InL LSP.LSPErrorCodes_RequestFailed) message Nothing + + fromRightM onErr handler diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index 22a00cc..ba2e8b0 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -10,30 +10,37 @@ module Server.Model.Monad ( MonadAgdaLib (..), useAgdaLib, - notificationHandlerWithAgdaLib, MonadAgdaFile (..), useAgdaFile, - requestHandlerWithAgdaFile, + WithAgdaLibT, + runWithAgdaLibT, WithAgdaLibM, runWithAgdaLib, + WithAgdaFileT, + runWithAgdaFileT, + WithAgdaFileM, ) where import Agda.Interaction.Options (CommandLineOptions (optPragmaOptions), PragmaOptions) -import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv, TCM, TCMT (..), TCState (stPersistentState), modifyTCLens, setTCLens, stPragmaOptions, useTC) +import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv, TCM, TCMT (..), TCState (stPersistentState), catchError_, modifyTCLens, setTCLens, stPragmaOptions, useTC) +import qualified Agda.TypeChecking.Monad as TCM +import qualified Agda.TypeChecking.Pretty as TCM import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) import Agda.Utils.Lens (Lens', locally, over, use, view, (<&>), (^.)) import Agda.Utils.Monad (bracket_) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask, asks) import Control.Monad.Trans (MonadTrans, lift) +import qualified Data.Text as Text import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP -import Monad (ServerM, ServerT, askModel, findAgdaLib) +import Monad (ServerM, ServerT, askModel, catchTCError, findAgdaLib) import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) @@ -120,22 +127,6 @@ runWithAgdaLib uri x = do agdaLib <- Model.getAgdaLib normUri model runWithAgdaLibT agdaLib x -type NotificationHandlerWithAgdaLib m = - LSP.TNotificationMessage m -> LSP.NormalizedUri -> WithAgdaLibM () - -notificationHandlerWithAgdaLib :: - forall (m :: LSP.Method LSP.ClientToServer LSP.Notification) textdoc. - (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => - LSP.SMethod m -> - NotificationHandlerWithAgdaLib m -> - LSP.Handlers ServerM -notificationHandlerWithAgdaLib m handler = LSP.notificationHandler m $ \notification -> do - let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri - normUri = LSP.toNormalizedUri uri - - agdaLib <- findAgdaLib normUri - runWithAgdaLibT agdaLib $ handler notification normUri - instance (MonadIO m) => MonadAgdaLib (WithAgdaLibT m) where askAgdaLib = WithAgdaLibT ask localAgdaLib f = WithAgdaLibT . local f . unWithAgdaLibT @@ -184,31 +175,6 @@ runWithAgdaFileT agdaLib agdaFile = type WithAgdaFileM = WithAgdaFileT ServerM -type RequestHandlerWithAgdaFile m = - LSP.TRequestMessage m -> - (Either (LSP.TResponseError m) (LSP.MessageResult m) -> WithAgdaFileM ()) -> - WithAgdaFileM () - -requestHandlerWithAgdaFile :: - forall (m :: LSP.Method LSP.ClientToServer LSP.Request). - (LSP.HasTextDocument (LSP.MessageParams m) LSP.TextDocumentIdentifier) => - LSP.SMethod m -> - RequestHandlerWithAgdaFile m -> - LSP.Handlers ServerM -requestHandlerWithAgdaFile m handler = LSP.requestHandler m $ \req responder -> do - let uri = req ^. LSP.params . LSP.textDocument . LSP.uri - normUri = LSP.toNormalizedUri uri - - model <- askModel - case Model.getAgdaFile normUri model of - Nothing -> do - let message = "Request for unknown Agda file at URI: " <> LSP.getUri uri - responder $ Left $ LSP.TResponseError (LSP.InR LSP.ErrorCodes_InvalidParams) message Nothing - Just agdaFile -> do - agdaLib <- Model.getAgdaLib normUri model - let responder' = lift . responder - runWithAgdaFileT agdaLib agdaFile $ handler req responder' - instance (MonadIO m) => MonadAgdaLib (WithAgdaFileT m) where askAgdaLib = WithAgdaFileT $ view withAgdaFileEnvAgdaLib localAgdaLib f = WithAgdaFileT . locally withAgdaFileEnvAgdaLib f . unWithAgdaFileT diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index dbc310e..13bc440 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -21,7 +21,8 @@ import Options (Config, defaultOptions, initConfig) import qualified Server.CommandController as CommandController import Server.Model (Model) import Server.Model.AgdaLib (agdaLibIncludes) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib), requestHandlerWithAgdaFile) +import Server.Model.Handler (requestHandlerWithAgdaFile) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) import qualified Server.ResponseController as ResponseController import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) From 269caa4eb526f73b2551dbc9d006c75d291db667 Mon Sep 17 00:00:00 2001 From: nvarner Date: Thu, 30 Oct 2025 19:50:07 -0500 Subject: [PATCH 18/47] use unqualified symbol name --- src/Server/Model/Symbol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index 291a540..e178690 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -81,7 +81,7 @@ instance Semigroup SymbolInfo where (symbolParent old <|> symbolParent new) symbolShortName :: SymbolInfo -> Text -symbolShortName = Text.pack . prettyShow . symbolName +symbolShortName = Text.pack . prettyShow . A.qnameName . symbolName lspSymbolKind :: SymbolInfo -> LSP.SymbolKind lspSymbolKind = toLspSymbolKind . symbolKind From 001d043fca4ecc611d9637d5bad5bcc0393bbe82 Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 31 Oct 2025 20:15:48 -0500 Subject: [PATCH 19/47] no anonymous function symbols --- agda-language-server.cabal | 1 + src/Indexer/Indexer.hs | 34 +++++++++------ test/Test.hs | 4 +- test/Test/Indexer/Invariants.hs | 39 +---------------- test/Test/Indexer/NoAnonFunSymbol.hs | 25 +++++++++++ test/TestData.hs | 64 +++++++++++++++++++++++++++- test/data/AnonFun.agda | 4 ++ 7 files changed, 117 insertions(+), 54 deletions(-) create mode 100644 test/Test/Indexer/NoAnonFunSymbol.hs create mode 100644 test/data/AnonFun.agda diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 86bd57d..a64e3c5 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -185,6 +185,7 @@ test-suite als-test main-is: Test.hs other-modules: Test.Indexer.Invariants + Test.Indexer.NoAnonFunSymbol Test.Indexer.NoDuplicateDecl Test.Indexer.NoMissing Test.Indexer.NoOverlap diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 5394729..e900bb8 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -22,6 +22,7 @@ import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe (whenJust) import Agda.Utils.Monad (when) import Data.Foldable (forM_, traverse_) +import Data.Functor.Compose (Compose (Compose, getCompose)) import qualified Data.Set as Set import Data.Void (absurd) import Indexer.Monad @@ -100,7 +101,7 @@ instance Indexable A.Declaration where A.FunDef _defInfo name clauses -> withBindingKind DefBinding $ do -- function declarations are captured by the `Axiom` case withParent name $ do - index clauses + index $ WithLHSNaming LHSNamed <$> clauses A.DataSig defInfo _erased name genTel type' -> withBindingKind DeclBinding $ do tellDecl name Data type' @@ -200,7 +201,7 @@ instance Indexable A.Expr where return () A.ExtendedLam _exprInfo defInfo _erased _generatedFn clauses -> do index defInfo - index clauses + index $ WithLHSNaming LHSAnonymous <$> clauses A.Pi _exprInfo tel type' -> do index tel index type' @@ -335,28 +336,33 @@ instance Indexable A.WhereDeclarations where A.WhereDecls Nothing _ decl -> index decl -instance (Indexable a) => Indexable (A.LHSCore' a) where - index core = case core of +data LHSNaming = LHSNamed | LHSAnonymous deriving (Eq) + +data WithLHSNaming a = WithLHSNaming LHSNaming a + +instance (Indexable a) => Indexable (WithLHSNaming (A.LHSCore' a)) where + index (WithLHSNaming lhsNaming core) = case core of A.LHSHead name pats -> do - tellDef name Param UnknownType + when (lhsNaming == LHSNamed) $ + tellDef name Param UnknownType indexNamedArgs name pats A.LHSProj destructor focus pats -> do tellUsage destructor -- TODO: what does the named arg in `focus` mean? - indexNamedArgs destructor [focus] + indexNamedArgs destructor [getCompose $ WithLHSNaming lhsNaming <$> Compose focus] indexNamedArgs destructor pats A.LHSWith lhsHead withPatterns pats -> do - index lhsHead + index $ WithLHSNaming lhsNaming lhsHead index withPatterns -- TODO: what do the named args mean? forM_ pats $ \(C.Arg argInfo (C.Named _name pat)) -> when (C.argInfoOrigin argInfo == C.UserWritten) $ index pat -instance Indexable A.LHS where - index (A.LHS lhsInfo core) = case Info.lhsEllipsis lhsInfo of +instance Indexable (WithLHSNaming A.LHS) where + index (WithLHSNaming lhsNaming (A.LHS lhsInfo core)) = case Info.lhsEllipsis lhsInfo of C.ExpandedEllipsis _range _withArgs -> return () - C.NoEllipsis -> index core + C.NoEllipsis -> index $ WithLHSNaming lhsNaming core instance Indexable A.RewriteEqn where index eqn = case eqn of @@ -382,15 +388,15 @@ instance Indexable A.RHS where return () A.WithRHS _generatedFn withExprs clauses -> do forM_ withExprs indexWithExpr - index clauses + index $ WithLHSNaming LHSAnonymous <$> clauses A.RewriteRHS rewriteExprs _strippedPats rewriteRhs whereDecls -> do index rewriteExprs index rewriteRhs index whereDecls -instance (Indexable a) => Indexable (A.Clause' a) where - index (A.Clause lhs _strippedPats rhs whereDecls _catchall) = do - index lhs +instance Indexable (WithLHSNaming A.Clause) where + index (WithLHSNaming lhsNaming (A.Clause lhs _strippedPats rhs whereDecls _catchall)) = do + index $ WithLHSNaming lhsNaming lhs index rhs index whereDecls diff --git a/test/Test.hs b/test/Test.hs index 34aa3eb..0c2c0ca 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -12,6 +12,7 @@ import Test.Tasty.Options import qualified Test.Model as Model import qualified Test.ModelMonad as ModelMonad import qualified Test.Indexer.Invariants as IndexerInvariants +import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -39,7 +40,8 @@ tests = do LSP.tests alsPath, Model.tests, ModelMonad.tests, - indexerInvariantsTest + indexerInvariantsTest, + NoAnonFunSymbol.tests #if defined(wasm32_HOST_ARCH) , WASM.tests alsPath #endif diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index 0a80b52..bc41b79 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -22,49 +22,14 @@ import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension) +import TestData (AgdaFileDetails (AgdaFileDetails)) import qualified TestData tests :: IO TestTree tests = do inPaths <- findByExtension [".agda"] "test/data/Indexer" files <- forM inPaths $ \inPath -> do - let testName = takeBaseName inPath - uri = LSP.filePathToUri inPath - model <- TestData.getModel - - (file, interface) <- LSP.runLspT undefined $ do - env <- TestData.getServerEnv model - runServerT env $ do - interface <- runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile - - TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) - checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src - return $ Imp.crInterface checkResult - - ast <- runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile - - withAstFor src return - - -- Write the AST to a file for debugging purposes - liftIO $ writeFile ("test/data/AST" testName) $ prettyShow $ topLevelDecls ast - - runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile - - agdaFile <- indexFile src - return (agdaFile, interface) - + TestData.AgdaFileDetails testName file interface <- TestData.agdaFileDetails inPath return (testName, file, interface) return $ diff --git a/test/Test/Indexer/NoAnonFunSymbol.hs b/test/Test/Indexer/NoAnonFunSymbol.hs new file mode 100644 index 0000000..4a6f997 --- /dev/null +++ b/test/Test/Indexer/NoAnonFunSymbol.hs @@ -0,0 +1,25 @@ +module Test.Indexer.NoAnonFunSymbol (tests) where + +import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Utils.Lens ((^.)) +import Agda.Utils.Maybe (ifJustM, whenJust, whenJustM) +import Control.Monad (forM) +import Data.Foldable (find) +import Data.List (isInfixOf) +import qualified Data.Map as Map +import Server.Model.AgdaFile (agdaFileSymbols) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase) +import qualified TestData + +tests :: TestTree +tests = + testCase "No symbols for internal anonymous function names" $ do + TestData.AgdaFileDetails name agdaFile interface <- TestData.agdaFileDetails "test/data/AnonFun.agda" + + let symbolNames = prettyShow <$> Map.keys (agdaFile ^. agdaFileSymbols) + whenJust (find isAnonFunName symbolNames) $ \name -> + assertFailure $ "Found symbol for internal anonymous function: " ++ name + +isAnonFunName :: String -> Bool +isAnonFunName name = ".extendedlambda" `isInfixOf` name diff --git a/test/TestData.hs b/test/TestData.hs index d9d9e00..299e697 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -8,23 +8,83 @@ module TestData fileUri3, fakeUri, getServerEnv, + AgdaFileDetails (..), + agdaFileDetails, ) where +import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) +import qualified Agda.Interaction.Imports as Imp +import qualified Agda.Interaction.Options +import Agda.Syntax.Abstract.More () +import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Syntax.Translation.ConcreteToAbstract (topLevelDecls) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.FileName (absolute) import Agda.Utils.IORef (newIORef) import Agda.Utils.Lens (set, (<&>)) import Control.Concurrent (newChan) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map as Map +import Indexer (indexFile, withAstFor) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP -import Monad (Env (Env)) +import qualified Language.LSP.Server as LSP +import Monad (Env (Env), runServerT) import Options (defaultOptions, initConfig) import qualified Server.CommandController as CommandController import Server.Model (Model (Model)) -import Server.Model.AgdaFile (emptyAgdaFile) +import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import Server.Model.Monad (runWithAgdaLib) import qualified Server.ResponseController as ResponseController +import System.FilePath (takeBaseName, ()) + +data AgdaFileDetails = AgdaFileDetails + { fileName :: String, + agdaFile :: AgdaFile, + interface :: TCM.Interface + } + +agdaFileDetails :: FilePath -> IO AgdaFileDetails +agdaFileDetails inPath = do + let testName = takeBaseName inPath + uri = LSP.filePathToUri inPath + model <- TestData.getModel + + (file, interface) <- LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + interface <- runWithAgdaLib uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) + checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src + return $ Imp.crInterface checkResult + + ast <- runWithAgdaLib uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + withAstFor src return + + runWithAgdaLib uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions + absInPath <- liftIO $ absolute inPath + let srcFile = SourceFile absInPath + src <- TCM.liftTCM $ Imp.parseSource srcFile + + agdaFile <- indexFile src + return (agdaFile, interface) + + return $ AgdaFileDetails testName file interface + +-------------------------------------------------------------------------------- documentSymbolMessage :: LSP.NormalizedUri -> LSP.TRequestMessage LSP.Method_TextDocumentDocumentSymbol documentSymbolMessage uri = diff --git a/test/data/AnonFun.agda b/test/data/AnonFun.agda new file mode 100644 index 0000000..c62b8a6 --- /dev/null +++ b/test/data/AnonFun.agda @@ -0,0 +1,4 @@ +module AnonFun where + +f : {A : Set} -> A -> A +f = \where x -> x From 768f723c6fad5992d75178bc86036be667cfad86 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 1 Nov 2025 14:16:51 -0500 Subject: [PATCH 20/47] support Agda 2.8.0 indexing --- src/Indexer/Indexer.hs | 44 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 42 insertions(+), 2 deletions(-) diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index e900bb8..090ddcd 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,7 +22,7 @@ import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe (whenJust) import Agda.Utils.Monad (when) -import Data.Foldable (forM_, traverse_) +import Data.Foldable (forM_, traverse_, toList) import Data.Functor.Compose (Compose (Compose, getCompose)) import qualified Data.Set as Set import Data.Void (absurd) @@ -213,9 +214,17 @@ instance Indexable A.Expr where A.Let _exprInfo bindings body -> do index bindings index body +#if MIN_VERSION_Agda(2,8,0) + A.Rec _kwRange _exprInfo recAssigns -> +#else A.Rec _exprInfo recAssigns -> +#endif index recAssigns +#if MIN_VERSION_Agda(2,8,0) + A.RecUpdate _kwRange _exprInfo exprRec assigns -> do +#else A.RecUpdate _exprInfo exprRec assigns -> do +#endif index exprRec index assigns A.ScopedExpr _scope expr' -> @@ -269,11 +278,18 @@ instance (Indexable a) => Indexable (A.Pattern' a) where index rhs A.WithP _patInfo pat' -> index pat' +#if MIN_VERSION_Agda(2,8,0) + A.RecP _kwRange _conPatInfo fieldAssignments -> +#else A.RecP _conPatInfo fieldAssignments -> +#endif index fieldAssignments +#if MIN_VERSION_Agda(2,8,0) +#else A.AnnP _patInfo type' pat' -> do index type' index pat' +#endif instance (Indexable a) => Indexable (Maybe a) @@ -452,19 +468,35 @@ instance Indexable A.LetBinding where A.LetOpen _moduleInfo moduleName importDirective -> do tellUsage moduleName index importDirective +#if MIN_VERSION_Agda(2,8,0) + A.LetAxiom _letInfo _argInfo boundName type' -> do + -- TODO: what does the `ArgInfo` mean? + tellBinding boundName Axiom type' + index type' +#else A.LetDeclaredVariable boundName -> -- This is always a declaration tellDecl boundName Local UnknownType +#endif indexNamedArgBinder :: (TypeLike t, HasParamNames t) => C.NamedArg A.Binder -> t -> IndexerM () +#if MIN_VERSION_Agda(2,8,0) +indexNamedArgBinder + (C.Arg argInfo (C.Named _maybeArgName (A.Binder pat nameOrigin name))) + typeLike = + when (C.argInfoOrigin argInfo == C.UserWritten && nameOrigin == C.UserBinderName) $ do + tellBinding name Param typeLike + index pat +#else indexNamedArgBinder (C.Arg argInfo (C.Named _maybeArgName (A.Binder pat name))) typeLike = when (C.argInfoOrigin argInfo == C.UserWritten) $ do tellBinding name Param typeLike index pat +#endif instance Indexable A.TypedBinding where index = \case @@ -492,7 +524,11 @@ instance Indexable A.DataDefParams where instance Indexable A.RecordDirectives where index = \case +#if MIN_VERSION_Agda(2,8,0) + (C.RecordDirectives inductive _hasEta _patRange (A.NamedRecCon conName)) -> +#else (C.RecordDirectives inductive _hasEta _patRange (Just conName)) -> +#endif tellDef conName (constructorSymbolKind inductive) UnknownType _noUserConstructor -> return () where @@ -606,7 +642,11 @@ instance SymbolKindLike TCM.Defn where toSymbolKind = \case TCM.AxiomDefn _axiomData -> Axiom TCM.DataOrRecSigDefn _dataOrRecSigData -> Unknown +#if MIN_VERSION_Agda(2,8,0) + TCM.GeneralizableVar _numGeneralizableArgs -> GeneralizeVar +#else TCM.GeneralizableVar -> GeneralizeVar +#endif TCM.AbstractDefn defn -> toSymbolKind defn TCM.FunctionDefn _functionData -> Fun TCM.DatatypeDefn _datatypeData -> Data @@ -637,7 +677,7 @@ instance HasParamNames A.Type where getParamNames tel <> getParamNames codom A.Fun _exprInfo _dom codom -> getParamNames codom A.Generalized varNames codom -> - Set.toList varNames <> getParamNames codom + toList varNames <> getParamNames codom A.ScopedExpr _scopeInfo expr -> getParamNames expr _noMoreParams -> [] From 094a883c11cf8f2ea8738636bb0401e3545e8f89 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 1 Nov 2025 16:29:45 -0500 Subject: [PATCH 21/47] support Agda 2.8.0 file management --- agda-language-server.cabal | 2 + src/Agda/Interaction/Imports/More.hs | 39 +------- src/Agda/Interaction/Imports/Virtual.hs | 96 +++++++++++++++++++ src/Agda/Syntax/Abstract/More.hs | 1 - .../Handler/TextDocument/FileManagement.hs | 27 +++--- src/Server/Model/Monad.hs | 20 ++++ 6 files changed, 138 insertions(+), 47 deletions(-) create mode 100644 src/Agda/Interaction/Imports/Virtual.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index a64e3c5..727fbd3 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -50,6 +50,7 @@ library Agda Agda.Convert Agda.Interaction.Imports.More + Agda.Interaction.Imports.Virtual Agda.Interaction.Library.More Agda.IR Agda.Parser @@ -198,6 +199,7 @@ test-suite als-test Agda Agda.Convert Agda.Interaction.Imports.More + Agda.Interaction.Imports.Virtual Agda.Interaction.Library.More Agda.IR Agda.Parser diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 549625b..3d905be 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} module Agda.Interaction.Imports.More - ( parseVirtualSource, - setOptionsFromSourcePragmas, + ( setOptionsFromSourcePragmas, checkModuleName', + runPMDropWarnings, + moduleName, + runPM, + beginningOfFile, ) where @@ -93,38 +96,6 @@ import Agda.Utils.Singleton (singleton) import Agda.Syntax.Common.Pretty (pretty) #endif --- | Parse a source file without talking to the filesystem -parseVirtualSource :: - -- | Logical path of the source file. Used in ranges, not filesystem access. - SourceFile -> - -- | Logical contents of the source file - TL.Text -> - TCM Imp.Source -parseVirtualSource sourceFile source = Bench.billTo [Bench.Parsing] $ do - f <- srcFilePath sourceFile - let rf0 = mkRangeFile f Nothing - setCurrentRange (beginningOfFile rf0) $ do - parsedModName0 <- moduleName f . fst . fst =<< do - runPMDropWarnings $ parseFile moduleParser rf0 $ TL.unpack source - - let rf = mkRangeFile f $ Just parsedModName0 - ((parsedMod, attrs), fileType) <- runPM $ parseFile moduleParser rf $ TL.unpack source - parsedModName <- moduleName f parsedMod - - -- TODO: handle libs properly - let libs = [] - - return - Source - { srcText = source, - srcFileType = fileType, - srcOrigin = sourceFile, - srcModule = parsedMod, - srcModuleName = parsedModName, - srcProjectLibs = libs, - srcAttributes = attrs - } - srcFilePath :: SourceFile -> TCM AbsolutePath #if MIN_VERSION_Agda(2,8,0) srcFilePath = TCM.srcFilePath diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs new file mode 100644 index 0000000..30535a0 --- /dev/null +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module Agda.Interaction.Imports.Virtual + ( VSourceFile (..), + vSrcFileId, + vSrcFromUri, + parseVSource, + ) +where + +#if MIN_VERSION_Agda(2,8,0) +#else +import Agda.Interaction.FindFile (SourceFile (SourceFile)) +#endif +import qualified Agda.Interaction.Imports as Imp +import qualified Agda.Interaction.Imports.More as Imp +import Agda.Syntax.Parser (moduleParser, parseFile) +import Agda.Syntax.Position (mkRangeFile) +import qualified Agda.TypeChecking.Monad as TCM +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans (lift) +import qualified Data.Strict as Strict +import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS + +data VSourceFile = VSourceFile + { vSrcFileSrcFile :: TCM.SourceFile, + vSrcUri :: LSP.NormalizedUri, + vSrcVFile :: VFS.VirtualFile + } + +vSrcFilePath :: (TCM.MonadFileId m) => VSourceFile -> m TCM.AbsolutePath +vSrcFilePath = TCM.srcFilePath . vSrcFileSrcFile + +vSrcFileId :: VSourceFile -> TCM.FileId +vSrcFileId = TCM.srcFileId . vSrcFileSrcFile + +#if MIN_VERSION_Agda(2,8,0) +vSrcFromUri :: + (TCM.MonadFileId m, MonadIO m) => + LSP.NormalizedUri -> + VFS.VirtualFile -> + m VSourceFile +vSrcFromUri normUri file = do + absPath <- uriToPossiblyInvalidAbsolutePath normUri + src <- TCM.srcFromPath absPath + return $ VSourceFile src normUri file +#else +vSrcFromUri :: + (MonadIO m) => + LSP.NormalizedUri -> + VFS.VirtualFile -> + m VSourceFile +vSrcFromUri normUri file = do + absPath <- uriToPossiblyInvalidAbsolutePath normUri + let src = SourceFile absPath + return $ VSourceFile src normUri file +#endif + +-- | Based on @parseSource@ +parseVSource :: (TCM.MonadTCM m) => VSourceFile -> m Imp.Source +parseVSource vSrcFile = TCM.liftTCM $ do + let sourceFile = vSrcFileSrcFile vSrcFile + f <- vSrcFilePath vSrcFile + + let rf0 = mkRangeFile f Nothing + TCM.setCurrentRange (Imp.beginningOfFile rf0) $ do + let sourceStrict = VFS.virtualFileText $ vSrcVFile vSrcFile + let source = Strict.toLazy sourceStrict + let txt = Text.unpack sourceStrict + + parsedModName0 <- + Imp.moduleName f . fst . fst =<< do + Imp.runPMDropWarnings $ parseFile moduleParser rf0 txt + + let rf = mkRangeFile f $ Just parsedModName0 + ((parsedMod, attrs), fileType) <- Imp.runPM $ parseFile moduleParser rf txt + parsedModName <- Imp.moduleName f parsedMod + + -- TODO: handle libs properly + let libs = [] + + return + Imp.Source + { Imp.srcText = source, + Imp.srcFileType = fileType, + Imp.srcOrigin = sourceFile, + Imp.srcModule = parsedMod, + Imp.srcModuleName = parsedModName, + Imp.srcProjectLibs = libs, + Imp.srcAttributes = attrs + } diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs index efd4131..fbe4f2b 100644 --- a/src/Agda/Syntax/Abstract/More.hs +++ b/src/Agda/Syntax/Abstract/More.hs @@ -170,7 +170,6 @@ instance Pretty LetBinding where text "let" <+> pretty (unBind name) <+> text "=" <+> pretty expr LetPatBind _letInfo pat expr -> text "letPat" <+> pretty pat <+> text "=" <+> pretty expr - LetDeclaredVariable name -> text "letDeclared" <+> pretty (unBind name) _ -> text "LetBinding" instance Pretty Binder where diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index a43d8f9..c95f349 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -7,6 +7,7 @@ where import Agda.Interaction.FindFile (SourceFile (SourceFile)) import qualified Agda.Interaction.Imports.More as Imp +import Agda.Interaction.Imports.Virtual (parseVSource, vSrcFromUri) import Agda.TypeChecking.Monad (MonadTCM (liftTCM)) import Agda.Utils.Lens ((^.)) import Control.Monad.Trans (lift) @@ -14,9 +15,9 @@ import Data.Strict (Strict (toLazy)) import Indexer (indexFile) import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Server as VFS import qualified Language.LSP.VFS as VFS import Monad (ServerM, modifyModel) import qualified Server.Model as Model @@ -24,11 +25,14 @@ import Server.Model.Handler (notificationHandlerWithAgdaLib) didOpenHandler :: LSP.Handlers ServerM didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen $ \uri notification -> do - sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri - let sourceText = toLazy $ notification ^. LSP.params . LSP.textDocument . LSP.text - src <- liftTCM $ Imp.parseVirtualSource sourceFile sourceText - agdaFile <- indexFile src - lift $ modifyModel $ Model.setAgdaFile uri agdaFile + vfile <- lift $ LSP.getVirtualFile uri + case vfile of + Nothing -> return () + Just vfile -> do + vSourceFile <- vSrcFromUri uri vfile + src <- liftTCM $ parseVSource vSourceFile + agdaFile <- indexFile src + lift $ modifyModel $ Model.setAgdaFile uri agdaFile didCloseHandler :: LSP.Handlers ServerM didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClose $ \uri notification -> do @@ -36,12 +40,11 @@ didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClos didSaveHandler :: LSP.Handlers ServerM didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \uri notification -> do - sourceFile <- SourceFile <$> uriToPossiblyInvalidAbsolutePath uri - virtualFile <- lift $ VFS.getVirtualFile uri - case virtualFile of + vfile <- lift $ LSP.getVirtualFile uri + case vfile of Nothing -> return () - Just virtualFile -> do - let sourceText = toLazy $ VFS.virtualFileText virtualFile - src <- liftTCM $ Imp.parseVirtualSource sourceFile sourceText + Just vfile -> do + vSourceFile <- vSrcFromUri uri vfile + src <- liftTCM $ parseVSource vSourceFile agdaFile <- indexFile src lift $ modifyModel $ Model.setAgdaFile uri agdaFile diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index ba2e8b0..1a8a313 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -45,6 +46,9 @@ import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) import Server.Model.AgdaLib (AgdaLib, agdaLibTcEnv, agdaLibTcStateRef) +#if MIN_VERSION_Agda(2,8,0) +import Agda.Utils.FileId (File, getIdFile) +#endif -------------------------------------------------------------------------------- @@ -110,6 +114,16 @@ defaultLiftTCM (TCM f) = do tcEnv <- useAgdaLib agdaLibTcEnv liftIO $ f tcStateRef tcEnv +#if MIN_VERSION_Agda(2,8,0) +-- Taken from TCMT implementation +defaultFileFromId :: (MonadAgdaLib m) => TCM.FileId -> m File +defaultFileFromId fi = useTC TCM.stFileDict <&> (`getIdFile` fi) + +-- Taken from TCMT implementation +defaultIdFromFile :: (MonadAgdaLib m) => File -> m TCM.FileId +defaultIdFromFile = TCM.stateTCLens TCM.stFileDict . TCM.registerFileIdWithBuiltin +#endif + -------------------------------------------------------------------------------- newtype WithAgdaLibT m a = WithAgdaLibT {unWithAgdaLibT :: ReaderT AgdaLib m a} @@ -151,6 +165,12 @@ instance (MonadIO m) => HasOptions (WithAgdaLibT m) where instance (MonadIO m) => MonadTCM (WithAgdaLibT m) where liftTCM = defaultLiftTCM +#if MIN_VERSION_Agda(2,8,0) +instance (MonadIO m) => TCM.MonadFileId (WithAgdaLibT m) where + fileFromId = defaultFileFromId + idFromFile = defaultIdFromFile +#endif + -------------------------------------------------------------------------------- data WithAgdaFileEnv = WithAgdaFileEnv From 91ec6d41f32b511e5e0d0616b7fbf3779679ad63 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 1 Nov 2025 17:40:20 -0500 Subject: [PATCH 22/47] support Agda 2.8.0 in tests --- src/Indexer.hs | 46 +++++++++++++++----------- test/Test/Indexer/Invariants.hs | 17 ---------- test/TestData.hs | 57 ++++++++++++++++++--------------- test/data/Indexer/Module.agda | 2 +- test/data/test.agda-lib | 2 ++ 5 files changed, 61 insertions(+), 63 deletions(-) create mode 100644 test/data/test.agda-lib diff --git a/src/Indexer.hs b/src/Indexer.hs index 73b13fb..2861528 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -2,6 +2,7 @@ module Indexer ( withAstFor, + usingSrcAsCurrent, indexFile, ) where @@ -21,9 +22,9 @@ import Indexer.Postprocess (postprocess) import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (WithAgdaLibM) -withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a +usingSrcAsCurrent :: Imp.Source -> WithAgdaLibM a -> WithAgdaLibM a #if MIN_VERSION_Agda(2,8,0) -withAstFor src f = do +usingSrcAsCurrent src x = do TCM.liftTCM $ TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ -- Now reset the options @@ -31,16 +32,9 @@ withAstFor src f = do TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) $ do - let topLevel = - TopLevel - (Imp.srcOrigin src) - (Imp.srcModuleName src) - (C.modDecls $ Imp.srcModule src) - ast <- TCM.liftTCM $ toAbstract topLevel - f ast + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) x #else -withAstFor src f = do +usingSrcAsCurrent src x = do TCM.liftTCM $ TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ -- Now reset the options @@ -48,14 +42,28 @@ withAstFor src f = do TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) $ do - let topLevel = - TopLevel - (srcFilePath $ Imp.srcOrigin src) - (Imp.srcModuleName src) - (C.modDecls $ Imp.srcModule src) - ast <- TCM.liftTCM $ toAbstract topLevel - f ast + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) x +#endif + +withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a +#if MIN_VERSION_Agda(2,8,0) +withAstFor src f = usingSrcAsCurrent src $ do + let topLevel = + TopLevel + (Imp.srcOrigin src) + (Imp.srcModuleName src) + (C.modDecls $ Imp.srcModule src) + ast <- TCM.liftTCM $ toAbstract topLevel + f ast +#else +withAstFor src f = usingSrcAsCurrent src $ do + let topLevel = + TopLevel + (srcFilePath $ Imp.srcOrigin src) + (Imp.srcModuleName src) + (C.modDecls $ Imp.srcModule src) + ast <- TCM.liftTCM $ toAbstract topLevel + f ast #endif indexFile :: diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index bc41b79..8345bc5 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -1,28 +1,11 @@ module Test.Indexer.Invariants (tests) where -import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) -import qualified Agda.Interaction.Imports as Imp -import Agda.Interaction.Options (defaultOptions) -import Agda.Syntax.Abstract.More () -import Agda.Syntax.Common.Pretty (prettyShow) -import Agda.Syntax.Translation.ConcreteToAbstract (TopLevelInfo (topLevelDecls)) -import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.FileName (absolute) import Control.Monad (forM) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as Map -import Indexer (indexFile, withAstFor) -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Server as LSP -import Monad (runServerT) -import Server.Model.Monad (runWithAgdaLib) -import System.FilePath (takeBaseName, ()) import Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) import Test.Indexer.NoMissing (testNoMissing) import Test.Indexer.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension) -import TestData (AgdaFileDetails (AgdaFileDetails)) import qualified TestData tests :: IO TestTree diff --git a/test/TestData.hs b/test/TestData.hs index 299e697..8f9b7c3 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} module TestData @@ -13,7 +14,13 @@ module TestData ) where -import Agda.Interaction.FindFile (SourceFile (SourceFile), srcFilePath) +import Agda.Interaction.FindFile + ( SourceFile (SourceFile), +#if MIN_VERSION_Agda(2,8,0) +#else + srcFilePath, +#endif + ) import qualified Agda.Interaction.Imports as Imp import qualified Agda.Interaction.Options import Agda.Syntax.Abstract.More () @@ -26,11 +33,11 @@ import Agda.Utils.Lens (set, (<&>)) import Control.Concurrent (newChan) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map as Map -import Indexer (indexFile, withAstFor) +import Indexer (indexFile, withAstFor, usingSrcAsCurrent) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Monad (Env (Env), runServerT) +import Monad (Env (Env), runServerT, catchTCError) import Options (defaultOptions, initConfig) import qualified Server.CommandController as CommandController import Server.Model (Model (Model)) @@ -39,6 +46,7 @@ import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) import Server.Model.Monad (runWithAgdaLib) import qualified Server.ResponseController as ResponseController import System.FilePath (takeBaseName, ()) +import Agda.TypeChecking.Pretty (prettyTCM) data AgdaFileDetails = AgdaFileDetails { fileName :: String, @@ -55,32 +63,29 @@ agdaFileDetails inPath = do (file, interface) <- LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - interface <- runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile - - TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) + let withSrc f = runWithAgdaLib uri $ do + TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions + absInPath <- liftIO $ absolute inPath +#if MIN_VERSION_Agda(2,8,0) + srcFile <- TCM.srcFromPath absInPath +#else + let srcFile = SourceFile absInPath +#endif + src <- TCM.liftTCM $ Imp.parseSource srcFile + + f src + + let onErr = \err -> runWithAgdaLib uri $ do + t <- TCM.liftTCM $ prettyTCM err + error $ prettyShow t + + interface <- (withSrc $ \src -> usingSrcAsCurrent src $ do checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src - return $ Imp.crInterface checkResult - - ast <- runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile - - withAstFor src return + return $ Imp.crInterface checkResult) `catchTCError` onErr - runWithAgdaLib uri $ do - TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions - absInPath <- liftIO $ absolute inPath - let srcFile = SourceFile absInPath - src <- TCM.liftTCM $ Imp.parseSource srcFile + file <- withSrc indexFile `catchTCError` onErr - agdaFile <- indexFile src - return (agdaFile, interface) + return (file, interface) return $ AgdaFileDetails testName file interface diff --git a/test/data/Indexer/Module.agda b/test/data/Indexer/Module.agda index 6685305..817d050 100644 --- a/test/data/Indexer/Module.agda +++ b/test/data/Indexer/Module.agda @@ -1,4 +1,4 @@ -module Module where +module Indexer.Module where data Nat : Set where zero : Nat diff --git a/test/data/test.agda-lib b/test/data/test.agda-lib new file mode 100644 index 0000000..33f7e30 --- /dev/null +++ b/test/data/test.agda-lib @@ -0,0 +1,2 @@ +name: test +include: . \ No newline at end of file From 6e86f66541af5b6cc799c1dd00e8c620c06e1c42 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 1 Nov 2025 18:34:08 -0500 Subject: [PATCH 23/47] Agda 2.7.0.1 compatibility fixes --- src/Agda/Interaction/Imports/More.hs | 6 +++--- src/Agda/Interaction/Imports/Virtual.hs | 17 +++++++++++------ src/Agda/Position.hs | 5 +++-- stack.yaml.lock | 4 ++-- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 3d905be..987da8e 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -39,7 +39,6 @@ import Agda.Syntax.Position ( Range, Range' (Range), RangeFile, - beginningOfFile, getRange, intervalToRange, mkRangeFile, @@ -47,6 +46,7 @@ import Agda.Syntax.Position posToRange', startPos, #if MIN_VERSION_Agda(2,8,0) + beginningOfFile, rangeFromAbsolutePath, #endif ) @@ -58,8 +58,7 @@ import Agda.Syntax.TopLevelModuleName ( #endif ) import Agda.TypeChecking.Monad - ( AbsolutePath, - Interface, + ( Interface, TCM, checkAndSetOptionsFromPragma, setCurrentRange, @@ -78,6 +77,7 @@ import qualified Agda.TypeChecking.Monad.Benchmark as Bench #else import Agda.TypeChecking.Warnings (runPM) #endif +import Agda.Utils.FileName (AbsolutePath) import Agda.Utils.Monad (bracket_) #if MIN_VERSION_Agda(2,8,0) import qualified Data.Text as T diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 30535a0..932076c 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -3,13 +3,13 @@ module Agda.Interaction.Imports.Virtual ( VSourceFile (..), - vSrcFileId, vSrcFromUri, parseVSource, ) where #if MIN_VERSION_Agda(2,8,0) +import Agda.TypeChecking.Monad (SourceFile (SourceFile)) #else import Agda.Interaction.FindFile (SourceFile (SourceFile)) #endif @@ -18,6 +18,7 @@ import qualified Agda.Interaction.Imports.More as Imp import Agda.Syntax.Parser (moduleParser, parseFile) import Agda.Syntax.Position (mkRangeFile) import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.FileName (AbsolutePath) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans (lift) import qualified Data.Strict as Strict @@ -28,16 +29,20 @@ import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS data VSourceFile = VSourceFile - { vSrcFileSrcFile :: TCM.SourceFile, + { vSrcFileSrcFile :: SourceFile, vSrcUri :: LSP.NormalizedUri, vSrcVFile :: VFS.VirtualFile } -vSrcFilePath :: (TCM.MonadFileId m) => VSourceFile -> m TCM.AbsolutePath +#if MIN_VERSION_Agda(2,8,0) +vSrcFilePath :: (TCM.MonadFileId m) => VSourceFile -> m AbsolutePath vSrcFilePath = TCM.srcFilePath . vSrcFileSrcFile - -vSrcFileId :: VSourceFile -> TCM.FileId -vSrcFileId = TCM.srcFileId . vSrcFileSrcFile +#else +vSrcFilePath :: (Monad m) => VSourceFile -> m AbsolutePath +vSrcFilePath vSourceFile = do + let (SourceFile path) = vSrcFileSrcFile vSourceFile + return path +#endif #if MIN_VERSION_Agda(2,8,0) vSrcFromUri :: diff --git a/src/Agda/Position.hs b/src/Agda/Position.hs index 4122326..d90e96d 100644 --- a/src/Agda/Position.hs +++ b/src/Agda/Position.hs @@ -24,6 +24,7 @@ import qualified Data.Strict.Maybe as Strict import Data.Text (Text) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP +import Data.Functor (void) -- Note: LSP srclocs are 0-base -- Agda srclocs are 1-base @@ -73,8 +74,8 @@ intervalEnd :: Interval -> PositionWithoutFile intervalStart (Interval _ start _end) = start intervalEnd (Interval _ _start end) = end #else -intervalStart (Interval start _end) = start -intervalEnd (Interval _start end) = end +intervalStart (Interval start _end) = void start +intervalEnd (Interval _start end) = void end #endif -- | Agda Range -> LSP Range diff --git a/stack.yaml.lock b/stack.yaml.lock index d9c754b..82be79c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,9 +5,9 @@ packages: - completed: - hackage: Agda-2.8.0@sha256:f85f3b10eb034687b07d073686ab97c947082eecc5ad268cbe20a4c774abcaae,34434 + hackage: Agda-2.8.0@sha256:b73b1b6685650d4429074f10440952cecb7aef190a994f75d168c354d20b01a8,34453 pantry-tree: - sha256: 01cbe34629f37fa56a411390d4d9fa281bb92b8a66a6757232240f58380678a7 + sha256: 7dace5cc1fe5a4f09212dda58392ae29f34bb1382c6eb04cb86514b5f5e2da32 size: 43914 original: hackage: Agda-2.8.0 From b4b41724c9cc507c26cd801adc05347d0a5047e4 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 8 Nov 2025 19:34:39 -0600 Subject: [PATCH 24/47] better support for include paths --- agda-language-server.cabal | 3 + src/Agda/Interaction/Imports/More.hs | 12 ++- src/Agda/Interaction/Imports/Virtual.hs | 22 ++-- src/Agda/Interaction/Library/More.hs | 13 ++- src/Agda/TypeChecking/Monad/Options/More.hs | 58 ++++++++++ src/Indexer.hs | 27 +++-- src/Language/LSP/Protocol/Types/Uri/More.hs | 44 ++++++++ .../Handler/TextDocument/FileManagement.hs | 8 +- src/Server/Model/AgdaLib.hs | 75 +++++++++++-- src/Server/Model/Handler.hs | 2 + src/Server/Model/Monad.hs | 102 +++++++++++++++++- test/Test.hs | 2 + test/Test/Uri.hs | 23 ++++ 13 files changed, 348 insertions(+), 43 deletions(-) create mode 100644 src/Agda/TypeChecking/Monad/Options/More.hs create mode 100644 test/Test/Uri.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 727fbd3..d1e8341 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -56,6 +56,7 @@ library Agda.Parser Agda.Position Agda.Syntax.Abstract.More + Agda.TypeChecking.Monad.Options.More Control.Concurrent.SizedChan Indexer Indexer.Indexer @@ -194,6 +195,7 @@ test-suite als-test Test.Model Test.ModelMonad Test.SrcLoc + Test.Uri Test.WASM TestData Agda @@ -205,6 +207,7 @@ test-suite als-test Agda.Parser Agda.Position Agda.Syntax.Abstract.More + Agda.TypeChecking.Monad.Options.More Control.Concurrent.SizedChan Indexer Indexer.Indexer diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 987da8e..3cfe11e 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -22,6 +22,7 @@ import Agda.Interaction.FindFile ( import Agda.Interaction.Imports (Source (..)) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Library (OptionsPragma (..), _libPragmas) +import Agda.Interaction.Library.More () import Agda.Syntax.Common (TopLevelModuleName') import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Parser ( @@ -57,6 +58,7 @@ import Agda.Syntax.TopLevelModuleName ( rawTopLevelModuleNameForModule, #endif ) +import Agda.Syntax.Common.Pretty (Pretty, pretty, text, prettyAssign, (<+>)) import Agda.TypeChecking.Monad ( Interface, TCM, @@ -92,8 +94,6 @@ import Control.Monad.Error.Class ( ) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.Singleton (singleton) -#else -import Agda.Syntax.Common.Pretty (pretty) #endif srcFilePath :: SourceFile -> TCM AbsolutePath @@ -193,3 +193,11 @@ moduleName file parsedModule = Bench.billTo [Bench.ModuleName] $ do } else return raw #endif + +-- Orphan instances + +instance Pretty Imp.Source where + pretty src = + text "Source" + <+> pretty (Imp.srcModuleName src) + <+> pretty (Imp.srcProjectLibs src) diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 932076c..3c59edf 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -19,6 +19,7 @@ import Agda.Syntax.Parser (moduleParser, parseFile) import Agda.Syntax.Position (mkRangeFile) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.FileName (AbsolutePath) +import Agda.Utils.Maybe (maybeToList) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans (lift) import qualified Data.Strict as Strict @@ -27,6 +28,8 @@ import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS +import Server.Model.AgdaLib (agdaLibToFile) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) data VSourceFile = VSourceFile { vSrcFileSrcFile :: SourceFile, @@ -67,10 +70,10 @@ vSrcFromUri normUri file = do #endif -- | Based on @parseSource@ -parseVSource :: (TCM.MonadTCM m) => VSourceFile -> m Imp.Source -parseVSource vSrcFile = TCM.liftTCM $ do +parseVSource :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => VSourceFile -> m Imp.Source +parseVSource vSrcFile = do let sourceFile = vSrcFileSrcFile vSrcFile - f <- vSrcFilePath vSrcFile + f <- TCM.liftTCM $ vSrcFilePath vSrcFile let rf0 = mkRangeFile f Nothing TCM.setCurrentRange (Imp.beginningOfFile rf0) $ do @@ -79,15 +82,16 @@ parseVSource vSrcFile = TCM.liftTCM $ do let txt = Text.unpack sourceStrict parsedModName0 <- - Imp.moduleName f . fst . fst =<< do - Imp.runPMDropWarnings $ parseFile moduleParser rf0 txt + TCM.liftTCM $ + Imp.moduleName f . fst . fst =<< do + Imp.runPMDropWarnings $ parseFile moduleParser rf0 txt let rf = mkRangeFile f $ Just parsedModName0 - ((parsedMod, attrs), fileType) <- Imp.runPM $ parseFile moduleParser rf txt - parsedModName <- Imp.moduleName f parsedMod + ((parsedMod, attrs), fileType) <- TCM.liftTCM $ Imp.runPM $ parseFile moduleParser rf txt + parsedModName <- TCM.liftTCM $ Imp.moduleName f parsedMod - -- TODO: handle libs properly - let libs = [] + agdaLib <- askAgdaLib + let libs = maybeToList $ agdaLibToFile (vSrcUri vSrcFile) agdaLib return Imp.Source diff --git a/src/Agda/Interaction/Library/More.hs b/src/Agda/Interaction/Library/More.hs index 72f98c7..da5e264 100644 --- a/src/Agda/Interaction/Library/More.hs +++ b/src/Agda/Interaction/Library/More.hs @@ -9,8 +9,8 @@ module Agda.Interaction.Library.More ) where -import Agda.Interaction.Library (LibM) -import Agda.Interaction.Library.Base (LibErrorIO) +import Agda.Interaction.Library (LibM, AgdaLibFile) +import Agda.Interaction.Library.Base (LibErrorIO, libName, libFile, libIncludes) import Agda.Utils.Either (maybeRight) import Agda.Utils.Null (Null (empty)) import Control.Category ((>>>)) @@ -18,6 +18,8 @@ import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Lazy (evalStateT) import Control.Monad.Writer.Lazy (runWriterT) +import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) +import Agda.Utils.Lens ((^.)) #if MIN_VERSION_Agda(2,8,0) -- Unneeded in 2.8.0 due to API changes @@ -37,3 +39,10 @@ tryRunLibM = >>> flip evalStateT empty >>> fmap (fst >>> maybeRight) >>> liftIO + +instance Pretty AgdaLibFile where + pretty agdaLibFile = + text "AgdaLibFile" + <+> (pretty $ agdaLibFile ^. libName) + <+> (pretty $ agdaLibFile ^. libFile) + <+> (pretty $ agdaLibFile ^. libIncludes) diff --git a/src/Agda/TypeChecking/Monad/Options/More.hs b/src/Agda/TypeChecking/Monad/Options/More.hs new file mode 100644 index 0000000..eba67cb --- /dev/null +++ b/src/Agda/TypeChecking/Monad/Options/More.hs @@ -0,0 +1,58 @@ +module Agda.TypeChecking.Monad.Options.More (setCommandLineOptionsByLib) where + +import Agda.Interaction.Options (CommandLineOptions (..)) +import qualified Agda.Interaction.Options.Lenses as Lens +import Agda.TypeChecking.Monad (MonadTCM) +import qualified Agda.TypeChecking.Monad as TCM +import Agda.TypeChecking.Monad.Benchmark (updateBenchmarkingStatus) +import Agda.Utils.FileName (AbsolutePath, absolute) +import Agda.Utils.Lens ((^.)) +import qualified Agda.Utils.List1 as List1 +import Control.Monad.IO.Class (liftIO) +import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) +import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) +import System.Directory (getCurrentDirectory) + +setCommandLineOptionsByLib :: + (MonadTCM m, MonadAgdaLib m) => + CommandLineOptions -> + m () +setCommandLineOptionsByLib opts = do + root <- liftIO (absolute =<< getCurrentDirectory) + setCommandLineOptionsByLib' root opts + +setCommandLineOptionsByLib' :: + (MonadTCM m, MonadAgdaLib m) => + AbsolutePath -> + CommandLineOptions -> + m () +setCommandLineOptionsByLib' root opts = do + incs <- case optAbsoluteIncludePaths opts of + [] -> do + opts' <- setLibraryPathsByLib opts + let incs = optIncludePaths opts' + TCM.liftTCM $ TCM.setIncludeDirs incs root + List1.toList <$> TCM.getIncludeDirs + incs -> return incs + TCM.modifyTC $ Lens.setCommandLineOptions opts {optAbsoluteIncludePaths = incs} + TCM.liftTCM $ TCM.setPragmaOptions (optPragmaOptions opts) + TCM.liftTCM updateBenchmarkingStatus + +setLibraryPathsByLib :: + (MonadTCM m, MonadAgdaLib m) => + CommandLineOptions -> + m CommandLineOptions +setLibraryPathsByLib o = do + agdaLib <- askAgdaLib + return $ addDefaultLibrariesByLib agdaLib o + +-- TODO: resolve dependency libs; see setLibraryIncludes in Agda + +addDefaultLibrariesByLib :: AgdaLib -> CommandLineOptions -> CommandLineOptions +addDefaultLibrariesByLib agdaLib o + | not (null $ optLibraries o) || not (optUseLibs o) = o + | otherwise = do + let libs = agdaLib ^. agdaLibDependencies + let incs = uriToPossiblyInvalidFilePath <$> agdaLib ^. agdaLibIncludes + o {optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs} diff --git a/src/Indexer.hs b/src/Indexer.hs index 2861528..8b95761 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -12,9 +12,12 @@ where import Agda.Interaction.FindFile (srcFilePath) #endif import qualified Agda.Interaction.Imports as Imp +import qualified Agda.Interaction.Imports.More as Imp +import Agda.Syntax.Common.Pretty (prettyShow) import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel), TopLevelInfo) import qualified Agda.TypeChecking.Monad as TCM +import Agda.TypeChecking.Monad.Options.More (setCommandLineOptionsByLib) import qualified Data.Map as Map import Indexer.Indexer (indexAst) import Indexer.Monad (execIndexerM) @@ -23,27 +26,21 @@ import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (WithAgdaLibM) usingSrcAsCurrent :: Imp.Source -> WithAgdaLibM a -> WithAgdaLibM a -#if MIN_VERSION_Agda(2,8,0) usingSrcAsCurrent src x = do - TCM.liftTCM $ - TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ - -- Now reset the options - TCM.setCommandLineOptions . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC + TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src - TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) + TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ + -- Now reset the options + setCommandLineOptionsByLib . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) x +#if MIN_VERSION_Agda(2,8,0) + TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) $ do #else -usingSrcAsCurrent src x = do - TCM.liftTCM $ - TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ - -- Now reset the options - TCM.setCommandLineOptions . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC - TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) - - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) x + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) $ do #endif + x withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a #if MIN_VERSION_Agda(2,8,0) diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index dea62db..c428ecd 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -1,7 +1,9 @@ module Language.LSP.Protocol.Types.Uri.More ( getNormalizedUri, isUriAncestorOf, + uriHeightAbove, uriToPossiblyInvalidAbsolutePath, + uriToPossiblyInvalidFilePath, ) where @@ -24,6 +26,40 @@ isUriAncestorOf :: LSP.NormalizedUri -> LSP.NormalizedUri -> Bool isUriAncestorOf ancestor descendant = getNormalizedUri ancestor `Text.isPrefixOf` getNormalizedUri descendant +-- | If @ancestor@ is an ancestor of @descendant@, then +-- @uriHeightAbove ancestor descendant@ is the height of @ancestor@ above +-- @descendant@. +-- +-- For example, the height of @https://example.com/a/@ over +-- @https://example.com/a/b/c/@ is 2. +-- +-- This is a heuristic implementation and may need replacement if the heuristic +-- leads to bugs. +uriHeightAbove :: LSP.NormalizedUri -> LSP.NormalizedUri -> Int +uriHeightAbove ancestor descendant = + let suffix = pathBetween (getNormalizedUri ancestor) (getNormalizedUri descendant) + path = stripSlash $ stripScheme suffix + in countPathComponents path + where + pathBetween :: Text -> Text -> Text + pathBetween a b = case Text.commonPrefixes a b of + Just (_prefix, _suffixA, suffixB) -> suffixB + Nothing -> "" + + stripScheme :: Text -> Text + stripScheme uri = + let (prefix, suffix) = Text.breakOn "//" uri + in if Text.null suffix then prefix else suffix + + stripSlash :: Text -> Text + stripSlash = Text.dropAround (== '/') + + countPathComponents :: Text -> Int + countPathComponents path = + if Text.null path + then 0 + else Text.count "/" path + 1 + uriToPossiblyInvalidAbsolutePath :: (MonadIO m) => LSP.NormalizedUri -> m AbsolutePath uriToPossiblyInvalidAbsolutePath uri = do case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of @@ -32,3 +68,11 @@ uriToPossiblyInvalidAbsolutePath uri = do uriToInvalidAbsolutePath :: LSP.NormalizedUri -> AbsolutePath uriToInvalidAbsolutePath = AbsolutePath . getNormalizedUri + +uriToPossiblyInvalidFilePath :: LSP.NormalizedUri -> FilePath +uriToPossiblyInvalidFilePath uri = case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of + Just path -> path + Nothing -> uriToInvalidFilePath uri + +uriToInvalidFilePath :: LSP.NormalizedUri -> FilePath +uriToInvalidFilePath = Text.unpack . getNormalizedUri diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index c95f349..aa5fb7c 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -8,10 +8,12 @@ where import Agda.Interaction.FindFile (SourceFile (SourceFile)) import qualified Agda.Interaction.Imports.More as Imp import Agda.Interaction.Imports.Virtual (parseVSource, vSrcFromUri) +import Agda.Syntax.Common.Pretty (prettyShow) import Agda.TypeChecking.Monad (MonadTCM (liftTCM)) import Agda.Utils.Lens ((^.)) import Control.Monad.Trans (lift) import Data.Strict (Strict (toLazy)) +import qualified Data.Text as Text import Indexer (indexFile) import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP @@ -30,7 +32,8 @@ didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen Nothing -> return () Just vfile -> do vSourceFile <- vSrcFromUri uri vfile - src <- liftTCM $ parseVSource vSourceFile + src <- parseVSource vSourceFile + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src agdaFile <- indexFile src lift $ modifyModel $ Model.setAgdaFile uri agdaFile @@ -45,6 +48,7 @@ didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave Nothing -> return () Just vfile -> do vSourceFile <- vSrcFromUri uri vfile - src <- liftTCM $ parseVSource vSourceFile + src <- parseVSource vSourceFile + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src agdaFile <- indexFile src lift $ modifyModel $ Model.setAgdaFile uri agdaFile diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index aaa9b6b..9589de6 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -4,16 +4,20 @@ module Server.Model.AgdaLib ( AgdaLib (AgdaLib), initAgdaLib, agdaLibIncludes, + agdaLibDependencies, agdaLibTcStateRef, agdaLibTcEnv, isAgdaLibForUri, agdaLibFromFs, + agdaLibToFile, ) where import Agda.Interaction.Library ( - AgdaLibFile (_libIncludes), + AgdaLibFile (_libIncludes, AgdaLibFile), findProjectRoot, + LibName, + OptionsPragma (OptionsPragma), #if MIN_VERSION_Agda(2,8,0) getAgdaLibFile, #else @@ -29,43 +33,76 @@ import Agda.Interaction.Library.More ( ) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (IORef, newIORef) -import Agda.Utils.Lens (Lens', (<&>), (^.)) +import Agda.Utils.Lens (Lens', (<&>), (^.), set) import Agda.Utils.Maybe (listToMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Map (Map) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Server.Model.AgdaFile (AgdaFile) +import Agda.Interaction.Library.Base (libFile, LibName (..), libName, libIncludes, libPragmas) +import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) +import Agda.Utils.Null (empty) +import Agda.Syntax.Common.Pretty (Pretty, pretty, vcat, prettyAssign, text, pshow, doubleQuotes, (<+>)) + +data AgdaLibOrigin = FromFile !FilePath | Defaulted deriving (Show) data AgdaLib = AgdaLib - { _agdaLibIncludes :: ![LSP.NormalizedUri], + { _agdaLibName :: !LibName, + _agdaLibIncludes :: ![LSP.NormalizedUri], + _agdaLibOptionsPragma :: !OptionsPragma, + _agdaLibDependencies :: ![LibName], _agdaLibTcStateRef :: !(IORef TCM.TCState), - _agdaLibTcEnv :: !TCM.TCEnv + _agdaLibTcEnv :: !TCM.TCEnv, + _agdaLibOrigin :: !AgdaLibOrigin } -initAgdaLibWithIncludes :: (MonadIO m) => [LSP.NormalizedUri] -> m AgdaLib -initAgdaLibWithIncludes includes = do +instance Pretty AgdaLib where + pretty agdaLib = + text "AgdaLib" + <+> doubleQuotes (pretty $ agdaLib ^. agdaLibName) + <+> pshow (agdaLib ^. agdaLibOrigin) + <+> text "includes:" + <+> pretty (LSP.getNormalizedUri <$> (agdaLib ^. agdaLibIncludes)) + +initAgdaLibWithOrigin :: (MonadIO m) => AgdaLibOrigin -> m AgdaLib +initAgdaLibWithOrigin origin = do #if MIN_VERSION_Agda(2,8,0) + let libName = LibName "" [] tcState <- liftIO TCM.initStateIO #else + let libName = "" let tcState = TCM.initState #endif tcStateRef <- liftIO $ newIORef tcState let tcEnv = TCM.initEnv - return $ AgdaLib includes tcStateRef tcEnv + let optionsPragma = OptionsPragma [] empty + return $ AgdaLib libName [] optionsPragma [] tcStateRef tcEnv origin initAgdaLib :: (MonadIO m) => m AgdaLib -initAgdaLib = initAgdaLibWithIncludes [] +initAgdaLib = initAgdaLibWithOrigin Defaulted + +agdaLibName :: Lens' AgdaLib LibName +agdaLibName f a = f (_agdaLibName a) <&> \x -> a {_agdaLibName = x} agdaLibIncludes :: Lens' AgdaLib [LSP.NormalizedUri] agdaLibIncludes f a = f (_agdaLibIncludes a) <&> \x -> a {_agdaLibIncludes = x} +agdaLibOptionsPragma :: Lens' AgdaLib OptionsPragma +agdaLibOptionsPragma f a = f (_agdaLibOptionsPragma a) <&> \x -> a {_agdaLibOptionsPragma = x} + +agdaLibDependencies :: Lens' AgdaLib [LibName] +agdaLibDependencies f a = f (_agdaLibDependencies a) <&> \x -> a {_agdaLibDependencies = x} + agdaLibTcStateRef :: Lens' AgdaLib (IORef TCM.TCState) agdaLibTcStateRef f a = f (_agdaLibTcStateRef a) <&> \x -> a {_agdaLibTcStateRef = x} agdaLibTcEnv :: Lens' AgdaLib TCM.TCEnv agdaLibTcEnv f a = f (_agdaLibTcEnv a) <&> \x -> a {_agdaLibTcEnv = x} +agdaLibOrigin :: Lens' AgdaLib AgdaLibOrigin +agdaLibOrigin f a = f (_agdaLibOrigin a) <&> \x -> a {_agdaLibOrigin = x} + isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) @@ -86,6 +123,7 @@ agdaLibFromFs path = do Nothing -> return Nothing _noRoot -> return Nothing +-- TODO: this traverses the filesystem tryGetLibFileFromRootPath :: (MonadIO m) => FilePath -> m (Maybe AgdaLibFile) #if MIN_VERSION_Agda(2,8,0) tryGetLibFileFromRootPath root = do @@ -100,6 +138,21 @@ tryGetLibFileFromRootPath root = do #endif agdaLibFromFile :: (MonadIO m) => AgdaLibFile -> m AgdaLib -agdaLibFromFile libFile = do - let includes = LSP.toNormalizedUri . LSP.filePathToUri <$> _libIncludes libFile - initAgdaLibWithIncludes includes +agdaLibFromFile agdaLibFile = do + let includes = LSP.toNormalizedUri . LSP.filePathToUri <$> agdaLibFile ^. libIncludes + initAgdaLibWithOrigin (FromFile $ agdaLibFile ^. libFile) + <&> set agdaLibName (agdaLibFile ^. libName) + <&> set agdaLibIncludes includes + <&> set agdaLibOptionsPragma (agdaLibFile ^. libPragmas) + +-- | If the given `AgdaLib` came from a file, turn it back into one. Since +-- `AgdaLibFile`s are relative to an Agda file on the filesystem, the first +-- parameter is for the URI for the Agda file +agdaLibToFile :: LSP.NormalizedUri -> AgdaLib -> Maybe AgdaLibFile +agdaLibToFile relativeToUri agdaLib = case agdaLib ^. agdaLibOrigin of + Defaulted -> Nothing + FromFile filePath -> + let includePaths = uriToPossiblyInvalidFilePath <$> agdaLib ^. agdaLibIncludes + uri = LSP.toNormalizedUri $ LSP.filePathToUri filePath + above = LSP.uriHeightAbove uri relativeToUri + in Just $ AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index bef30ec..1a261df 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -45,6 +45,7 @@ notificationHandlerWithAgdaLib m handlerWithAgdaLib = LSP.notificationHandler m let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri agdaLib <- findAgdaLib normUri + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow agdaLib let notificationHandler = runWithAgdaLibT agdaLib . handlerWithAgdaLib normUri let handler = tryTC $ notificationHandler notification @@ -52,6 +53,7 @@ notificationHandlerWithAgdaLib m handlerWithAgdaLib = LSP.notificationHandler m let onErr = \err -> runWithAgdaLibT agdaLib $ do message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) lift $ LSP.sendNotification LSP.SMethod_WindowShowMessage $ LSP.ShowMessageParams LSP.MessageType_Error message + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Error message fromRightM onErr handler diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index 1a8a313..1290344 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -24,13 +25,16 @@ module Server.Model.Monad where import Agda.Interaction.Options (CommandLineOptions (optPragmaOptions), PragmaOptions) +import Agda.Interaction.Response (Response_boot (Resp_HighlightingInfo)) import Agda.Syntax.Common.Pretty (prettyShow) -import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv, TCM, TCMT (..), TCState (stPersistentState), catchError_, modifyTCLens, setTCLens, stPragmaOptions, useTC) +import Agda.Syntax.Position (getRange) +import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), MonadTrace, PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv (..), TCM, TCMT (..), TCState (stPersistentState), catchError_, modifyTCLens, setTCLens, stPragmaOptions, useTC, viewTC) import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Pretty as TCM import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) import Agda.Utils.Lens (Lens', locally, over, use, view, (<&>), (^.)) -import Agda.Utils.Monad (bracket_) +import Agda.Utils.Monad (and2M, bracket_, ifNotM, unless) +import Agda.Utils.Null (null) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask, asks) import Control.Monad.Trans (MonadTrans, lift) @@ -46,6 +50,7 @@ import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) import Server.Model.AgdaLib (AgdaLib, agdaLibTcEnv, agdaLibTcStateRef) +import Prelude hiding (null) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.FileId (File, getIdFile) #endif @@ -114,6 +119,94 @@ defaultLiftTCM (TCM f) = do tcEnv <- useAgdaLib agdaLibTcEnv liftIO $ f tcStateRef tcEnv +-- Taken from TCM implementation +defaultTraceClosureCall :: (MonadAgdaLib m, MonadTrace m) => TCM.Closure TCM.Call -> m a -> m a +defaultTraceClosureCall cl m = do + -- Compute update to 'Range' and 'Call' components of 'TCEnv'. + let withCall = + localTC $ + foldr (.) id $ + concat $ + [ [\e -> e {envCall = Just cl} | TCM.interestingCall call], + [ \e -> e {envHighlightingRange = callRange} + | callHasRange && highlightCall + || isNoHighlighting + ], + [\e -> e {envRange = callRange} | callHasRange] + ] + + -- For interactive highlighting, also wrap computation @m@ in 'highlightAsTypeChecked': + ifNotM + (pure highlightCall `and2M` do (TCM.Interactive ==) . envHighlightingLevel <$> askTC) + {-then-} (withCall m) + {-else-} $ do + oldRange <- envHighlightingRange <$> askTC + TCM.highlightAsTypeChecked oldRange callRange $ + withCall m + where + call = TCM.clValue cl + callRange = getRange call + callHasRange = not $ null callRange + + -- Should the given call trigger interactive highlighting? + highlightCall = case call of + TCM.CheckClause {} -> True + TCM.CheckLHS {} -> True + TCM.CheckPattern {} -> True + TCM.CheckPatternLinearityType {} -> False + TCM.CheckPatternLinearityValue {} -> False + TCM.CheckLetBinding {} -> True + TCM.InferExpr {} -> True + TCM.CheckExprCall {} -> True + TCM.CheckDotPattern {} -> True + TCM.IsTypeCall {} -> True + TCM.IsType_ {} -> True + TCM.InferVar {} -> True + TCM.InferDef {} -> True + TCM.CheckArguments {} -> True + TCM.CheckMetaSolution {} -> False + TCM.CheckTargetType {} -> False + TCM.CheckDataDef {} -> True + TCM.CheckRecDef {} -> True + TCM.CheckConstructor {} -> True + TCM.CheckConArgFitsIn {} -> False + TCM.CheckFunDefCall _ _ _ h -> h + TCM.CheckPragma {} -> True + TCM.CheckPrimitive {} -> True + TCM.CheckIsEmpty {} -> True + TCM.CheckConfluence {} -> False + TCM.CheckIApplyConfluence {} -> False + TCM.CheckModuleParameters {} -> False + TCM.CheckWithFunctionType {} -> True + TCM.CheckSectionApplication {} -> True + TCM.CheckNamedWhere {} -> False + TCM.ScopeCheckExpr {} -> False + TCM.ScopeCheckDeclaration {} -> False + TCM.ScopeCheckLHS {} -> False + TCM.NoHighlighting {} -> True + TCM.CheckProjection {} -> False + TCM.SetRange {} -> False + TCM.ModuleContents {} -> False + + isNoHighlighting = case call of + TCM.NoHighlighting {} -> True + _ -> False + + printHighlightingInfo remove info = do + modToSrc <- useTC TCM.stModuleToSource + method <- viewTC TCM.eHighlightingMethod + -- reportSDoc "highlighting" 50 $ + -- pure $ + -- vcat + -- [ "Printing highlighting info:", + -- nest 2 $ (text . show) info, + -- "File modules:", + -- nest 2 $ pretty modToSrc + -- ] + unless (null info) $ do + TCM.appInteractionOutputCallback $ + Resp_HighlightingInfo info remove method modToSrc + #if MIN_VERSION_Agda(2,8,0) -- Taken from TCMT implementation defaultFileFromId :: (MonadAgdaLib m) => TCM.FileId -> m File @@ -162,6 +255,11 @@ instance (MonadIO m) => HasOptions (WithAgdaLibT m) where pragmaOptions = defaultPragmaOptionsImpl commandLineOptions = defaultCommandLineOptionsImpl +-- TODO: how should this really be implemented? +instance (MonadIO m) => MonadTrace (WithAgdaLibT m) where + traceClosureCall = defaultTraceClosureCall + printHighlightingInfo _ _ = return () + instance (MonadIO m) => MonadTCM (WithAgdaLibT m) where liftTCM = defaultLiftTCM diff --git a/test/Test.hs b/test/Test.hs index 0c2c0ca..7d22750 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -13,6 +13,7 @@ import qualified Test.Model as Model import qualified Test.ModelMonad as ModelMonad import qualified Test.Indexer.Invariants as IndexerInvariants import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol +import qualified Test.Uri as URI -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -38,6 +39,7 @@ tests = do "Tests" [ SrcLoc.tests, LSP.tests alsPath, + URI.tests, Model.tests, ModelMonad.tests, indexerInvariantsTest, diff --git a/test/Test/Uri.hs b/test/Test/Uri.hs new file mode 100644 index 0000000..e35947f --- /dev/null +++ b/test/Test/Uri.hs @@ -0,0 +1,23 @@ +module Test.Uri (tests) where + +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types.Uri.More (uriHeightAbove) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup "URI" $ + [ testGroup "uriHeightAbove" $ + [ testCase "calculates positive height" $ do + let ancestor = LSP.toNormalizedUri $ LSP.Uri "https://example.com/a/b/c/d/" + let descendant = LSP.toNormalizedUri $ LSP.Uri "https://example.com/a/b/c/d/e/f" + let height = uriHeightAbove ancestor descendant + height @?= 2, + testCase "calculates 0 height" $ do + let ancestor = LSP.toNormalizedUri $ LSP.Uri "file://home/user/username/a/" + let descendant = LSP.toNormalizedUri $ LSP.Uri "file://home/user/username/a" + let height = uriHeightAbove ancestor descendant + height @?= 0 + ] + ] From 958e6b76377557dd2056c80b2f9c7e47371c5261 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 9 Nov 2025 10:22:03 -0600 Subject: [PATCH 25/47] clear state before loading files --- agda-language-server.cabal | 8 +- src/Indexer.hs | 104 ++---------------- test/Test.hs | 6 +- test/Test/Indexer.hs | 16 +++ test/Test/Indexer/Invariants.hs | 6 +- .../{ => Invariants}/NoDuplicateDecl.hs | 2 +- .../Indexer/{ => Invariants}/NoMissing.hs | 2 +- .../Indexer/{ => Invariants}/NoOverlap.hs | 2 +- test/Test/Indexer/Reload.hs | 30 +++++ test/TestData.hs | 19 ++-- 10 files changed, 81 insertions(+), 114 deletions(-) create mode 100644 test/Test/Indexer.hs rename test/Test/Indexer/{ => Invariants}/NoDuplicateDecl.hs (95%) rename test/Test/Indexer/{ => Invariants}/NoMissing.hs (98%) rename test/Test/Indexer/{ => Invariants}/NoOverlap.hs (98%) create mode 100644 test/Test/Indexer/Reload.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index d1e8341..1190f0e 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -186,11 +186,13 @@ test-suite als-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Test.Indexer Test.Indexer.Invariants + Test.Indexer.Invariants.NoDuplicateDecl + Test.Indexer.Invariants.NoMissing + Test.Indexer.Invariants.NoOverlap Test.Indexer.NoAnonFunSymbol - Test.Indexer.NoDuplicateDecl - Test.Indexer.NoMissing - Test.Indexer.NoOverlap + Test.Indexer.Reload Test.LSP Test.Model Test.ModelMonad diff --git a/src/Indexer.hs b/src/Indexer.hs index 8b95761..ae24085 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -27,6 +27,8 @@ import Server.Model.Monad (WithAgdaLibM) usingSrcAsCurrent :: Imp.Source -> WithAgdaLibM a -> WithAgdaLibM a usingSrcAsCurrent src x = do + TCM.liftTCM TCM.resetState + TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ @@ -35,33 +37,26 @@ usingSrcAsCurrent src x = do #if MIN_VERSION_Agda(2,8,0) TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) $ do + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) x #else TCM.modifyTCLens TCM.stModuleToSource $ Map.insert (Imp.srcModuleName src) (srcFilePath $ Imp.srcOrigin src) - TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) $ do + TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) x #endif - x withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a -#if MIN_VERSION_Agda(2,8,0) withAstFor src f = usingSrcAsCurrent src $ do - let topLevel = - TopLevel - (Imp.srcOrigin src) - (Imp.srcModuleName src) - (C.modDecls $ Imp.srcModule src) - ast <- TCM.liftTCM $ toAbstract topLevel - f ast +#if MIN_VERSION_Agda(2,8,0) + let srcFile = Imp.srcOrigin src #else -withAstFor src f = usingSrcAsCurrent src $ do + let srcFile = srcFilePath $ Imp.srcOrigin src +#endif let topLevel = TopLevel - (srcFilePath $ Imp.srcOrigin src) + srcFile (Imp.srcModuleName src) (C.modDecls $ Imp.srcModule src) ast <- TCM.liftTCM $ toAbstract topLevel f ast -#endif indexFile :: Imp.Source -> @@ -69,84 +64,3 @@ indexFile :: indexFile src = withAstFor src $ \ast -> execIndexerM $ do indexAst ast postprocess - --- let options = defaultOptions - --- TCM.liftTCM TCM.resetState - --- TCM.liftTCM $ TCM.setCommandLineOptions' rootPath options --- TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src --- loadPrims <- optLoadPrimitives <$> TCM.pragmaOptions - --- when loadPrims $ do --- libdirPrim <- liftIO getPrimitiveLibDir - --- -- Turn off import-chasing messages. --- -- We have to modify the persistent verbosity setting, since --- -- getInterface resets the current verbosity settings to the persistent ones. - --- bracket_ (TCM.getsTC TCM.getPersistentVerbosity) TCM.putPersistentVerbosity $ do --- TCM.modifyPersistentVerbosity --- (Strict.Just . Trie.insert [] 0 . Strict.fromMaybe Trie.empty) --- -- set root verbosity to 0 - --- -- We don't want to generate highlighting information for Agda.Primitive. --- TCM.liftTCM $ --- TCM.withHighlightingLevel TCM.None $ --- forM_ (Set.map (libdirPrim ) TCM.primitiveModules) $ \f -> do --- primSource <- Imp.parseSource (SourceFile $ mkAbsolute f) --- Imp.checkModuleName' (Imp.srcModuleName primSource) (Imp.srcOrigin primSource) --- void $ Imp.getNonMainInterface (Imp.srcModuleName primSource) (Just primSource) - --- TCM.liftTCM $ Imp.checkModuleName' (Imp.srcModuleName src) (Imp.srcOrigin src) - --- addImportCycleCheck (Imp.srcModuleName src) $ --- TCM.localTC (\e -> e {TCM.envCurrentPath = Just $ TCM.srcFileId srcFile}) $ do --- let topLevel = --- C.TopLevel --- srcFile --- (Imp.srcModuleName src) --- (C.modDecls $ Imp.srcModule src) --- ast <- TCM.liftTCM $ C.toAbstract topLevel - --- deps <- TCM.useTC TCM.stImportedModulesTransitive --- moduleToSourceId <- TCM.useTC TCM.stModuleToSourceId --- forM_ deps $ maybeUpdateCacheForDepFile moduleToSourceId - --- cache <- getCache --- let entries = LSP.fromNormalizedUri . fst <$> Cache.getAllEntries cache --- alwaysReportSDoc "lsp.cache" 20 $ return (text "cache entries:" <+> pretty entries) - --- let ds = C.topLevelDecls ast --- let scope = C.topLevelScope ast - --- TCM.liftTCM TCM.activateLoadedFileCache - --- TCM.liftTCM TCM.cachingStarts --- opts <- TCM.liftTCM $ TCM.useTC TCM.stPragmaOptions --- me <- TCM.liftTCM TCM.readFromCachedLog --- case me of --- Just (TCM.Pragmas opts', _) --- | opts == opts' -> --- return () --- _ -> TCM.liftTCM TCM.cleanCachedLog --- TCM.liftTCM $ TCM.writeToCurrentLog $ TCM.Pragmas opts - --- TCM.liftTCM $ --- mapM_ TC.checkDeclCached ds `TCM.finally_` TCM.cacheCurrentLog - --- TCM.liftTCM TCM.unfreezeMetas - --- TCM.liftTCM $ TCM.setScope scope - --- TCM.liftTCM $ --- TCM.stCurrentModule --- `TCM.setTCLens'` Just --- ( C.topLevelModuleName ast, --- Imp.srcModuleName src --- ) - --- file <- Index.abstractToIndex $ C.topLevelDecls ast - --- -- return (file, moduleToSourceId, deps) --- return file diff --git a/test/Test.hs b/test/Test.hs index 7d22750..b949f2c 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -14,6 +14,7 @@ import qualified Test.ModelMonad as ModelMonad import qualified Test.Indexer.Invariants as IndexerInvariants import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol import qualified Test.Uri as URI +import qualified Test.Indexer as Indexer -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -33,7 +34,7 @@ main = do tests :: IO TestTree tests = do - indexerInvariantsTest <- IndexerInvariants.tests + indexerTests <- Indexer.tests return $ askOption $ \(AlsPathOption alsPath) -> testGroup "Tests" @@ -42,8 +43,7 @@ tests = do URI.tests, Model.tests, ModelMonad.tests, - indexerInvariantsTest, - NoAnonFunSymbol.tests + indexerTests #if defined(wasm32_HOST_ARCH) , WASM.tests alsPath #endif diff --git a/test/Test/Indexer.hs b/test/Test/Indexer.hs new file mode 100644 index 0000000..dcf3b9f --- /dev/null +++ b/test/Test/Indexer.hs @@ -0,0 +1,16 @@ +module Test.Indexer (tests) where + +import qualified Test.Indexer.Invariants as Invariants +import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol +import qualified Test.Indexer.Reload as Reload +import Test.Tasty (TestTree, testGroup) + +tests :: IO TestTree +tests = do + invariantsTests <- Invariants.tests + return $ + testGroup "Indexer" $ + [ invariantsTests, + NoAnonFunSymbol.tests, + Reload.tests + ] diff --git a/test/Test/Indexer/Invariants.hs b/test/Test/Indexer/Invariants.hs index 8345bc5..663a8a8 100644 --- a/test/Test/Indexer/Invariants.hs +++ b/test/Test/Indexer/Invariants.hs @@ -1,9 +1,9 @@ module Test.Indexer.Invariants (tests) where import Control.Monad (forM) -import Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) -import Test.Indexer.NoMissing (testNoMissing) -import Test.Indexer.NoOverlap (testNoOverlap) +import Test.Indexer.Invariants.NoDuplicateDecl (testNoDuplicateDecl) +import Test.Indexer.Invariants.NoMissing (testNoMissing) +import Test.Indexer.Invariants.NoOverlap (testNoOverlap) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension) import qualified TestData diff --git a/test/Test/Indexer/NoDuplicateDecl.hs b/test/Test/Indexer/Invariants/NoDuplicateDecl.hs similarity index 95% rename from test/Test/Indexer/NoDuplicateDecl.hs rename to test/Test/Indexer/Invariants/NoDuplicateDecl.hs index d09869f..415c698 100644 --- a/test/Test/Indexer/NoDuplicateDecl.hs +++ b/test/Test/Indexer/Invariants/NoDuplicateDecl.hs @@ -1,4 +1,4 @@ -module Test.Indexer.NoDuplicateDecl (testNoDuplicateDecl) where +module Test.Indexer.Invariants.NoDuplicateDecl (testNoDuplicateDecl) where import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common.Pretty (Pretty, align, pretty, prettyList, prettyShow, text, vcat, (<+>)) diff --git a/test/Test/Indexer/NoMissing.hs b/test/Test/Indexer/Invariants/NoMissing.hs similarity index 98% rename from test/Test/Indexer/NoMissing.hs rename to test/Test/Indexer/Invariants/NoMissing.hs index 69525ce..33cc208 100644 --- a/test/Test/Indexer/NoMissing.hs +++ b/test/Test/Indexer/Invariants/NoMissing.hs @@ -1,7 +1,7 @@ -- | Check that highlighting data doesn't show more references than we have -- `Ref`s. We expect to sometimes pick up references that highlighting does not, -- so it's okay if we have more. -module Test.Indexer.NoMissing (testNoMissing) where +module Test.Indexer.Invariants.NoMissing (testNoMissing) where import Agda.Interaction.Highlighting.Precise (Aspects, HighlightingInfo) import qualified Agda.Interaction.Highlighting.Precise as HL diff --git a/test/Test/Indexer/NoOverlap.hs b/test/Test/Indexer/Invariants/NoOverlap.hs similarity index 98% rename from test/Test/Indexer/NoOverlap.hs rename to test/Test/Indexer/Invariants/NoOverlap.hs index 9f24df3..7bdb0ec 100644 --- a/test/Test/Indexer/NoOverlap.hs +++ b/test/Test/Indexer/Invariants/NoOverlap.hs @@ -1,6 +1,6 @@ -- | Check that `Ref`s don't overlap, so that there is only one `Ref` instance -- per actual reference. -module Test.Indexer.NoOverlap (testNoOverlap) where +module Test.Indexer.Invariants.NoOverlap (testNoOverlap) where import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common.Pretty (Doc, Pretty (prettyList), align, parens, pretty, prettyShow, text, vcat, (<+>)) diff --git a/test/Test/Indexer/Reload.hs b/test/Test/Indexer/Reload.hs new file mode 100644 index 0000000..9632b51 --- /dev/null +++ b/test/Test/Indexer/Reload.hs @@ -0,0 +1,30 @@ +module Test.Indexer.Reload (tests) where + +import Indexer (indexFile) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import Monad (runServerT) +import Server.Model.Monad (runWithAgdaLib) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified TestData + +tests :: TestTree +tests = + testGroup "Reload" $ + [ testCase "Reload single file" $ testReloadFile "test/data/A.agda" + ] + +testReloadFile :: FilePath -> IO () +testReloadFile path = do + let uri = LSP.filePathToUri path + model <- TestData.getModel + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib uri $ do + src <- TestData.parseSourceFromPath path + _ <- indexFile src + _ <- indexFile src + return () diff --git a/test/TestData.hs b/test/TestData.hs index 8f9b7c3..dcf7759 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -11,6 +11,7 @@ module TestData getServerEnv, AgdaFileDetails (..), agdaFileDetails, + parseSourceFromPath, ) where @@ -65,13 +66,7 @@ agdaFileDetails inPath = do runServerT env $ do let withSrc f = runWithAgdaLib uri $ do TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions - absInPath <- liftIO $ absolute inPath -#if MIN_VERSION_Agda(2,8,0) - srcFile <- TCM.srcFromPath absInPath -#else - let srcFile = SourceFile absInPath -#endif - src <- TCM.liftTCM $ Imp.parseSource srcFile + src <- parseSourceFromPath inPath f src @@ -89,6 +84,16 @@ agdaFileDetails inPath = do return $ AgdaFileDetails testName file interface +parseSourceFromPath :: (TCM.MonadTCM m) => FilePath -> m Imp.Source +parseSourceFromPath path = do + absPath <- liftIO $ absolute path +#if MIN_VERSION_Agda(2,8,0) + srcFile <- TCM.liftTCM $ TCM.srcFromPath absPath +#else + let srcFile = SourceFile absPath +#endif + TCM.liftTCM $ Imp.parseSource srcFile + -------------------------------------------------------------------------------- documentSymbolMessage :: LSP.NormalizedUri -> LSP.TRequestMessage LSP.Method_TextDocumentDocumentSymbol From 688a1a8a9ca87746d7964974653d269cf02e618e Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 9 Nov 2025 15:29:18 -0600 Subject: [PATCH 26/47] test reloading is compatible with changes --- src/Agda/Interaction/Imports/Virtual.hs | 47 +++++++++++++++--------- src/Server/Model/AgdaFile.hs | 6 +++- src/Server/Model/Symbol.hs | 2 ++ test/Test/Indexer/Reload.hs | 48 +++++++++++++++++++++++-- test/TestData.hs | 27 +++++++++++--- 5 files changed, 105 insertions(+), 25 deletions(-) diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 3c59edf..02d7e07 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -4,6 +4,7 @@ module Agda.Interaction.Imports.Virtual ( VSourceFile (..), vSrcFromUri, + parseSourceFromContents, parseVSource, ) where @@ -37,15 +38,20 @@ data VSourceFile = VSourceFile vSrcVFile :: VFS.VirtualFile } +#if MIN_VERSION_Agda(2,8,0) +srcFilePath :: (TCM.MonadFileId m) => SourceFile -> m AbsolutePath +srcFilePath = TCM.srcFilePath +#else +srcFilePath :: (Monad m) => SourceFile -> m AbsolutePath +srcFilePath (SourceFile path) = return path +#endif + #if MIN_VERSION_Agda(2,8,0) vSrcFilePath :: (TCM.MonadFileId m) => VSourceFile -> m AbsolutePath -vSrcFilePath = TCM.srcFilePath . vSrcFileSrcFile #else vSrcFilePath :: (Monad m) => VSourceFile -> m AbsolutePath -vSrcFilePath vSourceFile = do - let (SourceFile path) = vSrcFileSrcFile vSourceFile - return path #endif +vSrcFilePath = srcFilePath . vSrcFileSrcFile #if MIN_VERSION_Agda(2,8,0) vSrcFromUri :: @@ -69,37 +75,44 @@ vSrcFromUri normUri file = do return $ VSourceFile src normUri file #endif --- | Based on @parseSource@ -parseVSource :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => VSourceFile -> m Imp.Source -parseVSource vSrcFile = do - let sourceFile = vSrcFileSrcFile vSrcFile - f <- TCM.liftTCM $ vSrcFilePath vSrcFile +parseSourceFromContents :: + (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => + LSP.NormalizedUri -> + SourceFile -> + Text.Text -> + m Imp.Source +parseSourceFromContents srcUri srcFile contentsStrict = do + f <- TCM.liftTCM $ srcFilePath srcFile let rf0 = mkRangeFile f Nothing TCM.setCurrentRange (Imp.beginningOfFile rf0) $ do - let sourceStrict = VFS.virtualFileText $ vSrcVFile vSrcFile - let source = Strict.toLazy sourceStrict - let txt = Text.unpack sourceStrict + let contents = Strict.toLazy contentsStrict + let contentsString = Text.unpack contentsStrict parsedModName0 <- TCM.liftTCM $ Imp.moduleName f . fst . fst =<< do - Imp.runPMDropWarnings $ parseFile moduleParser rf0 txt + Imp.runPMDropWarnings $ parseFile moduleParser rf0 contentsString let rf = mkRangeFile f $ Just parsedModName0 - ((parsedMod, attrs), fileType) <- TCM.liftTCM $ Imp.runPM $ parseFile moduleParser rf txt + ((parsedMod, attrs), fileType) <- TCM.liftTCM $ Imp.runPM $ parseFile moduleParser rf contentsString parsedModName <- TCM.liftTCM $ Imp.moduleName f parsedMod agdaLib <- askAgdaLib - let libs = maybeToList $ agdaLibToFile (vSrcUri vSrcFile) agdaLib + let libs = maybeToList $ agdaLibToFile srcUri agdaLib return Imp.Source - { Imp.srcText = source, + { Imp.srcText = contents, Imp.srcFileType = fileType, - Imp.srcOrigin = sourceFile, + Imp.srcOrigin = srcFile, Imp.srcModule = parsedMod, Imp.srcModuleName = parsedModName, Imp.srcProjectLibs = libs, Imp.srcAttributes = attrs } + +-- | Based on @parseSource@ +parseVSource :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => VSourceFile -> m Imp.Source +parseVSource (VSourceFile srcFile uri vFile) = + parseSourceFromContents uri srcFile (VFS.virtualFileText vFile) diff --git a/src/Server/Model/AgdaFile.hs b/src/Server/Model/AgdaFile.hs index 8b04452..2056c8a 100644 --- a/src/Server/Model/AgdaFile.hs +++ b/src/Server/Model/AgdaFile.hs @@ -14,7 +14,7 @@ where import Agda.Position (toLspRange) import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyAssign, prettyMap, text, vcat) +import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyAssign, prettyMap, prettyShow, text, vcat) import Agda.Syntax.Position (getRange) import Agda.Utils.Lens (Lens', over, (<&>), (^.)) import Data.Foldable (find) @@ -29,6 +29,7 @@ data AgdaFile = AgdaFile { _agdaFileSymbols :: !(Map A.QName SymbolInfo), _agdaFileRefs :: !(Map A.QName [Ref]) } + deriving (Eq) instance Pretty AgdaFile where pretty agdaFile = @@ -37,6 +38,9 @@ instance Pretty AgdaFile where prettyAssign (text "refs", prettyMap $ Map.toList $ agdaFile ^. agdaFileRefs) ] +instance Show AgdaFile where + show = prettyShow + emptyAgdaFile :: AgdaFile emptyAgdaFile = AgdaFile Map.empty Map.empty diff --git a/src/Server/Model/Symbol.hs b/src/Server/Model/Symbol.hs index e178690..696674a 100644 --- a/src/Server/Model/Symbol.hs +++ b/src/Server/Model/Symbol.hs @@ -66,6 +66,7 @@ data SymbolInfo = SymbolInfo symbolType :: !(Maybe String), symbolParent :: !(Maybe A.QName) } + deriving (Eq) instance Pretty SymbolInfo where pretty symbolInfo = @@ -115,6 +116,7 @@ data Ref = Ref refRange :: !LSP.Range, refIsAmbiguous :: !Bool } + deriving (Eq) prettyAmbiguity :: Ref -> Doc prettyAmbiguity ref = diff --git a/test/Test/Indexer/Reload.hs b/test/Test/Indexer/Reload.hs index 9632b51..a3b4ef5 100644 --- a/test/Test/Indexer/Reload.hs +++ b/test/Test/Indexer/Reload.hs @@ -1,18 +1,23 @@ module Test.Indexer.Reload (tests) where +import Agda.Interaction.Imports.Virtual (parseSourceFromContents) +import Agda.Syntax.Common.Pretty (prettyShow) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as Text import Indexer (indexFile) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerT) import Server.Model.Monad (runWithAgdaLib) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import qualified TestData tests :: TestTree tests = testGroup "Reload" $ - [ testCase "Reload single file" $ testReloadFile "test/data/A.agda" + [ testCase "Reload single file" $ testReloadFile "test/data/A.agda", + testCase "Reload after changes" testReloadChanges ] testReloadFile :: FilePath -> IO () @@ -28,3 +33,42 @@ testReloadFile path = do _ <- indexFile src _ <- indexFile src return () + +testReloadChanges :: IO () +testReloadChanges = do + let path = "test/data/A.agda" + let contentsA = + Text.unlines + [ "module A where", + "", + "data T : Set where", + " tt : T" + ] + let contentsB = + Text.unlines + [ "module A where", + "", + "data T : Set where", + " tt : T", + "", + "f : T -> T", + "f x = x" + ] + + let uri = LSP.filePathToUri path + model <- TestData.getModel + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib uri $ do + src0 <- TestData.parseSourceFromPathAndContents path contentsA + agdaFile0 <- indexFile src0 + + src1 <- TestData.parseSourceFromPathAndContents path contentsB + agdaFile1 <- indexFile src1 + + src2 <- TestData.parseSourceFromPathAndContents path contentsA + agdaFile2 <- indexFile src2 + + liftIO $ agdaFile0 @?= agdaFile2 diff --git a/test/TestData.hs b/test/TestData.hs index dcf7759..30da455 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -12,6 +12,7 @@ module TestData AgdaFileDetails (..), agdaFileDetails, parseSourceFromPath, + parseSourceFromPathAndContents, ) where @@ -44,10 +45,12 @@ import qualified Server.CommandController as CommandController import Server.Model (Model (Model)) import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) -import Server.Model.Monad (runWithAgdaLib) +import Server.Model.Monad (runWithAgdaLib, MonadAgdaLib) import qualified Server.ResponseController as ResponseController import System.FilePath (takeBaseName, ()) import Agda.TypeChecking.Pretty (prettyTCM) +import Data.Text (Text) +import Agda.Interaction.Imports.Virtual (parseSourceFromContents) data AgdaFileDetails = AgdaFileDetails { fileName :: String, @@ -84,16 +87,30 @@ agdaFileDetails inPath = do return $ AgdaFileDetails testName file interface -parseSourceFromPath :: (TCM.MonadTCM m) => FilePath -> m Imp.Source -parseSourceFromPath path = do +sourceFileFromPath :: (TCM.MonadTCM m) => FilePath -> m SourceFile +sourceFileFromPath path = do absPath <- liftIO $ absolute path #if MIN_VERSION_Agda(2,8,0) - srcFile <- TCM.liftTCM $ TCM.srcFromPath absPath + TCM.liftTCM $ TCM.srcFromPath absPath #else - let srcFile = SourceFile absPath + return $ SourceFile absPath #endif + +parseSourceFromPath :: (TCM.MonadTCM m) => FilePath -> m Imp.Source +parseSourceFromPath path = do + srcFile <- sourceFileFromPath path TCM.liftTCM $ Imp.parseSource srcFile +parseSourceFromPathAndContents :: + (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => + FilePath -> + Text -> + m Imp.Source +parseSourceFromPathAndContents path contents = do + srcFile <- sourceFileFromPath path + let uri = LSP.toNormalizedUri $ LSP.filePathToUri path + parseSourceFromContents uri srcFile contents + -------------------------------------------------------------------------------- documentSymbolMessage :: LSP.NormalizedUri -> LSP.TRequestMessage LSP.Method_TextDocumentDocumentSymbol From 811d5da8df323935ee0e7fcc62620a8569c185b8 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 9 Nov 2025 15:36:48 -0600 Subject: [PATCH 27/47] index module params as children of module --- src/Indexer/Indexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 090ddcd..1f473e0 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -84,8 +84,8 @@ instance Indexable A.Declaration where A.Section _range _erased moduleName genTel decls -> do tellDecl moduleName Module NoType tellParamNames moduleName genTel - index genTel withParent moduleName $ do + index genTel index decls A.Apply _moduleInfo _erased moduleName moduleApp _scopeCopyInfo importDirective -> do tellUsage moduleName From 8505671cfff3aedff0f33a6206ab3fb86421ff0a Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 9 Nov 2025 16:21:20 -0600 Subject: [PATCH 28/47] show fewer document symbols --- .../Handler/TextDocument/DocumentSymbol.hs | 72 +++++++++++++------ 1 file changed, 51 insertions(+), 21 deletions(-) diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs index bd5b695..d82f581 100644 --- a/src/Server/Handler/TextDocument/DocumentSymbol.hs +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -3,6 +3,7 @@ module Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) where import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Maybe (fromMaybe, mapMaybe) +import Agda.Utils.Monad (forMaybeM) import Control.Monad (forM) import Control.Monad.Trans (lift) import Data.Map (Map) @@ -15,7 +16,7 @@ import Monad (ServerM) import Server.Model.AgdaFile (AgdaFile, agdaFileSymbols, defNameRange, symbolByName, symbolsByParent) import Server.Model.Handler (requestHandlerWithAgdaFile) import Server.Model.Monad (MonadAgdaFile (askAgdaFile), useAgdaFile) -import Server.Model.Symbol (SymbolInfo (symbolName), lspSymbolKind, symbolShortName, symbolType) +import Server.Model.Symbol (SymbolInfo (symbolName), SymbolKind (..), lspSymbolKind, symbolKind, symbolShortName, symbolType) documentSymbolHandler :: LSP.Handlers ServerM documentSymbolHandler = requestHandlerWithAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do @@ -23,25 +24,54 @@ documentSymbolHandler = requestHandlerWithAgdaFile LSP.SMethod_TextDocumentDocum let symbols = symbolsByParent file let topLevelNames = fromMaybe [] $ Map.lookup Nothing symbols let topLevelSymbols = mapMaybe (symbolByName file) topLevelNames - topLevelDocumentSymbols <- lift $ forM topLevelSymbols $ symbolToDocumentSymbol file symbols + topLevelDocumentSymbols <- lift $ forMaybeM topLevelSymbols $ symbolToDocumentSymbol file symbols responder $ Right $ LSP.InR $ LSP.InL topLevelDocumentSymbols -symbolToDocumentSymbol :: AgdaFile -> Map (Maybe A.QName) [A.QName] -> SymbolInfo -> ServerM LSP.DocumentSymbol -symbolToDocumentSymbol file symbolsByParent symbol = do - let name = symbolName symbol - let range = defNameRange file name - let childrenNames = fromMaybe [] $ Map.lookup (Just name) symbolsByParent - let childrenSymbols = mapMaybe (symbolByName file) childrenNames - childrenDocumentSymbols <- - forM childrenSymbols $ - symbolToDocumentSymbol file symbolsByParent - return $ - LSP.DocumentSymbol - (symbolShortName symbol) - (Text.pack <$> symbolType symbol) - (lspSymbolKind symbol) - Nothing - Nothing - range - range - (Just childrenDocumentSymbols) +symbolToDocumentSymbol :: + AgdaFile -> + Map (Maybe A.QName) [A.QName] -> + SymbolInfo -> + ServerM (Maybe LSP.DocumentSymbol) +symbolToDocumentSymbol file symbolsByParent symbol = + if symbolIsDocumentSymbol symbol + then do + let name = symbolName symbol + let range = defNameRange file name + let childrenNames = fromMaybe [] $ Map.lookup (Just name) symbolsByParent + let childrenSymbols = mapMaybe (symbolByName file) childrenNames + childrenDocumentSymbols <- + forMaybeM childrenSymbols $ + symbolToDocumentSymbol file symbolsByParent + return $ + Just $ + LSP.DocumentSymbol + (symbolShortName symbol) + (Text.pack <$> symbolType symbol) + (lspSymbolKind symbol) + Nothing + Nothing + range + range + (Just childrenDocumentSymbols) + else return Nothing + +-- | We only want to report "important" symbols as document symbols. For +-- example, top level module definitions should be document symbols, but local +-- variables should not. +symbolIsDocumentSymbol :: SymbolInfo -> Bool +symbolIsDocumentSymbol symbol = case symbolKind symbol of + Con -> True + CoCon -> True + Field -> True + PatternSyn -> True + GeneralizeVar -> True + Macro -> True + Data -> True + Record -> True + Fun -> True + Axiom -> True + Prim -> True + Module -> True + Param -> False + Local -> False + Unknown -> False From f29df3215d5669a78faf1b16434d41d83579b3f2 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 9 Nov 2025 17:12:54 -0600 Subject: [PATCH 29/47] Agda 2.6.4.3 compatibility --- src/Agda/Interaction/Imports/More.hs | 8 +++++++- src/Agda/Syntax/Abstract/More.hs | 1 - src/Indexer/Indexer.hs | 20 ++++++++++++++++---- src/Server/Model/Handler.hs | 5 +++++ src/Server/Model/Monad.hs | 6 +++++- 5 files changed, 33 insertions(+), 7 deletions(-) diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 3cfe11e..1c2b374 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -62,12 +62,14 @@ import Agda.Syntax.Common.Pretty (Pretty, pretty, text, prettyAssign, (<+>)) import Agda.TypeChecking.Monad ( Interface, TCM, - checkAndSetOptionsFromPragma, setCurrentRange, setOptionsFromPragma, setTCLens, stPragmaOptions, useTC, +#if MIN_VERSION_Agda(2,7,0) + checkAndSetOptionsFromPragma, +#endif #if MIN_VERSION_Agda(2,8,0) runPM, runPMDropWarnings, @@ -146,9 +148,13 @@ setOptionsFromSourcePragmas checkOpts src = do mapM_ setOpts (srcDefaultPragmas src) mapM_ setOpts (srcFilePragmas src) where +#if MIN_VERSION_Agda(2,7,0) setOpts | checkOpts = checkAndSetOptionsFromPragma | otherwise = setOptionsFromPragma +#else + setOpts = setOptionsFromPragma +#endif -- Andreas, 2016-07-11, issue 2092 -- The error range should be set to the file with the wrong module name diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs index fbe4f2b..cf36516 100644 --- a/src/Agda/Syntax/Abstract/More.hs +++ b/src/Agda/Syntax/Abstract/More.hs @@ -7,7 +7,6 @@ import Agda.Syntax.Abstract import Agda.Syntax.Common import Agda.Syntax.Common (ArgInfo (argInfoOrigin)) import Agda.Syntax.Common.Pretty -import Agda.Syntax.Concrete (TacticAttribute' (theTacticAttribute)) import Agda.Syntax.Info import Agda.Utils.Functor ((<&>)) import Data.Foldable (Foldable (toList)) diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 1f473e0..40030ca 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -136,7 +136,11 @@ instance Indexable A.Declaration where index decls A.PatternSynDef name bindings pat -> do tellDecl name PatternSyn UnknownType +#if MIN_VERSION_Agda(2,7,0) forM_ bindings $ \(C.WithHiding _hiding binding) -> +#else + forM_ bindings $ \(C.Arg _argInfo binding) -> +#endif tellDef binding Param UnknownType let pat' :: A.Pattern = fmap absurd pat index pat' @@ -302,7 +306,11 @@ instance (Indexable a) => Indexable (C.Arg a) where when (C.argInfoOrigin argInfo == C.UserWritten) $ index x +#if MIN_VERSION_Agda(2,7,0) instance Indexable A.TacticAttribute +#else +instance (Indexable a) => Indexable (C.Ranged a) +#endif instance Indexable A.DefInfo where index = index . Info.defTactic @@ -391,10 +399,12 @@ instance Indexable A.RewriteEqn where tellDef bindName Param UnknownType index pat index expr +#if MIN_VERSION_Agda(2,7,0) C.LeftLet bindings -> forM_ bindings $ \(pat, expr) -> do index pat index expr +#endif instance Indexable A.RHS where index rhs = case rhs of @@ -556,18 +566,20 @@ instance Indexable A.Pragma where tellUsage name A.InjectivePragma name -> tellUsage name - A.InjectiveForInferencePragma name -> - tellUsage name A.InlinePragma _shouldInline name -> tellUsage name A.NotProjectionLikePragma name -> tellUsage name - A.OverlapPragma name _overlapMode -> - tellUsage name A.DisplayPragma name args displayExpr -> do tellUsage name indexNamedArgs name args index displayExpr +#if MIN_VERSION_Agda(2,7,0) + A.InjectiveForInferencePragma name -> + tellUsage name + A.OverlapPragma name _overlapMode -> + tellUsage name +#endif -------------------------------------------------------------------------------- diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index 1a261df..7be4f8e 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} @@ -26,6 +27,10 @@ import qualified Language.LSP.Server as LSP import Monad (ServerM, askModel, catchTCError, findAgdaLib) import qualified Server.Model as Model import Server.Model.Monad (WithAgdaFileM, WithAgdaLibM, runWithAgdaFileT, runWithAgdaLibT) +#if MIN_VERSION_Agda(2,7,0) +#else +import Agda.TypeChecking.Errors () +#endif tryTC :: ServerM a -> ServerM (Either TCM.TCErr a) tryTC handler = (Right <$> handler) `catchTCError` (return . Left) diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index 1290344..a6922a8 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -25,7 +25,6 @@ module Server.Model.Monad where import Agda.Interaction.Options (CommandLineOptions (optPragmaOptions), PragmaOptions) -import Agda.Interaction.Response (Response_boot (Resp_HighlightingInfo)) import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position (getRange) import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), MonadTrace, PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv (..), TCM, TCMT (..), TCState (stPersistentState), catchError_, modifyTCLens, setTCLens, stPragmaOptions, useTC, viewTC) @@ -54,6 +53,11 @@ import Prelude hiding (null) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.FileId (File, getIdFile) #endif +#if MIN_VERSION_Agda(2,7,0) +import Agda.Interaction.Response (Response_boot(Resp_HighlightingInfo)) +#else +import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) +#endif -------------------------------------------------------------------------------- From 58be9bd92e3022bccd813d14414437d25ce7f22b Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 15 Nov 2025 10:08:47 -0600 Subject: [PATCH 30/47] Broken library resolution unit tests --- test/Test.hs | 2 + test/Test/AgdaLibResolution.hs | 47 +++++++++++++++++++++++ test/data/libs/no-deps/no-deps.agda-lib | 2 + test/data/libs/no-deps/src/Constants.agda | 9 +++++ test/data/libs/no-deps/src/Data/Nat.agda | 5 +++ 5 files changed, 65 insertions(+) create mode 100644 test/Test/AgdaLibResolution.hs create mode 100644 test/data/libs/no-deps/no-deps.agda-lib create mode 100644 test/data/libs/no-deps/src/Constants.agda create mode 100644 test/data/libs/no-deps/src/Data/Nat.agda diff --git a/test/Test.hs b/test/Test.hs index b949f2c..f964065 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -15,6 +15,7 @@ import qualified Test.Indexer.Invariants as IndexerInvariants import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol import qualified Test.Uri as URI import qualified Test.Indexer as Indexer +import qualified Test.AgdaLibResolution as AgdaLibResolution -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -43,6 +44,7 @@ tests = do URI.tests, Model.tests, ModelMonad.tests, + AgdaLibResolution.tests, indexerTests #if defined(wasm32_HOST_ARCH) , WASM.tests alsPath diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs new file mode 100644 index 0000000..477cf60 --- /dev/null +++ b/test/Test/AgdaLibResolution.hs @@ -0,0 +1,47 @@ +module Test.AgdaLibResolution (tests) where + +import Agda.Syntax.Common.Pretty (prettyShow) +import Control.Monad.IO.Class (liftIO) +import Indexer (indexFile, usingSrcAsCurrent) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import Monad (runServerT) +import Server.Model.Monad (MonadAgdaLib (askAgdaLib), runWithAgdaLib) +import System.Directory (makeAbsolute) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) +import qualified TestData + +natPath, constPath :: FilePath +natPath = "test/data/libs/no-deps/src/Data/Nat.agda" +constPath = "test/data/libs/no-deps/src/Constants.agda" + +tests :: TestTree +tests = + testGroup + "Agda lib resolution" + [ testCase "Module without imports in lib without dependencies" $ do + model <- TestData.getModel + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib (LSP.filePathToUri natPath) $ do + natSrc <- TestData.parseSourceFromPath natPath + _ <- indexFile natSrc + return (), + testCase "Module with imports in lib without lib dependencies" $ do + model <- TestData.getModel + + absConstPath <- makeAbsolute constPath + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib (LSP.filePathToUri absConstPath) $ do + lib <- askAgdaLib + _ <- liftIO $ assertFailure $ prettyShow lib + constSrc <- TestData.parseSourceFromPath constPath + _ <- indexFile constSrc + return () + ] diff --git a/test/data/libs/no-deps/no-deps.agda-lib b/test/data/libs/no-deps/no-deps.agda-lib new file mode 100644 index 0000000..9970791 --- /dev/null +++ b/test/data/libs/no-deps/no-deps.agda-lib @@ -0,0 +1,2 @@ +name: no-deps +include: src diff --git a/test/data/libs/no-deps/src/Constants.agda b/test/data/libs/no-deps/src/Constants.agda new file mode 100644 index 0000000..699e243 --- /dev/null +++ b/test/data/libs/no-deps/src/Constants.agda @@ -0,0 +1,9 @@ +module Constants where + +open import Data.Nat + +one : Nat +one = suc zero + +two : Nat +two = suc one diff --git a/test/data/libs/no-deps/src/Data/Nat.agda b/test/data/libs/no-deps/src/Data/Nat.agda new file mode 100644 index 0000000..9ee2cba --- /dev/null +++ b/test/data/libs/no-deps/src/Data/Nat.agda @@ -0,0 +1,5 @@ +module Data.Nat where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat From 42a325f2998e06f06fdcc45b2f641cbf61cfbe8c Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 16 Nov 2025 17:16:55 -0600 Subject: [PATCH 31/47] agda lib search without fs --- agda-language-server.cabal | 14 +- package.yaml | 1 + src/Agda/Interaction/Library/Parse/More.hs | 288 ++++++++++++++++++ src/Language/LSP/Protocol/Types/Uri/More.hs | 23 ++ src/Monad.hs | 43 +-- src/Server/AgdaLibResolver.hs | 60 ++++ src/Server/Filesystem.hs | 198 ++++++++++++ .../Handler/TextDocument/FileManagement.hs | 35 ++- src/Server/Model/AgdaLib.hs | 46 +-- src/Server/Model/Handler.hs | 15 +- src/Server/Model/Monad.hs | 2 +- src/Server/VfsIndex.hs | 123 ++++++++ test/TestData.hs | 4 + 13 files changed, 772 insertions(+), 80 deletions(-) create mode 100644 src/Agda/Interaction/Library/Parse/More.hs create mode 100644 src/Server/AgdaLibResolver.hs create mode 100644 src/Server/Filesystem.hs create mode 100644 src/Server/VfsIndex.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 1190f0e..eefadc2 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -52,6 +52,7 @@ library Agda.Interaction.Imports.More Agda.Interaction.Imports.Virtual Agda.Interaction.Library.More + Agda.Interaction.Library.Parse.More Agda.IR Agda.Parser Agda.Position @@ -79,7 +80,9 @@ library Render.TypeChecking Render.Utils Server + Server.AgdaLibResolver Server.CommandController + Server.Filesystem Server.Handler Server.Handler.TextDocument.DocumentSymbol Server.Handler.TextDocument.FileManagement @@ -90,6 +93,7 @@ library Server.Model.Monad Server.Model.Symbol Server.ResponseController + Server.VfsIndex Switchboard other-modules: Paths_agda_language_server @@ -111,6 +115,7 @@ library , filepath , lsp >=2 , lsp-types >=2 + , modern-uri , mtl , network , network-simple ==0.4.2 @@ -158,6 +163,7 @@ executable als , filepath , lsp >=2 , lsp-types >=2 + , modern-uri , mtl , network , network-simple ==0.4.2 @@ -186,6 +192,7 @@ test-suite als-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Test.AgdaLibResolution Test.Indexer Test.Indexer.Invariants Test.Indexer.Invariants.NoDuplicateDecl @@ -205,6 +212,7 @@ test-suite als-test Agda.Interaction.Imports.More Agda.Interaction.Imports.Virtual Agda.Interaction.Library.More + Agda.Interaction.Library.Parse.More Agda.IR Agda.Parser Agda.Position @@ -232,7 +240,9 @@ test-suite als-test Render.TypeChecking Render.Utils Server + Server.AgdaLibResolver Server.CommandController + Server.Filesystem Server.Handler Server.Handler.TextDocument.DocumentSymbol Server.Handler.TextDocument.FileManagement @@ -243,6 +253,7 @@ test-suite als-test Server.Model.Monad Server.Model.Symbol Server.ResponseController + Server.VfsIndex Switchboard Paths_agda_language_server hs-source-dirs: @@ -265,6 +276,7 @@ test-suite als-test , lsp >=2 , lsp-test , lsp-types >=2 + , modern-uri , mtl , network , network-simple ==0.4.2 diff --git a/package.yaml b/package.yaml index b0fe8d9..2db68d3 100644 --- a/package.yaml +++ b/package.yaml @@ -62,6 +62,7 @@ dependencies: - filepath - lsp-types >= 2 - lsp >= 2 + - modern-uri - mtl - network - network-simple == 0.4.2 diff --git a/src/Agda/Interaction/Library/Parse/More.hs b/src/Agda/Interaction/Library/Parse/More.hs new file mode 100644 index 0000000..6ce0b64 --- /dev/null +++ b/src/Agda/Interaction/Library/Parse/More.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Adaptation of Agda.Interaction.Library.Parse +-- +-- Agda only exports functions which read from the filesystem, so we reproduce +-- and modify them here to interact with LSP filesystem abstractions. +module Agda.Interaction.Library.Parse.More + ( parseLibFile, + runP, + ) +where + +import Agda.Interaction.Library.Base +import Agda.Syntax.Position +import Agda.Utils.Applicative +import Agda.Utils.FileName +import Agda.Utils.IO (catchIO) +import qualified Agda.Utils.IO.UTF8 as UTF8 +import Agda.Utils.Lens +import Agda.Utils.List (duplicates) +import Agda.Utils.List1 (List1, toList) +import qualified Agda.Utils.List1 as List1 +import qualified Agda.Utils.Maybe.Strict as Strict +import Agda.Utils.Singleton +import Agda.Utils.String (ltrim) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Writer +import Data.Char +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import Monad (ServerM) +import qualified Server.Filesystem as FS +import System.FilePath + +-- | Parser monad: Can throw @LibParseError@s, and collects +-- @LibWarning'@s library warnings. +type P = ExceptT LibParseError (Writer [LibWarning']) + +runP :: P a -> (Either LibParseError a, [LibWarning']) +runP = runWriter . runExceptT + +warningP :: LibWarning' -> P () +warningP = tell . pure + +-- | The config files we parse have the generic structure of a sequence +-- of @field : content@ entries. +type GenericFile = [GenericEntry] + +data GenericEntry = GenericEntry + { -- | E.g. field name. @trim@med. + geHeader :: String, + -- | E.g. field content. @trim@med. + _geContent :: [String] + } + +-- | Library file field format format [sic!]. +data Field = forall a. Field + { -- | Name of the field. + fName :: String, + -- | Is it optional? + fOptional :: Bool, + -- | Content parser for this field. + -- + -- The range points to the start of the file. + fParse :: Range -> [String] -> P a, + -- | Sets parsed content in 'AgdaLibFile' structure. + fSet :: LensSet AgdaLibFile a + } + +optionalField :: + String -> (Range -> [String] -> P a) -> Lens' AgdaLibFile a -> Field +optionalField str p l = Field str True p (set l) + +-- | @.agda-lib@ file format with parsers and setters. +agdaLibFields :: [Field] +agdaLibFields = + -- Andreas, 2017-08-23, issue #2708, field "name" is optional. + [ optionalField "name" (\_ -> parseName) libName, + optionalField "include" (\_ -> pure . concatMap parsePaths) libIncludes, + optionalField "depend" (\_ -> pure . map parseLibName . concatMap splitCommas) libDepends, + optionalField "flags" (\r -> pure . foldMap (parseFlags r)) libPragmas + ] + where + parseName :: [String] -> P LibName + parseName [s] | [name] <- words s = pure $ parseLibName name + parseName ls = throwError $ BadLibraryName $ unwords ls + + parsePaths :: String -> [FilePath] + parsePaths = go id + where + fixup acc = let fp = acc [] in not (null fp) ?$> fp + go acc [] = fixup acc + go acc ('\\' : ' ' : cs) = go (acc . (' ' :)) cs + go acc ('\\' : '\\' : cs) = go (acc . ('\\' :)) cs + go acc (' ' : cs) = fixup acc ++ go id cs + go acc (c : cs) = go (acc . (c :)) cs + + parseFlags :: Range -> String -> OptionsPragma + parseFlags r s = + OptionsPragma + { pragmaStrings = words s, + pragmaRange = r + } + +-- | Parse @.agda-lib@ file. +-- +-- In the Agda implementation, this is where the path is set in AgdaLibFile. We +-- don't, since we don't really want to work with paths in the first place. +parseLibFile :: (FS.Provider p, FS.IsFileId f) => p -> f -> ServerM (Maybe (P AgdaLibFile)) +parseLibFile provider fileId = do + abs <- FS.fileIdToPossiblyInvalidAbsolutePath $ FS.toFileId fileId + contents <- FS.getFileContents provider fileId + case contents of + Nothing -> return Nothing + Just contents -> + return $ Just $ parseLib abs (Text.unpack contents) + +-- | Parse file contents. +parseLib :: + -- | The parsed file. + AbsolutePath -> + String -> + P AgdaLibFile +parseLib file s = fromGeneric file =<< parseGeneric s + +-- | Parse 'GenericFile' with 'agdaLibFields' descriptors. +fromGeneric :: + -- | The parsed file. + AbsolutePath -> + GenericFile -> + P AgdaLibFile +fromGeneric file = fromGeneric' file agdaLibFields + +-- | Given a list of 'Field' descriptors (with their custom parsers), +-- parse a 'GenericFile' into the 'AgdaLibFile' structure. +-- +-- Checks mandatory fields are present; +-- no duplicate fields, no unknown fields. +fromGeneric' :: + -- | The parsed file. + AbsolutePath -> + [Field] -> + GenericFile -> + P AgdaLibFile +fromGeneric' file fields fs = do + checkFields fields (map geHeader fs) + foldM upd emptyLibFile fs + where + -- The range points to the start of the file. + r = + Range + (Strict.Just $ mkRangeFile file Nothing) + (singleton (posToInterval () p p)) + where + p = + Pn + { srcFile = (), + posPos = 1, + posLine = 1, + posCol = 1 + } + + upd :: AgdaLibFile -> GenericEntry -> P AgdaLibFile + upd l (GenericEntry h cs) = do + mf <- findField h fields + case mf of + Just Field {..} -> do + x <- fParse r cs + return $ fSet x l + Nothing -> return l + +-- | Ensure that there are no duplicate fields and no mandatory fields are missing. +checkFields :: [Field] -> [String] -> P () +checkFields fields fs = do + -- Report missing mandatory fields. + () <- List1.unlessNull missing $ throwError . MissingFields + -- Report duplicate fields. + List1.unlessNull (duplicates fs) $ throwError . DuplicateFields + where + mandatory :: [String] + mandatory = [fName f | f <- fields, not $ fOptional f] + missing :: [String] + missing = mandatory List.\\ fs + +-- | Find 'Field' with given 'fName', throw error if unknown. +findField :: String -> [Field] -> P (Maybe Field) +findField s fs = maybe err (return . Just) $ List.find ((s ==) . fName) fs + where + err = warningP (UnknownField s) >> return Nothing + +-- Generic file parser ---------------------------------------------------- + +-- | Example: +-- +-- @ +-- parseGeneric "name:Main--BLA\ndepend:--BLA\n standard-library--BLA\ninclude : . --BLA\n src more-src \n" +-- == Right [("name",["Main"]),("depend",["standard-library"]),("include",[".","src more-src"])] +-- @ +parseGeneric :: String -> P GenericFile +parseGeneric s = + groupLines =<< concat <$> zipWithM parseLine [1 ..] (map stripComments $ lines s) + +-- | Lines with line numbers. +data GenericLine + = -- | Header line, like a field name, e.g. "include :". Cannot be indented. + -- @String@ is 'trim'med. + Header LineNumber String + | -- | Other line. Must be indented. + -- @String@ is 'trim'med. + Content LineNumber String + deriving (Show) + +-- | Parse line into 'Header' and 'Content' components. +-- +-- Precondition: line comments and trailing whitespace have been stripped away. +-- +-- Example file: +-- +-- @ +-- name: Main +-- depend: +-- standard-library +-- include: . +-- src more-src +-- @ +-- +-- This should give +-- +-- @ +-- [ Header 1 "name" +-- , Content 1 "Main" +-- , Header 2 "depend" +-- , Content 3 "standard-library" +-- , Header 4 "include" +-- , Content 4 "." +-- , Content 5 "src more-src" +-- ] +-- @ +parseLine :: LineNumber -> String -> P [GenericLine] +parseLine _ "" = pure [] +parseLine l s@(c : _) + -- Indented lines are 'Content'. + | isSpace c = pure [Content l $ ltrim s] + -- Non-indented lines are 'Header'. + | otherwise = + case break (== ':') s of + -- Headers are single words followed by a colon. + -- Anything after the colon that is not whitespace is 'Content'. + (h, ':' : r) -> + case words h of + [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')] + [] -> throwError $ MissingFieldName l + hs -> throwError $ BadFieldName l h + _ -> throwError $ MissingColonForField l (ltrim s) + +-- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'. +-- +-- Leading 'Content's? That's an error. +groupLines :: [GenericLine] -> P GenericFile +groupLines [] = pure [] +groupLines (Content l c : _) = throwError $ ContentWithoutField l +groupLines (Header _ h : ls) = (GenericEntry h [c | Content _ c <- cs] :) <$> groupLines ls1 + where + (cs, ls1) = span isContent ls + isContent Content {} = True + isContent Header {} = False + +-- | Remove leading whitespace and line comment. +trimLineComment :: String -> String +trimLineComment = stripComments . ltrim + +-- | Break a comma-separated string. Result strings are @trim@med. +splitCommas :: String -> [String] +splitCommas = words . map (\c -> if c == ',' then ' ' else c) + +-- | ...and trailing, but not leading, whitespace. +stripComments :: String -> String +stripComments "" = "" +stripComments ('-' : '-' : c : _) | isSpace c = "" +stripComments (c : s) = cons c (stripComments s) + where + cons c "" | isSpace c = "" + cons c s = c : s \ No newline at end of file diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index c428ecd..e22c81b 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -2,18 +2,24 @@ module Language.LSP.Protocol.Types.Uri.More ( getNormalizedUri, isUriAncestorOf, uriHeightAbove, + uriParent, + uriExtension, uriToPossiblyInvalidAbsolutePath, uriToPossiblyInvalidFilePath, ) where import Agda.Utils.FileName (AbsolutePath (AbsolutePath), absolute) +import Agda.Utils.Lens (set, (^.)) +import Agda.Utils.List (initMaybe, lastMaybe) import Agda.Utils.Maybe (fromMaybe) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import qualified Data.Text as Text import Language.LSP.Protocol.Types (uriToFilePath) import qualified Language.LSP.Protocol.Types as LSP +import qualified Text.URI as ParsedUri +import qualified Text.URI.Lens as ParsedUriLens getNormalizedUri :: LSP.NormalizedUri -> Text getNormalizedUri = LSP.getUri . LSP.fromNormalizedUri @@ -60,6 +66,23 @@ uriHeightAbove ancestor descendant = then 0 else Text.count "/" path + 1 +uriParent :: LSP.NormalizedUri -> Maybe LSP.NormalizedUri +uriParent uri = do + parsedUri <- ParsedUri.mkURI $ getNormalizedUri uri + pathInit <- initMaybe $ parsedUri ^. ParsedUriLens.uriPath + let newParsedUri = set ParsedUriLens.uriPath pathInit parsedUri + return $ LSP.toNormalizedUri $ LSP.Uri $ ParsedUri.render newParsedUri + +uriExtension :: LSP.NormalizedUri -> Text +uriExtension uri = fromMaybe "" $ do + parsedUri <- ParsedUri.mkURI $ getNormalizedUri uri + pathEndRefined <- lastMaybe $ parsedUri ^. ParsedUriLens.uriPath + let pathEnd = ParsedUri.unRText pathEndRefined + let (prefix, suffix) = Text.breakOnEnd "." pathEnd + if Text.null prefix -- The prefix will contain the final ".", if one is found + then Nothing + else return $ "." <> suffix + uriToPossiblyInvalidAbsolutePath :: (MonadIO m) => LSP.NormalizedUri -> m AbsolutePath uriToPossiblyInvalidAbsolutePath uri = do case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of diff --git a/src/Monad.hs b/src/Monad.hs index e837de0..d3efe02 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} module Monad where @@ -37,11 +38,15 @@ import qualified Language.LSP.Server as LSP import Options import Server.CommandController (CommandController) import qualified Server.CommandController as CommandController +import Server.Filesystem (MonadFilesystem) +import qualified Server.Filesystem as FS import Server.Model (Model) import qualified Server.Model as Model -import Server.Model.AgdaLib (AgdaLib, agdaLibFromFs, initAgdaLib) +import Server.Model.AgdaLib (AgdaLib, initAgdaLib) import Server.ResponseController (ResponseController) import qualified Server.ResponseController as ResponseController +import Server.VfsIndex (VfsIndex) +import qualified Server.VfsIndex as VfsIndex import System.FilePath (takeDirectory) -------------------------------------------------------------------------------- @@ -54,6 +59,8 @@ data Env = Env envCommandController :: CommandController, envResponseChan :: Chan Response, envResponseController :: ResponseController, + envFilesystemProvider :: !FS.Layered, + envVfsIndex :: !(IORef VfsIndex), envModel :: !(IORef Model) } @@ -65,6 +72,8 @@ createInitEnv options = <*> liftIO CommandController.new <*> liftIO newChan <*> liftIO ResponseController.new + <*> (pure $ FS.Layered [FS.Wrap FS.LspVirtualFilesystem, FS.Wrap FS.OsFilesystem]) + <*> liftIO (newIORef VfsIndex.empty) <*> liftIO (newIORef Model.empty) -------------------------------------------------------------------------------- @@ -77,6 +86,9 @@ type ServerM = ServerT (LspM Config) runServerT :: Env -> ServerT m a -> m a runServerT = flip runReaderT +instance MonadFilesystem ServerM where + askVfsIndex = askVfsIndex + -------------------------------------------------------------------------------- writeLog :: (Monad m, MonadIO m) => Text -> ServerT m () @@ -89,6 +101,9 @@ writeLog' x = do chan <- asks envLogChan liftIO $ writeChan chan $ pack $ show x +askFilesystemProvider :: (MonadIO m) => ServerT m FS.Layered +askFilesystemProvider = asks envFilesystemProvider + askModel :: (MonadIO m) => ServerT m Model askModel = do modelVar <- asks envModel @@ -99,23 +114,15 @@ modifyModel f = do modelVar <- asks envModel liftIO $ modifyIORef' modelVar f --- | Find cached 'AgdaLib', or else make one from @.agda-lib@ files on the file --- system, or else provide a default -findAgdaLib :: (MonadIO m) => LSP.NormalizedUri -> ServerT m AgdaLib -findAgdaLib uri = do - model <- askModel - case Model.getKnownAgdaLib uri model of - Just lib -> return lib - Nothing -> do - lib <- case LSP.uriToFilePath $ LSP.fromNormalizedUri uri of - Just path -> do - lib <- agdaLibFromFs $ takeDirectory path - case lib of - Just lib -> return lib - Nothing -> initAgdaLib - Nothing -> initAgdaLib - modifyModel $ Model.withAgdaLib lib - return lib +askVfsIndex :: (MonadIO m) => ServerT m VfsIndex +askVfsIndex = do + vfsIndexVar <- asks envVfsIndex + liftIO $ readIORef vfsIndexVar + +modifyVfsIndex :: (MonadIO m) => (VfsIndex -> VfsIndex) -> ServerT m () +modifyVfsIndex f = do + vfsIndexVar <- asks envVfsIndex + liftIO $ modifyIORef' vfsIndexVar f catchTCError :: ServerM a -> (TCM.TCErr -> ServerM a) -> ServerM a catchTCError m h = diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs new file mode 100644 index 0000000..8bea1c2 --- /dev/null +++ b/src/Server/AgdaLibResolver.hs @@ -0,0 +1,60 @@ +module Server.AgdaLibResolver (findAgdaLib) where + +import Agda.Interaction.Library (AgdaLibFile) +import Agda.Interaction.Library.Parse.More (parseLibFile, runP) +import Agda.Utils.Either (maybeRight) +import Agda.Utils.Maybe (caseMaybe, ifJust, listToMaybe) +import qualified Language.LSP.Protocol.Types as LSP +import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) +import qualified Server.Filesystem as FS +import qualified Server.Model as Model +import Server.Model.AgdaLib (AgdaLib, agdaLibFromFile, initAgdaLib) + +-- | Find cached 'AgdaLib', or else make one from @.agda-lib@ files on the file +-- system, or else provide a default +findAgdaLib :: LSP.NormalizedUri -> ServerM AgdaLib +findAgdaLib uri = do + model <- askModel + case Model.getKnownAgdaLib uri model of + Just lib -> return lib + Nothing -> do + provider <- askFilesystemProvider + result <- searchFilesystemForAgdaLib provider uri + lib <- case result of + Just lib -> return lib + Nothing -> initAgdaLib + modifyModel $ Model.withAgdaLib lib + return lib + +searchFilesystemForAgdaLib :: (FS.Provider p, FS.IsFileId f) => p -> f -> ServerM (Maybe AgdaLib) +searchFilesystemForAgdaLib provider agdaIsFileId = do + let agdaFileId = FS.toFileId agdaIsFileId + libFileId <- searchForAgdaLibFile provider agdaFileId + case libFileId of + Nothing -> return Nothing + Just fileId -> do + agdaLibFile <- fileIdToAgdaLibFile provider fileId + case agdaLibFile of + Nothing -> return Nothing + Just agdaLibFile -> do + agdaLib <- agdaLibFromFile agdaLibFile + return $ Just agdaLib + where + searchForAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe FS.FileId) + searchForAgdaLibFile provider childFileId = do + parentFileId <- FS.fileIdParent childFileId + caseMaybe parentFileId (return Nothing) $ \parentFileId -> do + children <- FS.getChildren provider parentFileId + let candidates = filter (\child -> FS.fileIdExtension child == ".agda-lib") children + case listToMaybe candidates of + Nothing -> searchForAgdaLibFile provider parentFileId + Just candidate -> return $ Just candidate + + fileIdToAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe AgdaLibFile) + fileIdToAgdaLibFile provider fileId = do + agdaLibFile <- parseLibFile provider fileId + case agdaLibFile of + Nothing -> return Nothing + Just agdaLibFile -> do + let (result, _warnings) = runP agdaLibFile + return $ maybeRight result diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs new file mode 100644 index 0000000..f59106e --- /dev/null +++ b/src/Server/Filesystem.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Server.Filesystem + ( FileId, + fileIdToPossiblyInvalidAbsolutePath, + fileIdParent, + fileIdExtension, + IsFileId (..), + MonadFilesystem (..), + Provider, + getFileContents, + getChildren, + LspVirtualFilesystem (..), + OsFilesystem (..), + ProviderWrapper (..), + Layered (..), + ) +where + +import Agda.Utils.Either (maybeRight) +import Agda.Utils.FileName (AbsolutePath, absolute, sameFile) +import Agda.Utils.IO (catchIO) +import Agda.Utils.IO.UTF8 (ReadException, readTextFile) +import Agda.Utils.List (nubM) +import Agda.Utils.Monad (foldM, forM) +import Control.Exception (try, tryJust) +import qualified Control.Exception as E +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Strict as Strict +import Data.Text (Text) +import qualified Data.Text as Text +import Language.LSP.Protocol.Types (NormalizedUri) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Types.Uri.More as LSP +import Language.LSP.Server (MonadLsp) +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS +import Options (Config) +import Server.VfsIndex (VfsIndex, getEntry, getEntryChildren) +import System.Directory (canonicalizePath, getDirectoryContents) +import System.FilePath (takeExtension, ()) +import System.IO.Error (isPermissionError) + +data FileId + = Uri !LSP.NormalizedUri + | LocalFilePath !FilePath + +referToSameFile :: FileId -> FileId -> IO Bool +referToSameFile a b = + case (tryFileIdToFilePath a, tryFileIdToFilePath b) of + (Just a, Just b) -> do + absA <- absolute a + absB <- absolute b + sameFile absA absB + (Just _, Nothing) -> return False + (Nothing, Just _) -> return False + (Nothing, Nothing) -> do + let uriA = fileIdToUri a + let uriB = fileIdToUri b + return $ uriA == uriB + +fileIdToUri :: FileId -> LSP.NormalizedUri +fileIdToUri = \case + Uri uri -> uri + LocalFilePath filePath -> LSP.toNormalizedUri $ LSP.filePathToUri filePath + +tryFileIdToFilePath :: FileId -> Maybe FilePath +tryFileIdToFilePath = \case + Uri uri -> LSP.uriToFilePath $ LSP.fromNormalizedUri uri + LocalFilePath filePath -> Just filePath + +fileIdToPossiblyInvalidAbsolutePath :: (MonadIO m) => FileId -> m AbsolutePath +fileIdToPossiblyInvalidAbsolutePath (Uri uri) = LSP.uriToPossiblyInvalidAbsolutePath uri +fileIdToPossiblyInvalidAbsolutePath (LocalFilePath path) = liftIO $ absolute path + +fileIdParent :: (MonadIO m) => FileId -> m (Maybe FileId) +fileIdParent (Uri uri) = return $ Uri <$> LSP.uriParent uri +fileIdParent (LocalFilePath path) = do + -- Taken from Agda's findProjectConfig + up <- liftIO $ canonicalizePath $ path ".." + if up == path then return Nothing else return $ Just $ LocalFilePath up + +fileIdExtension :: FileId -> Text +fileIdExtension (Uri uri) = LSP.uriExtension uri +fileIdExtension (LocalFilePath path) = Text.pack $ takeExtension path + +class IsFileId a where + toFileId :: a -> FileId + +instance IsFileId FileId where + toFileId = id + +instance IsFileId LSP.Uri where + toFileId = Uri . LSP.toNormalizedUri + +instance IsFileId LSP.NormalizedUri where + toFileId = Uri + +instance IsFileId FilePath where + toFileId = LocalFilePath + +data File = File {fileContents :: !Text} + +-- | A monad where a filesystem provider can run. This is a bit of a hack. Its +-- capabilities are really just chosen to support the providers we need. We may +-- as well use 'ServerM', except that we would get circular dependencies when we +-- include a provider in its environment. +class (MonadLsp Config m) => MonadFilesystem m where + askVfsIndex :: m VfsIndex + +class Provider a where + getFileImpl :: (MonadFilesystem m) => a -> FileId -> m (Maybe File) + getChildrenImpl :: (MonadFilesystem m) => a -> FileId -> m [FileId] + +getFile :: (MonadFilesystem m, Provider a, IsFileId f) => a -> f -> m (Maybe File) +getFile provider fileId = getFileImpl provider (toFileId fileId) + +getFileContents :: (MonadFilesystem m, Provider a, IsFileId f) => a -> f -> m (Maybe Text) +getFileContents provider fileId = do + file <- getFile provider fileId + return $ fileContents <$> file + +getChildren :: (MonadFilesystem m, Provider a, IsFileId f) => a -> f -> m [FileId] +getChildren provider fileId = getChildrenImpl provider (toFileId fileId) + +data LspVirtualFilesystem = LspVirtualFilesystem + +instance Provider LspVirtualFilesystem where + getFileImpl _provider fileId = do + let uri = fileIdToUri fileId + vfile <- LSP.getVirtualFile uri + case vfile of + Nothing -> return Nothing + Just vfile -> do + let contents = VFS.virtualFileText vfile + return $ Just $ File contents + + getChildrenImpl _provider parent = do + let uri = fileIdToUri parent + vfsIndex <- askVfsIndex + let children = concat $ getEntryChildren <$> getEntry uri vfsIndex + return $ Uri <$> children + +data OsFilesystem = OsFilesystem + +instance Provider OsFilesystem where + getFileImpl _provider fileId = + case tryFileIdToFilePath fileId of + Nothing -> return Nothing + Just filePath -> do + let result :: IO (Either ReadException File) + result = try $ do + contents <- Strict.toStrict <$> readTextFile filePath + return $ File contents + liftIO $ maybeRight <$> result + + getChildrenImpl _provider parent = + case tryFileIdToFilePath parent of + Nothing -> return [] + Just parent -> + liftIO + $ (flip catchIO) + (\e -> if isPermissionError e then return [] else E.throwIO e) + $ do + children <- liftIO $ getDirectoryContents parent + return $ LocalFilePath <$> children + +-- TODO: Proper WASM support probably means custom extensions of LSP for +-- filesystem access. When/if these are implemented, they should get a provider +-- here. Include the provider in the default provider instance when running WASM +-- with whatever client the custom extension is for, and hopefully it should all +-- Just Work. + +data ProviderWrapper = forall a. (Provider a) => Wrap a + +instance Provider ProviderWrapper where + getFileImpl (Wrap provider) = getFileImpl provider + + getChildrenImpl (Wrap provider) = getChildrenImpl provider + +data Layered = Layered {layeredProviders :: ![ProviderWrapper]} + +instance Provider Layered where + getFileImpl (Layered providers) fileId = do + let results = flip getFileImpl fileId <$> providers + foldM + ( \file candidate -> case file of + Just _ -> return file + Nothing -> candidate + ) + Nothing + results + + getChildrenImpl (Layered providers) fileId = do + allChildren <- forM providers $ \provider -> getChildrenImpl provider fileId + liftIO $ nubM referToSameFile (concat allChildren) diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index aa5fb7c..a060328 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -21,25 +21,32 @@ import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS -import Monad (ServerM, modifyModel) +import Monad (ServerM, modifyModel, modifyVfsIndex) import qualified Server.Model as Model -import Server.Model.Handler (notificationHandlerWithAgdaLib) +import Server.Model.Handler (notificationHandlerWithAgdaLib, takeOverNotificationHandlerWithAgdaLib) +import qualified Server.VfsIndex as VFSIndex +import qualified Server.VfsIndex as VfsIndex didOpenHandler :: LSP.Handlers ServerM -didOpenHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidOpen $ \uri notification -> do - vfile <- lift $ LSP.getVirtualFile uri - case vfile of - Nothing -> return () - Just vfile -> do - vSourceFile <- vSrcFromUri uri vfile - src <- parseVSource vSourceFile - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src - agdaFile <- indexFile src - lift $ modifyModel $ Model.setAgdaFile uri agdaFile +didOpenHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidOpen $ \notification -> do + let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + modifyVfsIndex $ VfsIndex.onOpen uri + takeOverNotificationHandlerWithAgdaLib notification $ \uri notification -> do + vfile <- lift $ LSP.getVirtualFile uri + case vfile of + Nothing -> return () + Just vfile -> do + vSourceFile <- vSrcFromUri uri vfile + src <- parseVSource vSourceFile + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src + agdaFile <- indexFile src + lift $ modifyModel $ Model.setAgdaFile uri agdaFile didCloseHandler :: LSP.Handlers ServerM -didCloseHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidClose $ \uri notification -> do - lift $ modifyModel $ Model.deleteAgdaFile uri +didCloseHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidClose $ \notification -> do + let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + modifyVfsIndex $ VFSIndex.onClose uri + modifyModel $ Model.deleteAgdaFile $ LSP.toNormalizedUri uri didSaveHandler :: LSP.Handlers ServerM didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \uri notification -> do diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index 9589de6..8c06f57 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -8,7 +8,7 @@ module Server.Model.AgdaLib agdaLibTcStateRef, agdaLibTcEnv, isAgdaLibForUri, - agdaLibFromFs, + agdaLibFromFile, agdaLibToFile, ) where @@ -18,19 +18,8 @@ import Agda.Interaction.Library ( findProjectRoot, LibName, OptionsPragma (OptionsPragma), -#if MIN_VERSION_Agda(2,8,0) - getAgdaLibFile, -#else - getAgdaLibFiles', -#endif - ) -import Agda.Interaction.Library.More ( - tryRunLibM, -#if MIN_VERSION_Agda(2,8,0) -#else - runLibErrorIO, -#endif ) +import Agda.Interaction.Library.More (tryRunLibM) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (IORef, newIORef) import Agda.Utils.Lens (Lens', (<&>), (^.), set) @@ -106,37 +95,6 @@ agdaLibOrigin f a = f (_agdaLibOrigin a) <&> \x -> a {_agdaLibOrigin = x} isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) --- | Get an 'AgdaLib' from @.agda-lib@ files on the filesystem. These files are --- searched for by traversing parent directories until one is found. -agdaLibFromFs :: - (MonadIO m) => - -- | Directory to start the search from - FilePath -> - m (Maybe AgdaLib) -agdaLibFromFs path = do - root <- tryRunLibM $ findProjectRoot path - case root of - Just (Just root) -> do - libFile <- tryGetLibFileFromRootPath root - case libFile of - Just libFile -> Just <$> agdaLibFromFile libFile - Nothing -> return Nothing - _noRoot -> return Nothing - --- TODO: this traverses the filesystem -tryGetLibFileFromRootPath :: (MonadIO m) => FilePath -> m (Maybe AgdaLibFile) -#if MIN_VERSION_Agda(2,8,0) -tryGetLibFileFromRootPath root = do - maybeLibFiles <- tryRunLibM $ getAgdaLibFile root - case maybeLibFiles of - Just (libFile:_) -> return $ Just libFile - _ -> return Nothing -#else -tryGetLibFileFromRootPath root = do - libFiles <- runLibErrorIO $ getAgdaLibFiles' root - return $ listToMaybe libFiles -#endif - agdaLibFromFile :: (MonadIO m) => AgdaLibFile -> m AgdaLib agdaLibFromFile agdaLibFile = do let includes = LSP.toNormalizedUri . LSP.filePathToUri <$> agdaLibFile ^. libIncludes diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index 7be4f8e..1fe8101 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -7,6 +7,7 @@ module Server.Model.Handler ( notificationHandlerWithAgdaLib, + takeOverNotificationHandlerWithAgdaLib, requestHandlerWithAgdaFile, ) where @@ -24,9 +25,11 @@ import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Message as Lsp import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Monad (ServerM, askModel, catchTCError, findAgdaLib) +import Monad (ServerM, askModel, catchTCError) +import Server.AgdaLibResolver (findAgdaLib) import qualified Server.Model as Model import Server.Model.Monad (WithAgdaFileM, WithAgdaLibM, runWithAgdaFileT, runWithAgdaLibT) +import qualified Server.Model.Monad as LSP #if MIN_VERSION_Agda(2,7,0) #else import Agda.TypeChecking.Errors () @@ -46,7 +49,15 @@ notificationHandlerWithAgdaLib :: LSP.SMethod m -> NotificationHandlerWithAgdaLib m -> LSP.Handlers ServerM -notificationHandlerWithAgdaLib m handlerWithAgdaLib = LSP.notificationHandler m $ \notification -> do +notificationHandlerWithAgdaLib m handlerWithAgdaLib = + LSP.notificationHandler m $ flip takeOverNotificationHandlerWithAgdaLib handlerWithAgdaLib + +takeOverNotificationHandlerWithAgdaLib :: + (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => + LSP.TNotificationMessage m -> + NotificationHandlerWithAgdaLib m -> + ServerM () +takeOverNotificationHandlerWithAgdaLib notification handlerWithAgdaLib = do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri agdaLib <- findAgdaLib normUri diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index a6922a8..0d88f5f 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -44,7 +44,7 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP -import Monad (ServerM, ServerT, askModel, catchTCError, findAgdaLib) +import Monad (ServerM, ServerT, askModel, catchTCError) import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) diff --git a/src/Server/VfsIndex.hs b/src/Server/VfsIndex.hs new file mode 100644 index 0000000..e5a4de3 --- /dev/null +++ b/src/Server/VfsIndex.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DataKinds #-} + +module Server.VfsIndex + ( Entry, + getEntryChildren, + VfsIndex, + empty, + onOpen, + onClose, + getEntry, + ) +where + +import Agda.Utils.Functor ((<&>)) +import Agda.Utils.List1 (NonEmpty ((:|))) +import Agda.Utils.Maybe (maybeToList) +import Data.List (delete, union) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Types.Uri.More as LSP +import qualified Text.URI as ParsedUri + +data Entry = Entry + { _children :: ![ParsedUri.URI], + _isInVfs :: !Bool + } + +instance Semigroup Entry where + (Entry childrenA isInVfsA) <> (Entry childrenB isInVfsB) = Entry (union childrenA childrenB) (isInVfsA || isInVfsB) + +getEntryChildren :: Entry -> [LSP.NormalizedUri] +getEntryChildren = fmap (LSP.toNormalizedUri . LSP.Uri . ParsedUri.render) . _children + +-- | The index allows users to traverse the VFS like a tree. We infer an entry +-- for each "directory" which ultimately contains actual VFS entries. +-- For example, say the VFS contains files with the following URIs: +-- - @file:\/\/\/a\/b\/c.agda@ +-- - @file:\/\/\/a\/.agda-lib@ +-- +-- The index would store entries for the following URIs: +-- - @file:\/\/@ +-- - @file:\/\/\/a@ +-- - @file:\/\/\/a\/b@ +-- - @file:\/\/\/a\/b\/c.agda@ +-- - @file:\/\/\/a\/.agda-lib@ +data VfsIndex = VfsIndex (Map ParsedUri.URI Entry) + +empty :: VfsIndex +empty = VfsIndex Map.empty + +onOpen :: LSP.Uri -> VfsIndex -> VfsIndex +onOpen uri vfsIndex = + case ParsedUri.mkURI $ LSP.getNormalizedUri $ LSP.toNormalizedUri uri of + Nothing -> vfsIndex -- TODO: log this as an error + Just uri -> + let entryUris = dice uri + entries = + zip entryUris (True : repeat False) + <&> \(uri, isInVfs) -> (uri, Entry (maybeToList $ chop uri) isInVfs) + in foldl' (\vfsIndex (uri, entry) -> insertEntry uri entry vfsIndex) vfsIndex entries + +onClose :: LSP.Uri -> VfsIndex -> VfsIndex +onClose uri vfsIndex = + case ParsedUri.mkURI $ LSP.getNormalizedUri $ LSP.toNormalizedUri uri of + Nothing -> vfsIndex -- TODO: log this as an error + Just uri -> removeEntryFromVfs uri vfsIndex + +getEntry :: LSP.NormalizedUri -> VfsIndex -> Maybe Entry +getEntry uri (VfsIndex map) = + case ParsedUri.mkURI $ LSP.getNormalizedUri uri of + Nothing -> Nothing + Just uri -> Map.lookup uri map + +insertEntry :: ParsedUri.URI -> Entry -> VfsIndex -> VfsIndex +insertEntry uri entry (VfsIndex map) = VfsIndex $ Map.insertWith (<>) uri entry map + +removeEntryFromVfs :: ParsedUri.URI -> VfsIndex -> VfsIndex +removeEntryFromVfs uri (VfsIndex map) = deleteIfInvalidLeaf uri $ VfsIndex $ Map.adjust (\entry -> entry {_isInVfs = False}) uri map + +updateParentAfterDelete :: ParsedUri.URI -> VfsIndex -> VfsIndex +updateParentAfterDelete childUri vfsIndex@(VfsIndex map) = + case chop childUri of + Nothing -> vfsIndex + Just parentUri -> + deleteIfInvalidLeaf parentUri $ + VfsIndex $ + Map.adjust (\entry -> entry {_children = delete childUri $ _children entry}) parentUri map + +isValidLeaf :: Entry -> Bool +isValidLeaf entry = _isInVfs entry || not (null (_children entry)) + +deleteIfInvalidLeaf :: ParsedUri.URI -> VfsIndex -> VfsIndex +deleteIfInvalidLeaf uri vfsIndex@(VfsIndex map) = + case Map.lookup uri map of + Just entry + | not (isValidLeaf entry) -> + updateParentAfterDelete uri $ VfsIndex $ Map.delete uri map + _ -> vfsIndex + +dice :: ParsedUri.URI -> [ParsedUri.URI] +dice uri = uri : concat (dice <$> chop uri) + +chop :: ParsedUri.URI -> Maybe ParsedUri.URI +chop (ParsedUri.URI scheme authority path query (Just _fragment)) = + Just $ ParsedUri.URI scheme authority path query Nothing +chop (ParsedUri.URI scheme authority path query@(_ : _) Nothing) = + Just $ ParsedUri.URI scheme authority path (init query) Nothing +chop (ParsedUri.URI scheme authority path@(Just _) [] Nothing) = + Just $ ParsedUri.URI scheme authority (chopPath path) [] Nothing +chop (ParsedUri.URI scheme authority@(Right _) Nothing [] Nothing) = + Just $ ParsedUri.URI scheme (Left True) Nothing [] Nothing +chop (ParsedUri.URI scheme@(Just _) authority@(Left _) Nothing [] Nothing) = + Just $ ParsedUri.URI Nothing authority Nothing [] Nothing +chop (ParsedUri.URI Nothing authority@(Left _) Nothing [] Nothing) = Nothing + +type Path = Maybe (Bool, NonEmpty (ParsedUri.RText 'ParsedUri.PathPiece)) + +chopPath :: Path -> Path +chopPath (Just (True, parts)) = Just (False, parts) +chopPath (Just (False, part :| parts@(_ : _))) = Just (False, part :| init parts) +chopPath (Just (False, part :| [])) = Nothing +chopPath Nothing = Nothing diff --git a/test/TestData.hs b/test/TestData.hs index 30da455..a2fcae4 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -51,6 +51,8 @@ import System.FilePath (takeBaseName, ()) import Agda.TypeChecking.Pretty (prettyTCM) import Data.Text (Text) import Agda.Interaction.Imports.Virtual (parseSourceFromContents) +import qualified Server.Filesystem as FS +import qualified Server.VfsIndex as VfsIndex data AgdaFileDetails = AgdaFileDetails { fileName :: String, @@ -183,4 +185,6 @@ getServerEnv model = <*> liftIO CommandController.new <*> liftIO newChan <*> liftIO ResponseController.new + <*> (pure $ FS.Layered [FS.Wrap FS.LspVirtualFilesystem, FS.Wrap FS.OsFilesystem]) + <*> liftIO (newIORef VfsIndex.empty) <*> liftIO (newIORef model) From 919a563a8b77da2902351f6530fb3aa7c4b128d4 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 16 Nov 2025 18:47:01 -0600 Subject: [PATCH 32/47] fix getChildrenImpl for os --- src/Language/LSP/Protocol/Types/Uri/More.hs | 1 + src/Server/AgdaLibResolver.hs | 8 +++--- src/Server/Filesystem.hs | 28 +++++++++++++++------ test/Test/AgdaLibResolution.hs | 16 +++++++----- test/TestData.hs | 2 +- 5 files changed, 37 insertions(+), 18 deletions(-) diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index e22c81b..f5823d0 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -14,6 +14,7 @@ import Agda.Utils.Lens (set, (^.)) import Agda.Utils.List (initMaybe, lastMaybe) import Agda.Utils.Maybe (fromMaybe) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Function ((&)) import Data.Text (Text) import qualified Data.Text as Text import Language.LSP.Protocol.Types (uriToFilePath) diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs index 8bea1c2..1bc31c2 100644 --- a/src/Server/AgdaLibResolver.hs +++ b/src/Server/AgdaLibResolver.hs @@ -12,14 +12,16 @@ import Server.Model.AgdaLib (AgdaLib, agdaLibFromFile, initAgdaLib) -- | Find cached 'AgdaLib', or else make one from @.agda-lib@ files on the file -- system, or else provide a default -findAgdaLib :: LSP.NormalizedUri -> ServerM AgdaLib -findAgdaLib uri = do +findAgdaLib :: (FS.IsFileId f) => f -> ServerM AgdaLib +findAgdaLib isFileId = do + let fileId = FS.toFileId isFileId + let uri = FS.fileIdToUri fileId model <- askModel case Model.getKnownAgdaLib uri model of Just lib -> return lib Nothing -> do provider <- askFilesystemProvider - result <- searchFilesystemForAgdaLib provider uri + result <- searchFilesystemForAgdaLib provider fileId lib <- case result of Just lib -> return lib Nothing -> initAgdaLib diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs index f59106e..711f647 100644 --- a/src/Server/Filesystem.hs +++ b/src/Server/Filesystem.hs @@ -4,6 +4,7 @@ module Server.Filesystem ( FileId, + fileIdToUri, fileIdToPossiblyInvalidAbsolutePath, fileIdParent, fileIdExtension, @@ -39,8 +40,8 @@ import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS import Options (Config) import Server.VfsIndex (VfsIndex, getEntry, getEntryChildren) -import System.Directory (canonicalizePath, getDirectoryContents) -import System.FilePath (takeExtension, ()) +import System.Directory (canonicalizePath, doesDirectoryExist, getDirectoryContents) +import System.FilePath (takeDirectory, takeExtension, ()) import System.IO.Error (isPermissionError) data FileId @@ -78,9 +79,19 @@ fileIdToPossiblyInvalidAbsolutePath (LocalFilePath path) = liftIO $ absolute pat fileIdParent :: (MonadIO m) => FileId -> m (Maybe FileId) fileIdParent (Uri uri) = return $ Uri <$> LSP.uriParent uri fileIdParent (LocalFilePath path) = do - -- Taken from Agda's findProjectConfig - up <- liftIO $ canonicalizePath $ path ".." - if up == path then return Nothing else return $ Just $ LocalFilePath up + isDir <- liftIO $ doesDirectoryExist path + if isDir + then liftIO $ dirParent path + else return $ fileParent path + where + -- Taken from Agda's findProjectConfig + dirParent :: FilePath -> IO (Maybe FileId) + dirParent dirPath = do + up <- canonicalizePath $ path ".." + if up == path then return Nothing else return $ Just $ LocalFilePath up + + fileParent :: FilePath -> Maybe FileId + fileParent filePath = Just $ LocalFilePath $ takeDirectory filePath fileIdExtension :: FileId -> Text fileIdExtension (Uri uri) = LSP.uriExtension uri @@ -150,7 +161,7 @@ instance Provider OsFilesystem where case tryFileIdToFilePath fileId of Nothing -> return Nothing Just filePath -> do - let result :: IO (Either ReadException File) + let result :: IO (Either E.IOException File) result = try $ do contents <- Strict.toStrict <$> readTextFile filePath return $ File contents @@ -164,8 +175,9 @@ instance Provider OsFilesystem where $ (flip catchIO) (\e -> if isPermissionError e then return [] else E.throwIO e) $ do - children <- liftIO $ getDirectoryContents parent - return $ LocalFilePath <$> children + relativeChildren <- liftIO $ getDirectoryContents parent + let absoluteChildren = fmap (\child -> parent child) relativeChildren + return $ LocalFilePath <$> absoluteChildren -- TODO: Proper WASM support probably means custom extensions of LSP for -- filesystem access. When/if these are implemented, they should get a provider diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index 477cf60..fe61da4 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -6,6 +6,7 @@ import Indexer (indexFile, usingSrcAsCurrent) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerT) +import Server.AgdaLibResolver (findAgdaLib) import Server.Model.Monad (MonadAgdaLib (askAgdaLib), runWithAgdaLib) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) @@ -38,10 +39,13 @@ tests = LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - runWithAgdaLib (LSP.filePathToUri absConstPath) $ do - lib <- askAgdaLib - _ <- liftIO $ assertFailure $ prettyShow lib - constSrc <- TestData.parseSourceFromPath constPath - _ <- indexFile constSrc - return () + lib <- findAgdaLib absConstPath + liftIO $ assertFailure $ prettyShow lib + + -- runWithAgdaLib (LSP.filePathToUri absConstPath) $ do + -- lib <- askAgdaLib + -- _ <- liftIO $ assertFailure $ prettyShow lib + -- constSrc <- TestData.parseSourceFromPath constPath + -- _ <- indexFile constSrc + -- return () ] diff --git a/test/TestData.hs b/test/TestData.hs index a2fcae4..b91006e 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -185,6 +185,6 @@ getServerEnv model = <*> liftIO CommandController.new <*> liftIO newChan <*> liftIO ResponseController.new - <*> (pure $ FS.Layered [FS.Wrap FS.LspVirtualFilesystem, FS.Wrap FS.OsFilesystem]) + <*> (pure $ FS.Layered [FS.Wrap FS.OsFilesystem]) <*> liftIO (newIORef VfsIndex.empty) <*> liftIO (newIORef model) From c6aa2760743b88cc29cb92b971965c6346361b7d Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 17 Nov 2025 20:38:06 -0600 Subject: [PATCH 33/47] Better lib resolution --- src/Agda/TypeChecking/Monad/Options/More.hs | 3 +- src/Server/AgdaLibResolver.hs | 2 +- src/Server/Filesystem.hs | 37 ++++++++++++++++- src/Server/Model/AgdaLib.hs | 46 ++++++++++++++------- test/Test/AgdaLibResolution.hs | 24 ++++++----- test/TestData.hs | 4 +- 6 files changed, 85 insertions(+), 31 deletions(-) diff --git a/src/Agda/TypeChecking/Monad/Options/More.hs b/src/Agda/TypeChecking/Monad/Options/More.hs index eba67cb..daf8b2d 100644 --- a/src/Agda/TypeChecking/Monad/Options/More.hs +++ b/src/Agda/TypeChecking/Monad/Options/More.hs @@ -10,6 +10,7 @@ import Agda.Utils.Lens ((^.)) import qualified Agda.Utils.List1 as List1 import Control.Monad.IO.Class (liftIO) import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) +import qualified Server.Filesystem as FS import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes) import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) import System.Directory (getCurrentDirectory) @@ -54,5 +55,5 @@ addDefaultLibrariesByLib agdaLib o | not (null $ optLibraries o) || not (optUseLibs o) = o | otherwise = do let libs = agdaLib ^. agdaLibDependencies - let incs = uriToPossiblyInvalidFilePath <$> agdaLib ^. agdaLibIncludes + let incs = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes o {optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs} diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs index 1bc31c2..187e06b 100644 --- a/src/Server/AgdaLibResolver.hs +++ b/src/Server/AgdaLibResolver.hs @@ -39,7 +39,7 @@ searchFilesystemForAgdaLib provider agdaIsFileId = do case agdaLibFile of Nothing -> return Nothing Just agdaLibFile -> do - agdaLib <- agdaLibFromFile agdaLibFile + agdaLib <- agdaLibFromFile agdaLibFile fileId return $ Just agdaLib where searchForAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe FS.FileId) diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs index 711f647..1f39e28 100644 --- a/src/Server/Filesystem.hs +++ b/src/Server/Filesystem.hs @@ -3,9 +3,10 @@ {-# LANGUAGE FlexibleInstances #-} module Server.Filesystem - ( FileId, + ( FileId (..), fileIdToUri, fileIdToPossiblyInvalidAbsolutePath, + fileIdRelativeTo, fileIdParent, fileIdExtension, IsFileId (..), @@ -20,11 +21,13 @@ module Server.Filesystem ) where +import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyShow) import Agda.Utils.Either (maybeRight) import Agda.Utils.FileName (AbsolutePath, absolute, sameFile) import Agda.Utils.IO (catchIO) import Agda.Utils.IO.UTF8 (ReadException, readTextFile) import Agda.Utils.List (nubM) +import Agda.Utils.Maybe (fromMaybe, maybe) import Agda.Utils.Monad (foldM, forM) import Control.Exception (try, tryJust) import qualified Control.Exception as E @@ -41,12 +44,21 @@ import qualified Language.LSP.VFS as VFS import Options (Config) import Server.VfsIndex (VfsIndex, getEntry, getEntryChildren) import System.Directory (canonicalizePath, doesDirectoryExist, getDirectoryContents) -import System.FilePath (takeDirectory, takeExtension, ()) +import System.FilePath (isAbsolute, takeDirectory, takeExtension, ()) import System.IO.Error (isPermissionError) +import qualified Text.URI as ParsedUri data FileId = Uri !LSP.NormalizedUri | LocalFilePath !FilePath + deriving (Eq) + +instance Pretty FileId where + pretty (Uri uri) = pretty $ LSP.getNormalizedUri uri + pretty (LocalFilePath path) = pretty path + +instance Show FileId where + show = prettyShow referToSameFile :: FileId -> FileId -> IO Bool referToSameFile a b = @@ -67,6 +79,9 @@ fileIdToUri = \case Uri uri -> uri LocalFilePath filePath -> LSP.toNormalizedUri $ LSP.filePathToUri filePath +fileIdToParsedUri :: FileId -> Maybe ParsedUri.URI +fileIdToParsedUri = ParsedUri.mkURI . LSP.getNormalizedUri . fileIdToUri + tryFileIdToFilePath :: FileId -> Maybe FilePath tryFileIdToFilePath = \case Uri uri -> LSP.uriToFilePath $ LSP.fromNormalizedUri uri @@ -76,6 +91,24 @@ fileIdToPossiblyInvalidAbsolutePath :: (MonadIO m) => FileId -> m AbsolutePath fileIdToPossiblyInvalidAbsolutePath (Uri uri) = LSP.uriToPossiblyInvalidAbsolutePath uri fileIdToPossiblyInvalidAbsolutePath (LocalFilePath path) = liftIO $ absolute path +fileIdIsAbsolute :: FileId -> Bool +fileIdIsAbsolute (Uri uri) = + maybe + True + ParsedUri.isPathAbsolute + (ParsedUri.mkURI (LSP.getNormalizedUri uri)) +fileIdIsAbsolute (LocalFilePath path) = isAbsolute path + +-- | Makes the first 'FileId' absolute, treating the second 'FileId' as the base +fileIdRelativeTo :: (MonadIO m) => FileId -> FileId -> m FileId +fileIdRelativeTo fileId _baseFileId | fileIdIsAbsolute fileId = return fileId +fileIdRelativeTo (LocalFilePath path) (LocalFilePath basePath) = fmap LocalFilePath . liftIO $ canonicalizePath $ basePath path +fileIdRelativeTo fileId baseFileId = fromMaybe (pure fileId) $ do + uri <- fileIdToParsedUri fileId + baseUri <- fileIdToParsedUri baseFileId + absUri <- uri `ParsedUri.relativeTo` baseUri + return $ return $ Uri $ LSP.toNormalizedUri $ LSP.Uri $ ParsedUri.render absUri + fileIdParent :: (MonadIO m) => FileId -> m (Maybe FileId) fileIdParent (Uri uri) = return $ Uri <$> LSP.uriParent uri fileIdParent (LocalFilePath path) = do diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index 8c06f57..f02dc85 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -1,12 +1,15 @@ {-# LANGUAGE CPP #-} module Server.Model.AgdaLib - ( AgdaLib (AgdaLib), + ( AgdaLibOrigin (..), + AgdaLib (AgdaLib), initAgdaLib, + agdaLibName, agdaLibIncludes, agdaLibDependencies, agdaLibTcStateRef, agdaLibTcEnv, + agdaLibOrigin, isAgdaLibForUri, agdaLibFromFile, agdaLibToFile, @@ -23,7 +26,7 @@ import Agda.Interaction.Library.More (tryRunLibM) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (IORef, newIORef) import Agda.Utils.Lens (Lens', (<&>), (^.), set) -import Agda.Utils.Maybe (listToMaybe) +import Agda.Utils.Maybe (listToMaybe, catMaybes) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Map (Map) import qualified Language.LSP.Protocol.Types as LSP @@ -33,12 +36,17 @@ import Agda.Interaction.Library.Base (libFile, LibName (..), libName, libInclude import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) import Agda.Utils.Null (empty) import Agda.Syntax.Common.Pretty (Pretty, pretty, vcat, prettyAssign, text, pshow, doubleQuotes, (<+>)) +import qualified Text.URI as ParsedUri +import qualified Data.Text as Text +import qualified Server.Filesystem as FS +import Agda.Utils.Monad (forM) -data AgdaLibOrigin = FromFile !FilePath | Defaulted deriving (Show) +data AgdaLibOrigin = FromFile !FS.FileId | Defaulted + deriving (Show, Eq) data AgdaLib = AgdaLib { _agdaLibName :: !LibName, - _agdaLibIncludes :: ![LSP.NormalizedUri], + _agdaLibIncludes :: ![FS.FileId], _agdaLibOptionsPragma :: !OptionsPragma, _agdaLibDependencies :: ![LibName], _agdaLibTcStateRef :: !(IORef TCM.TCState), @@ -52,7 +60,7 @@ instance Pretty AgdaLib where <+> doubleQuotes (pretty $ agdaLib ^. agdaLibName) <+> pshow (agdaLib ^. agdaLibOrigin) <+> text "includes:" - <+> pretty (LSP.getNormalizedUri <$> (agdaLib ^. agdaLibIncludes)) + <+> pretty (agdaLib ^. agdaLibIncludes) initAgdaLibWithOrigin :: (MonadIO m) => AgdaLibOrigin -> m AgdaLib initAgdaLibWithOrigin origin = do @@ -74,7 +82,7 @@ initAgdaLib = initAgdaLibWithOrigin Defaulted agdaLibName :: Lens' AgdaLib LibName agdaLibName f a = f (_agdaLibName a) <&> \x -> a {_agdaLibName = x} -agdaLibIncludes :: Lens' AgdaLib [LSP.NormalizedUri] +agdaLibIncludes :: Lens' AgdaLib [FS.FileId] agdaLibIncludes f a = f (_agdaLibIncludes a) <&> \x -> a {_agdaLibIncludes = x} agdaLibOptionsPragma :: Lens' AgdaLib OptionsPragma @@ -93,12 +101,19 @@ agdaLibOrigin :: Lens' AgdaLib AgdaLibOrigin agdaLibOrigin f a = f (_agdaLibOrigin a) <&> \x -> a {_agdaLibOrigin = x} isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool -isAgdaLibForUri agdaLib uri = any (`LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) - -agdaLibFromFile :: (MonadIO m) => AgdaLibFile -> m AgdaLib -agdaLibFromFile agdaLibFile = do - let includes = LSP.toNormalizedUri . LSP.filePathToUri <$> agdaLibFile ^. libIncludes - initAgdaLibWithOrigin (FromFile $ agdaLibFile ^. libFile) +isAgdaLibForUri agdaLib uri = any (\include -> FS.fileIdToUri include `LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) + +-- | Given an 'AgdaLibFile' and the URI of that file, create the +-- corresponding 'AgdaLib' +agdaLibFromFile :: (MonadIO m, FS.IsFileId f) => AgdaLibFile -> f -> m AgdaLib +agdaLibFromFile agdaLibFile agdaLibIsFileId = do + let agdaLibFileId = FS.toFileId agdaLibIsFileId + agdaLibParent <- FS.fileIdParent agdaLibFileId + let includeToAbsolute = case agdaLibParent of + Nothing -> return . FS.LocalFilePath + Just parent -> \include -> FS.LocalFilePath include `FS.fileIdRelativeTo` parent + includes <- forM (agdaLibFile ^. libIncludes) includeToAbsolute + initAgdaLibWithOrigin (FromFile agdaLibFileId) <&> set agdaLibName (agdaLibFile ^. libName) <&> set agdaLibIncludes includes <&> set agdaLibOptionsPragma (agdaLibFile ^. libPragmas) @@ -109,8 +124,9 @@ agdaLibFromFile agdaLibFile = do agdaLibToFile :: LSP.NormalizedUri -> AgdaLib -> Maybe AgdaLibFile agdaLibToFile relativeToUri agdaLib = case agdaLib ^. agdaLibOrigin of Defaulted -> Nothing - FromFile filePath -> - let includePaths = uriToPossiblyInvalidFilePath <$> agdaLib ^. agdaLibIncludes - uri = LSP.toNormalizedUri $ LSP.filePathToUri filePath + FromFile fileId -> + let includePaths = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes + uri = FS.fileIdToUri fileId above = LSP.uriHeightAbove uri relativeToUri + filePath = LSP.uriToPossiblyInvalidFilePath uri in Just $ AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index fe61da4..fcafd77 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -1,21 +1,27 @@ module Test.AgdaLibResolution (tests) where +import Agda.Interaction.Library (parseLibName) import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Utils.Lens ((^.)) import Control.Monad.IO.Class (liftIO) import Indexer (indexFile, usingSrcAsCurrent) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerT) import Server.AgdaLibResolver (findAgdaLib) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib), runWithAgdaLib) +import qualified Server.Filesystem as FS +import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName, agdaLibOrigin) +import Server.Model.Monad (MonadAgdaLib, askAgdaLib, runWithAgdaLib) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase) +import Test.Tasty.HUnit (testCase, (@?=)) import qualified TestData -natPath, constPath :: FilePath +natPath, constPath, agdaLibPath, srcPath :: FilePath natPath = "test/data/libs/no-deps/src/Data/Nat.agda" constPath = "test/data/libs/no-deps/src/Constants.agda" +agdaLibPath = "test/data/libs/no-deps/no-deps.agda-lib" +srcPath = "test/data/libs/no-deps/src" tests :: TestTree tests = @@ -35,17 +41,15 @@ tests = model <- TestData.getModel absConstPath <- makeAbsolute constPath + absAgdaLibPath <- makeAbsolute agdaLibPath + absSrcPath <- makeAbsolute srcPath LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do lib <- findAgdaLib absConstPath - liftIO $ assertFailure $ prettyShow lib - -- runWithAgdaLib (LSP.filePathToUri absConstPath) $ do - -- lib <- askAgdaLib - -- _ <- liftIO $ assertFailure $ prettyShow lib - -- constSrc <- TestData.parseSourceFromPath constPath - -- _ <- indexFile constSrc - -- return () + liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" + liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) + liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath] ] diff --git a/test/TestData.hs b/test/TestData.hs index b91006e..4766974 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -145,7 +145,7 @@ fakeUri = LSP.toNormalizedUri $ LSP.Uri "file:///home/user2/project/Test.agda" getModel :: IO Model getModel = do let includes1 = - LSP.toNormalizedUri . LSP.Uri + FS.Uri . LSP.toNormalizedUri . LSP.Uri <$> [ "file:///home/user/project1/", "file:///home/user2/project2/", "https://example.com/agda/" @@ -155,7 +155,7 @@ getModel = do <&> set agdaLibIncludes includes1 let includes2 = - LSP.toNormalizedUri . LSP.Uri + FS.Uri . LSP.toNormalizedUri . LSP.Uri <$> ["file:///home/user/project2/"] testLib2 <- initAgdaLib From 57c68f1f009702009da7259ff690427bfa452171 Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 17 Nov 2025 20:45:54 -0600 Subject: [PATCH 34/47] Now works cross Agda version --- src/Agda/Interaction/Library/Parse/More.hs | 9 +++++++++ src/Server/Filesystem.hs | 2 +- src/Server/Model/AgdaLib.hs | 2 +- test/Test/AgdaLibResolution.hs | 8 ++++++++ 4 files changed, 19 insertions(+), 2 deletions(-) diff --git a/src/Agda/Interaction/Library/Parse/More.hs b/src/Agda/Interaction/Library/Parse/More.hs index 6ce0b64..b8227f8 100644 --- a/src/Agda/Interaction/Library/Parse/More.hs +++ b/src/Agda/Interaction/Library/Parse/More.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -82,12 +83,20 @@ agdaLibFields = -- Andreas, 2017-08-23, issue #2708, field "name" is optional. [ optionalField "name" (\_ -> parseName) libName, optionalField "include" (\_ -> pure . concatMap parsePaths) libIncludes, +#if MIN_VERSION_Agda(2,8,0) optionalField "depend" (\_ -> pure . map parseLibName . concatMap splitCommas) libDepends, +#else + optionalField "depend" (\_ -> pure . concatMap splitCommas) libDepends, +#endif optionalField "flags" (\r -> pure . foldMap (parseFlags r)) libPragmas ] where parseName :: [String] -> P LibName +#if MIN_VERSION_Agda(2,8,0) parseName [s] | [name] <- words s = pure $ parseLibName name +#else + parseName [s] | [name] <- words s = pure name +#endif parseName ls = throwError $ BadLibraryName $ unwords ls parsePaths :: String -> [FilePath] diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs index 1f39e28..6b55725 100644 --- a/src/Server/Filesystem.hs +++ b/src/Server/Filesystem.hs @@ -28,9 +28,9 @@ import Agda.Utils.IO (catchIO) import Agda.Utils.IO.UTF8 (ReadException, readTextFile) import Agda.Utils.List (nubM) import Agda.Utils.Maybe (fromMaybe, maybe) -import Agda.Utils.Monad (foldM, forM) import Control.Exception (try, tryJust) import qualified Control.Exception as E +import Control.Monad (foldM, forM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Strict as Strict import Data.Text (Text) diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index f02dc85..a0f4aba 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -39,7 +39,7 @@ import Agda.Syntax.Common.Pretty (Pretty, pretty, vcat, prettyAssign, text, psho import qualified Text.URI as ParsedUri import qualified Data.Text as Text import qualified Server.Filesystem as FS -import Agda.Utils.Monad (forM) +import Control.Monad (forM) data AgdaLibOrigin = FromFile !FS.FileId | Defaulted deriving (Show, Eq) diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index fcafd77..432f05c 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE CPP #-} + module Test.AgdaLibResolution (tests) where +#if MIN_VERSION_Agda(2,8,0) import Agda.Interaction.Library (parseLibName) +#endif import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Lens ((^.)) import Control.Monad.IO.Class (liftIO) @@ -49,7 +53,11 @@ tests = runServerT env $ do lib <- findAgdaLib absConstPath +#if MIN_VERSION_Agda(2,8,0) liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" +#else + liftIO $ lib ^. agdaLibName @?= "no-deps" +#endif liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath] ] From 65614f189169e5f4765a7c79221eeaaa859e59de Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 17 Nov 2025 20:54:09 -0600 Subject: [PATCH 35/47] Actually use new lib resolution --- src/Server/Model/Monad.hs | 5 ++--- test/Test/AgdaLibResolution.hs | 36 ++++++++++++++++++++++------------ 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index 0d88f5f..e5459c8 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -55,6 +55,7 @@ import Agda.Utils.FileId (File, getIdFile) #endif #if MIN_VERSION_Agda(2,7,0) import Agda.Interaction.Response (Response_boot(Resp_HighlightingInfo)) +import Server.AgdaLibResolver (findAgdaLib) #else import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) #endif @@ -233,9 +234,7 @@ type WithAgdaLibM = WithAgdaLibT ServerM runWithAgdaLib :: LSP.Uri -> WithAgdaLibM a -> ServerM a runWithAgdaLib uri x = do - let normUri = LSP.toNormalizedUri uri - model <- askModel - agdaLib <- Model.getAgdaLib normUri model + agdaLib <- findAgdaLib uri runWithAgdaLibT agdaLib x instance (MonadIO m) => MonadAgdaLib (WithAgdaLibT m) where diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index 432f05c..457db09 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -15,7 +15,7 @@ import Monad (runServerT) import Server.AgdaLibResolver (findAgdaLib) import qualified Server.Filesystem as FS import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName, agdaLibOrigin) -import Server.Model.Monad (MonadAgdaLib, askAgdaLib, runWithAgdaLib) +import Server.Model.Monad (MonadAgdaLib, askAgdaLib, runWithAgdaLib, runWithAgdaLibT) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -31,17 +31,7 @@ tests :: TestTree tests = testGroup "Agda lib resolution" - [ testCase "Module without imports in lib without dependencies" $ do - model <- TestData.getModel - - LSP.runLspT undefined $ do - env <- TestData.getServerEnv model - runServerT env $ do - runWithAgdaLib (LSP.filePathToUri natPath) $ do - natSrc <- TestData.parseSourceFromPath natPath - _ <- indexFile natSrc - return (), - testCase "Module with imports in lib without lib dependencies" $ do + [ testCase "Explicit" $ do model <- TestData.getModel absConstPath <- makeAbsolute constPath @@ -59,5 +49,25 @@ tests = liftIO $ lib ^. agdaLibName @?= "no-deps" #endif liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) - liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath] + liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath], + testCase "Module without imports in lib without dependencies" $ do + model <- TestData.getModel + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib (LSP.filePathToUri natPath) $ do + natSrc <- TestData.parseSourceFromPath natPath + _ <- indexFile natSrc + return (), + testCase "Module with imports in lib without lib dependencies" $ do + model <- TestData.getModel + + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + runWithAgdaLib (LSP.filePathToUri constPath) $ do + constSrc <- TestData.parseSourceFromPath constPath + _ <- indexFile constSrc + return () ] From 56c220304758765adef8d8adcf153eaddb95a73b Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 17 Nov 2025 21:00:44 -0600 Subject: [PATCH 36/47] Really actually use new lib resolution --- src/Server/Model.hs | 6 ------ src/Server/Model/Handler.hs | 2 +- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Server/Model.hs b/src/Server/Model.hs index 8ed9001..bf8fab6 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -2,7 +2,6 @@ module Server.Model ( Model (Model), empty, getKnownAgdaLib, - getAgdaLib, withAgdaLib, getAgdaFile, setAgdaFile, @@ -37,11 +36,6 @@ agdaFiles f a = f (_modelAgdaFiles a) <&> \x -> a {_modelAgdaFiles = x} getKnownAgdaLib :: LSP.NormalizedUri -> Model -> Maybe AgdaLib getKnownAgdaLib uri = find (`isAgdaLibForUri` uri) . _modelAgdaLibs --- | Get the Agda library for the given URI if known. Otherwise, get a generic --- default Agda library. -getAgdaLib :: (MonadIO m) => LSP.NormalizedUri -> Model -> m AgdaLib -getAgdaLib uri = maybe initAgdaLib return . getKnownAgdaLib uri - -- | Add an 'AgdaLib' to the model withAgdaLib :: AgdaLib -> Model -> Model withAgdaLib lib model = model {_modelAgdaLibs = lib : _modelAgdaLibs model} diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index 1fe8101..3b687e4 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -100,7 +100,7 @@ requestHandlerWithAgdaFile m handlerWithAgdaFile = LSP.requestHandler m $ \req r let message = "Request for unknown Agda file at URI: " <> LSP.getUri uri responder $ Left $ LSP.TResponseError (LSP.InR LSP.ErrorCodes_InvalidParams) message Nothing Just agdaFile -> do - agdaLib <- Model.getAgdaLib normUri model + agdaLib <- findAgdaLib normUri let responderWithAgdaFile = lift . responder let handler = tryTC $ runWithAgdaFileT agdaLib agdaFile $ handlerWithAgdaFile req responderWithAgdaFile From 39b8a61d2a4bcf4ea7fb82d9e00430e2718d717d Mon Sep 17 00:00:00 2001 From: nvarner Date: Tue, 18 Nov 2025 18:45:13 -0600 Subject: [PATCH 37/47] Don't let Agda print to stdout --- src/Options.hs | 12 +++++++++--- src/Server/Model/AgdaLib.hs | 4 +++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Options.hs b/src/Options.hs index b5c3808..d79be07 100644 --- a/src/Options.hs +++ b/src/Options.hs @@ -43,12 +43,13 @@ data Options = Options optRawResponses :: Bool, optSetup :: Bool, optHelp :: Bool, - optVersion :: Bool + optVersion :: Bool, + optStdin :: Bool } defaultOptions :: Options defaultOptions = - Options {optViaTCP = Nothing, optRawAgdaOptions = [], optRawResponses = False, optSetup = False, optHelp = False, optVersion = False} + Options {optViaTCP = Nothing, optRawAgdaOptions = [], optRawResponses = False, optSetup = False, optHelp = False, optVersion = False, optStdin = False} options :: [OptDescr (Options -> Options)] options = @@ -84,7 +85,12 @@ options = ['V'] ["version"] (NoArg (\opts -> opts {optVersion = True})) - "print version information and exit" + "print version information and exit", + Option + [] + ["stdio"] + (NoArg (\opts -> opts {optStdin = True})) + "connect via stdio" ] versionNumber :: Int diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index a0f4aba..28d9a9c 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -71,7 +71,9 @@ initAgdaLibWithOrigin origin = do let libName = "" let tcState = TCM.initState #endif - tcStateRef <- liftIO $ newIORef tcState + let persistentState = TCM.stPersistentState tcState + let tcState' = tcState { TCM.stPersistentState = persistentState { TCM.stInteractionOutputCallback = \_ -> return () } } + tcStateRef <- liftIO $ newIORef tcState' let tcEnv = TCM.initEnv let optionsPragma = OptionsPragma [] empty return $ AgdaLib libName [] optionsPragma [] tcStateRef tcEnv origin From 5bfd1022ea481bbd1a84143ec34b93701150dce8 Mon Sep 17 00:00:00 2001 From: nvarner Date: Tue, 18 Nov 2025 18:56:38 -0600 Subject: [PATCH 38/47] Don't send file contents on save --- src/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index bbebd50..41fd5a6 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -102,7 +102,7 @@ syncOptions = _change = Just TextDocumentSyncKind_Incremental, -- receive change notifications from the client _willSave = Just False, -- receive willSave notifications from the client _willSaveWaitUntil = Just False, -- receive willSave notifications from the client - _save = Just $ InR $ SaveOptions (Just True) -- includes the document content on save, so that we don't have to read it from the disk (not sure if this is still true in lsp 2) + _save = Just $ InR $ SaveOptions (Just False) } -- handlers of the LSP server From 7ee1627979068d57a4dd713f714abe92d8872a49 Mon Sep 17 00:00:00 2001 From: nvarner Date: Wed, 19 Nov 2025 20:30:07 -0600 Subject: [PATCH 39/47] Split AgdaLib into AgdaProject and AgdaLib --- agda-language-server.cabal | 4 + src/Agda/Interaction/Imports/Virtual.hs | 6 +- src/Agda/TypeChecking/Monad/Options/More.hs | 8 +- src/Indexer.hs | 8 +- src/Indexer/Monad.hs | 8 +- src/Server/AgdaProjectResolver.hs | 23 ++++ src/Server/Model.hs | 26 ++++- src/Server/Model/AgdaLib.hs | 12 +- src/Server/Model/AgdaProject.hs | 53 +++++++++ src/Server/Model/Handler.hs | 19 +-- src/Server/Model/Monad.hs | 122 ++++++++++---------- test/Test/AgdaLibResolution.hs | 9 +- test/Test/Indexer/Reload.hs | 9 +- test/Test/ModelMonad.hs | 2 +- test/TestData.hs | 16 ++- 15 files changed, 214 insertions(+), 111 deletions(-) create mode 100644 src/Server/AgdaProjectResolver.hs create mode 100644 src/Server/Model/AgdaProject.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index eefadc2..e9abe10 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -81,6 +81,7 @@ library Render.Utils Server Server.AgdaLibResolver + Server.AgdaProjectResolver Server.CommandController Server.Filesystem Server.Handler @@ -89,6 +90,7 @@ library Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.AgdaProject Server.Model.Handler Server.Model.Monad Server.Model.Symbol @@ -241,6 +243,7 @@ test-suite als-test Render.Utils Server Server.AgdaLibResolver + Server.AgdaProjectResolver Server.CommandController Server.Filesystem Server.Handler @@ -249,6 +252,7 @@ test-suite als-test Server.Model Server.Model.AgdaFile Server.Model.AgdaLib + Server.Model.AgdaProject Server.Model.Handler Server.Model.Monad Server.Model.Symbol diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 02d7e07..3e7e67c 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -30,7 +30,7 @@ import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS import Server.Model.AgdaLib (agdaLibToFile) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) +import Server.Model.Monad (MonadAgdaProject, askAgdaLib) data VSourceFile = VSourceFile { vSrcFileSrcFile :: SourceFile, @@ -76,7 +76,7 @@ vSrcFromUri normUri file = do #endif parseSourceFromContents :: - (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => + (TCM.MonadTrace m, MonadAgdaProject m) => LSP.NormalizedUri -> SourceFile -> Text.Text -> @@ -113,6 +113,6 @@ parseSourceFromContents srcUri srcFile contentsStrict = do } -- | Based on @parseSource@ -parseVSource :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => VSourceFile -> m Imp.Source +parseVSource :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaProject m) => VSourceFile -> m Imp.Source parseVSource (VSourceFile srcFile uri vFile) = parseSourceFromContents uri srcFile (VFS.virtualFileText vFile) diff --git a/src/Agda/TypeChecking/Monad/Options/More.hs b/src/Agda/TypeChecking/Monad/Options/More.hs index daf8b2d..b1ed972 100644 --- a/src/Agda/TypeChecking/Monad/Options/More.hs +++ b/src/Agda/TypeChecking/Monad/Options/More.hs @@ -12,11 +12,11 @@ import Control.Monad.IO.Class (liftIO) import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) import qualified Server.Filesystem as FS import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) +import Server.Model.Monad (MonadAgdaProject, askAgdaLib) import System.Directory (getCurrentDirectory) setCommandLineOptionsByLib :: - (MonadTCM m, MonadAgdaLib m) => + (MonadTCM m, MonadAgdaProject m) => CommandLineOptions -> m () setCommandLineOptionsByLib opts = do @@ -24,7 +24,7 @@ setCommandLineOptionsByLib opts = do setCommandLineOptionsByLib' root opts setCommandLineOptionsByLib' :: - (MonadTCM m, MonadAgdaLib m) => + (MonadTCM m, MonadAgdaProject m) => AbsolutePath -> CommandLineOptions -> m () @@ -41,7 +41,7 @@ setCommandLineOptionsByLib' root opts = do TCM.liftTCM updateBenchmarkingStatus setLibraryPathsByLib :: - (MonadTCM m, MonadAgdaLib m) => + (MonadTCM m, MonadAgdaProject m) => CommandLineOptions -> m CommandLineOptions setLibraryPathsByLib o = do diff --git a/src/Indexer.hs b/src/Indexer.hs index ae24085..8c1ee38 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -23,9 +23,9 @@ import Indexer.Indexer (indexAst) import Indexer.Monad (execIndexerM) import Indexer.Postprocess (postprocess) import Server.Model.AgdaFile (AgdaFile) -import Server.Model.Monad (WithAgdaLibM) +import Server.Model.Monad (WithAgdaProjectM) -usingSrcAsCurrent :: Imp.Source -> WithAgdaLibM a -> WithAgdaLibM a +usingSrcAsCurrent :: Imp.Source -> WithAgdaProjectM a -> WithAgdaProjectM a usingSrcAsCurrent src x = do TCM.liftTCM TCM.resetState @@ -43,7 +43,7 @@ usingSrcAsCurrent src x = do TCM.localTC (\e -> e {TCM.envCurrentPath = Just (srcFilePath $ Imp.srcOrigin src)}) x #endif -withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaLibM a) -> WithAgdaLibM a +withAstFor :: Imp.Source -> (TopLevelInfo -> WithAgdaProjectM a) -> WithAgdaProjectM a withAstFor src f = usingSrcAsCurrent src $ do #if MIN_VERSION_Agda(2,8,0) let srcFile = Imp.srcOrigin src @@ -60,7 +60,7 @@ withAstFor src f = usingSrcAsCurrent src $ do indexFile :: Imp.Source -> - WithAgdaLibM AgdaFile + WithAgdaProjectM AgdaFile indexFile src = withAstFor src $ \ast -> execIndexerM $ do indexAst ast postprocess diff --git a/src/Indexer/Monad.hs b/src/Indexer/Monad.hs index 543c6d0..63f1e71 100644 --- a/src/Indexer/Monad.hs +++ b/src/Indexer/Monad.hs @@ -43,7 +43,7 @@ import Control.Monad.Trans (lift) import Data.Map (Map) import qualified Data.Map as Map import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile, insertRef, insertSymbolInfo) -import Server.Model.Monad (WithAgdaLibM) +import Server.Model.Monad (WithAgdaProjectM) import Server.Model.Symbol (Ref (Ref), RefKind (..), SymbolInfo (..), SymbolKind (..)) data NamedArgUsage = NamedArgUsage @@ -99,9 +99,9 @@ initEnv = do dataRecordParams <- liftIO $ newIORef mempty return $ Env agdaFile parent DeclBinding paramNames namedArgUsages dataRecordParams -type IndexerM = ReaderT Env WithAgdaLibM +type IndexerM = ReaderT Env WithAgdaProjectM -execIndexerM :: IndexerM a -> WithAgdaLibM AgdaFile +execIndexerM :: IndexerM a -> WithAgdaProjectM AgdaFile execIndexerM x = do env <- initEnv _ <- runReaderT x env @@ -247,7 +247,7 @@ class TypeLike t where -- However, strings do lose semantic information otherwise available to us, -- so this representation may be switched in the future if that information is -- needed. - toTypeString :: t -> WithAgdaLibM (Maybe String) + toTypeString :: t -> WithAgdaProjectM (Maybe String) instance (TypeLike t) => TypeLike (Maybe t) where toTypeString = maybe (return Nothing) toTypeString diff --git a/src/Server/AgdaProjectResolver.hs b/src/Server/AgdaProjectResolver.hs new file mode 100644 index 0000000..06cffb3 --- /dev/null +++ b/src/Server/AgdaProjectResolver.hs @@ -0,0 +1,23 @@ +module Server.AgdaProjectResolver (findAgdaProject) where + +import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) +import Server.AgdaLibResolver (findAgdaLib) +import qualified Server.Filesystem as FS +import qualified Server.Model as Model +import Server.Model.AgdaProject (AgdaProject) +import qualified Server.Model.AgdaProject as AgdaProject + +-- | Find cached 'AgdaProject', or else make one from @.agda-lib@ files on the +-- file system, or else provide a default +findAgdaProject :: (FS.IsFileId f) => f -> ServerM AgdaProject +findAgdaProject isFileId = do + let fileId = FS.toFileId isFileId + let uri = FS.fileIdToUri fileId + model <- askModel + case Model.getKnownAgdaProject uri model of + Just project -> return project + Nothing -> do + lib <- findAgdaLib fileId + project <- AgdaProject.new lib + modifyModel $ Model.withAgdaProject project + return project diff --git a/src/Server/Model.hs b/src/Server/Model.hs index bf8fab6..3ff320e 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -2,14 +2,16 @@ module Server.Model ( Model (Model), empty, getKnownAgdaLib, + getKnownAgdaProject, withAgdaLib, + withAgdaProject, getAgdaFile, setAgdaFile, deleteAgdaFile, ) where -import Agda.Utils.Lens (Lens', over) +import Agda.Utils.Lens (Lens', over, (^.)) import Control.Monad.IO.Class (MonadIO) import Data.Foldable (find) import Data.Functor ((<&>)) @@ -18,27 +20,41 @@ import qualified Data.Map as Map import qualified Language.LSP.Protocol.Types as LSP import Server.Model.AgdaFile (AgdaFile) import Server.Model.AgdaLib (AgdaLib, initAgdaLib, isAgdaLibForUri) +import Server.Model.AgdaProject (AgdaProject) +import qualified Server.Model.AgdaProject as AgdaProject data Model = Model - { _modelAgdaLibs :: !([AgdaLib]), + { _modelAgdaLibs :: ![AgdaLib], + _modelAgdaProjects :: ![AgdaProject], _modelAgdaFiles :: !(Map LSP.NormalizedUri AgdaFile) } empty :: Model -empty = Model [] Map.empty +empty = Model [] [] Map.empty agdaLibs :: Lens' Model [AgdaLib] agdaLibs f a = f (_modelAgdaLibs a) <&> \x -> a {_modelAgdaLibs = x} +agdaProjects :: Lens' Model [AgdaProject] +agdaProjects f a = f (_modelAgdaProjects a) <&> \x -> a {_modelAgdaProjects = x} + agdaFiles :: Lens' Model (Map LSP.NormalizedUri AgdaFile) agdaFiles f a = f (_modelAgdaFiles a) <&> \x -> a {_modelAgdaFiles = x} getKnownAgdaLib :: LSP.NormalizedUri -> Model -> Maybe AgdaLib -getKnownAgdaLib uri = find (`isAgdaLibForUri` uri) . _modelAgdaLibs +getKnownAgdaLib uri model = find (`isAgdaLibForUri` uri) $ model ^. agdaLibs + +getKnownAgdaProject :: LSP.NormalizedUri -> Model -> Maybe AgdaProject +getKnownAgdaProject uri model = + find ((`isAgdaLibForUri` uri) . (^. AgdaProject.agdaLib)) $ model ^. agdaProjects -- | Add an 'AgdaLib' to the model withAgdaLib :: AgdaLib -> Model -> Model -withAgdaLib lib model = model {_modelAgdaLibs = lib : _modelAgdaLibs model} +withAgdaLib lib = over agdaLibs (lib :) + +-- | Add an 'AgdaProject' to the model +withAgdaProject :: AgdaProject -> Model -> Model +withAgdaProject project = over agdaProjects (project :) getAgdaFile :: LSP.NormalizedUri -> Model -> Maybe AgdaFile getAgdaFile uri = Map.lookup uri . _modelAgdaFiles diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index 28d9a9c..75f3832 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -7,8 +7,6 @@ module Server.Model.AgdaLib agdaLibName, agdaLibIncludes, agdaLibDependencies, - agdaLibTcStateRef, - agdaLibTcEnv, agdaLibOrigin, isAgdaLibForUri, agdaLibFromFile, @@ -49,8 +47,6 @@ data AgdaLib = AgdaLib _agdaLibIncludes :: ![FS.FileId], _agdaLibOptionsPragma :: !OptionsPragma, _agdaLibDependencies :: ![LibName], - _agdaLibTcStateRef :: !(IORef TCM.TCState), - _agdaLibTcEnv :: !TCM.TCEnv, _agdaLibOrigin :: !AgdaLibOrigin } @@ -76,7 +72,7 @@ initAgdaLibWithOrigin origin = do tcStateRef <- liftIO $ newIORef tcState' let tcEnv = TCM.initEnv let optionsPragma = OptionsPragma [] empty - return $ AgdaLib libName [] optionsPragma [] tcStateRef tcEnv origin + return $ AgdaLib libName [] optionsPragma [] origin initAgdaLib :: (MonadIO m) => m AgdaLib initAgdaLib = initAgdaLibWithOrigin Defaulted @@ -93,12 +89,6 @@ agdaLibOptionsPragma f a = f (_agdaLibOptionsPragma a) <&> \x -> a {_agdaLibOpti agdaLibDependencies :: Lens' AgdaLib [LibName] agdaLibDependencies f a = f (_agdaLibDependencies a) <&> \x -> a {_agdaLibDependencies = x} -agdaLibTcStateRef :: Lens' AgdaLib (IORef TCM.TCState) -agdaLibTcStateRef f a = f (_agdaLibTcStateRef a) <&> \x -> a {_agdaLibTcStateRef = x} - -agdaLibTcEnv :: Lens' AgdaLib TCM.TCEnv -agdaLibTcEnv f a = f (_agdaLibTcEnv a) <&> \x -> a {_agdaLibTcEnv = x} - agdaLibOrigin :: Lens' AgdaLib AgdaLibOrigin agdaLibOrigin f a = f (_agdaLibOrigin a) <&> \x -> a {_agdaLibOrigin = x} diff --git a/src/Server/Model/AgdaProject.hs b/src/Server/Model/AgdaProject.hs new file mode 100644 index 0000000..609a96a --- /dev/null +++ b/src/Server/Model/AgdaProject.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} + +module Server.Model.AgdaProject + ( AgdaProject, + new, + agdaLib, + tcStateRef, + tcEnv, + ) +where + +import qualified Agda.TypeChecking.Monad as TCM +import Agda.Utils.IORef (IORef, newIORef) +import Agda.Utils.Lens (Lens', (<&>), (^.)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Server.Model.AgdaLib (AgdaLib, initAgdaLib) +import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) + +data AgdaProject = AgdaProject + { + _agdaLib :: !AgdaLib, + _tcStateRef :: !(IORef TCM.TCState), + _tcEnv :: !TCM.TCEnv + } + +instance Pretty AgdaProject where + pretty agdaProject = + text "AgdaProject" + <+> pretty (agdaProject ^. agdaLib) + +new :: (MonadIO m) => AgdaLib -> m AgdaProject +new agdaLib = do +#if MIN_VERSION_Agda(2,8,0) + tcState <- liftIO TCM.initStateIO +#else + let tcState = TCM.initState +#endif + let persistentState = TCM.stPersistentState tcState + -- Prevent Agda from writing to standard output by default. LSP likes to use + -- it, so Agda shouldn't try to use it too. + let tcState' = tcState { TCM.stPersistentState = persistentState { TCM.stInteractionOutputCallback = \_ -> return () } } + tcStateRef <- liftIO $ newIORef tcState' + let tcEnv = TCM.initEnv + return $ AgdaProject agdaLib tcStateRef tcEnv + +agdaLib :: Lens' AgdaProject AgdaLib +agdaLib f a = f (_agdaLib a) <&> \x -> a {_agdaLib = x} + +tcStateRef :: Lens' AgdaProject (IORef TCM.TCState) +tcStateRef f a = f (_tcStateRef a) <&> \x -> a {_tcStateRef = x} + +tcEnv :: Lens' AgdaProject TCM.TCEnv +tcEnv f a = f (_tcEnv a) <&> \x -> a {_tcEnv = x} diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index 3b687e4..c29e1fd 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -27,8 +27,9 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM, askModel, catchTCError) import Server.AgdaLibResolver (findAgdaLib) +import Server.AgdaProjectResolver (findAgdaProject) import qualified Server.Model as Model -import Server.Model.Monad (WithAgdaFileM, WithAgdaLibM, runWithAgdaFileT, runWithAgdaLibT) +import Server.Model.Monad (WithAgdaFileM, WithAgdaProjectM, runWithAgdaFileT, runWithAgdaProjectT) import qualified Server.Model.Monad as LSP #if MIN_VERSION_Agda(2,7,0) #else @@ -42,7 +43,7 @@ tryTC handler = (Right <$> handler) `catchTCError` (return . Left) type NotificationHandlerWithAgdaLib (m :: LSP.Method LSP.ClientToServer LSP.Notification) = - LSP.NormalizedUri -> LSP.TNotificationMessage m -> WithAgdaLibM () + LSP.NormalizedUri -> LSP.TNotificationMessage m -> WithAgdaProjectM () notificationHandlerWithAgdaLib :: (LSP.HasTextDocument (LSP.MessageParams m) textdoc, LSP.HasUri textdoc LSP.Uri) => @@ -60,13 +61,13 @@ takeOverNotificationHandlerWithAgdaLib :: takeOverNotificationHandlerWithAgdaLib notification handlerWithAgdaLib = do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri - agdaLib <- findAgdaLib normUri - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow agdaLib + agdaProject <- findAgdaProject uri + lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow agdaProject - let notificationHandler = runWithAgdaLibT agdaLib . handlerWithAgdaLib normUri + let notificationHandler = runWithAgdaProjectT agdaProject . handlerWithAgdaLib normUri let handler = tryTC $ notificationHandler notification - let onErr = \err -> runWithAgdaLibT agdaLib $ do + let onErr = \err -> runWithAgdaProjectT agdaProject $ do message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) lift $ LSP.sendNotification LSP.SMethod_WindowShowMessage $ LSP.ShowMessageParams LSP.MessageType_Error message lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Error message @@ -100,11 +101,11 @@ requestHandlerWithAgdaFile m handlerWithAgdaFile = LSP.requestHandler m $ \req r let message = "Request for unknown Agda file at URI: " <> LSP.getUri uri responder $ Left $ LSP.TResponseError (LSP.InR LSP.ErrorCodes_InvalidParams) message Nothing Just agdaFile -> do - agdaLib <- findAgdaLib normUri + agdaProject <- findAgdaProject uri let responderWithAgdaFile = lift . responder - let handler = tryTC $ runWithAgdaFileT agdaLib agdaFile $ handlerWithAgdaFile req responderWithAgdaFile + let handler = tryTC $ runWithAgdaFileT agdaProject agdaFile $ handlerWithAgdaFile req responderWithAgdaFile - let onErr = \err -> runWithAgdaFileT agdaLib agdaFile $ do + let onErr = \err -> runWithAgdaFileT agdaProject agdaFile $ do message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) lift $ responder $ Left $ LSP.TResponseError (LSP.InL LSP.LSPErrorCodes_RequestFailed) message Nothing diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index e5459c8..e00f9ca 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -10,14 +10,14 @@ {-# LANGUAGE TypeSynonymInstances #-} module Server.Model.Monad - ( MonadAgdaLib (..), + ( MonadAgdaProject (..), + askAgdaLib, useAgdaLib, MonadAgdaFile (..), useAgdaFile, - WithAgdaLibT, - runWithAgdaLibT, - WithAgdaLibM, - runWithAgdaLib, + WithAgdaProjectT, + runWithAgdaProjectT, + WithAgdaProjectM, WithAgdaFileT, runWithAgdaFileT, WithAgdaFileM, @@ -48,30 +48,39 @@ import Monad (ServerM, ServerT, askModel, catchTCError) import Options (Config) import qualified Server.Model as Model import Server.Model.AgdaFile (AgdaFile) -import Server.Model.AgdaLib (AgdaLib, agdaLibTcEnv, agdaLibTcStateRef) +import Server.Model.AgdaLib (AgdaLib) +import Server.Model.AgdaProject (AgdaProject) +import qualified Server.Model.AgdaProject as AgdaProject import Prelude hiding (null) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.FileId (File, getIdFile) #endif #if MIN_VERSION_Agda(2,7,0) import Agda.Interaction.Response (Response_boot(Resp_HighlightingInfo)) -import Server.AgdaLibResolver (findAgdaLib) #else import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) #endif -------------------------------------------------------------------------------- -class (MonadTCM m, ReadTCState m) => MonadAgdaLib m where - askAgdaLib :: m AgdaLib - localAgdaLib :: (AgdaLib -> AgdaLib) -> m a -> m a +class (MonadTCM m, ReadTCState m) => MonadAgdaProject m where + askAgdaProject :: m AgdaProject + localAgdaProject :: (AgdaProject -> AgdaProject) -> m a -> m a -useAgdaLib :: (MonadAgdaLib m) => Lens' AgdaLib a -> m a +useAgdaProject :: (MonadAgdaProject m) => Lens' AgdaProject a -> m a +useAgdaProject lens = do + agdaProject <- askAgdaProject + return $ agdaProject ^. lens + +askAgdaLib :: (MonadAgdaProject m) => m AgdaLib +askAgdaLib = useAgdaProject AgdaProject.agdaLib + +useAgdaLib :: (MonadAgdaProject m) => Lens' AgdaLib a -> m a useAgdaLib lens = do agdaLib <- askAgdaLib return $ agdaLib ^. lens -class (MonadAgdaLib m) => MonadAgdaFile m where +class (MonadAgdaProject m) => MonadAgdaFile m where askAgdaFile :: m AgdaFile localAgdaFile :: (AgdaFile -> AgdaFile) -> m a -> m a @@ -82,50 +91,50 @@ useAgdaFile lens = do -------------------------------------------------------------------------------- -defaultAskTC :: (MonadAgdaLib m) => m TCEnv -defaultAskTC = useAgdaLib agdaLibTcEnv +defaultAskTC :: (MonadAgdaProject m) => m TCEnv +defaultAskTC = useAgdaProject AgdaProject.tcEnv -defaultLocalTC :: (MonadAgdaLib m) => (TCEnv -> TCEnv) -> m a -> m a -defaultLocalTC f = localAgdaLib (over agdaLibTcEnv f) +defaultLocalTC :: (MonadAgdaProject m) => (TCEnv -> TCEnv) -> m a -> m a +defaultLocalTC f = localAgdaProject (over AgdaProject.tcEnv f) -defaultGetTC :: (MonadAgdaLib m) => m TCState +defaultGetTC :: (MonadAgdaProject m) => m TCState defaultGetTC = do - tcStateRef <- useAgdaLib agdaLibTcStateRef + tcStateRef <- useAgdaProject AgdaProject.tcStateRef liftIO $ readIORef tcStateRef -defaultPutTC :: (MonadAgdaLib m) => TCState -> m () +defaultPutTC :: (MonadAgdaProject m) => TCState -> m () defaultPutTC tcState = do - tcStateRef <- useAgdaLib agdaLibTcStateRef + tcStateRef <- useAgdaProject AgdaProject.tcStateRef liftIO $ writeIORef tcStateRef tcState -defaultModifyTC :: (MonadAgdaLib m) => (TCState -> TCState) -> m () +defaultModifyTC :: (MonadAgdaProject m) => (TCState -> TCState) -> m () defaultModifyTC f = do - tcStateRef <- useAgdaLib agdaLibTcStateRef + tcStateRef <- useAgdaProject AgdaProject.tcStateRef liftIO $ modifyIORef' tcStateRef f -- Taken from TCMT implementation -defaultLocallyTCState :: (MonadAgdaLib m) => Lens' TCState a -> (a -> a) -> m b -> m b +defaultLocallyTCState :: (MonadAgdaProject m) => Lens' TCState a -> (a -> a) -> m b -> m b defaultLocallyTCState lens f = bracket_ (useTC lens <* modifyTCLens lens f) (setTCLens lens) -- Taken from TCMT implementation -defaultPragmaOptionsImpl :: (MonadAgdaLib m) => m PragmaOptions +defaultPragmaOptionsImpl :: (MonadAgdaProject m) => m PragmaOptions defaultPragmaOptionsImpl = useTC stPragmaOptions -- Taken from TCMT implementation -defaultCommandLineOptionsImpl :: (MonadAgdaLib m) => m CommandLineOptions +defaultCommandLineOptionsImpl :: (MonadAgdaProject m) => m CommandLineOptions defaultCommandLineOptionsImpl = do p <- useTC stPragmaOptions cl <- stPersistentOptions . stPersistentState <$> getTC return $ cl {optPragmaOptions = p} -defaultLiftTCM :: (MonadAgdaLib m) => TCM a -> m a +defaultLiftTCM :: (MonadAgdaProject m) => TCM a -> m a defaultLiftTCM (TCM f) = do - tcStateRef <- useAgdaLib agdaLibTcStateRef - tcEnv <- useAgdaLib agdaLibTcEnv + tcStateRef <- useAgdaProject AgdaProject.tcStateRef + tcEnv <- useAgdaProject AgdaProject.tcEnv liftIO $ f tcStateRef tcEnv -- Taken from TCM implementation -defaultTraceClosureCall :: (MonadAgdaLib m, MonadTrace m) => TCM.Closure TCM.Call -> m a -> m a +defaultTraceClosureCall :: (MonadAgdaProject m, MonadTrace m) => TCM.Closure TCM.Call -> m a -> m a defaultTraceClosureCall cl m = do -- Compute update to 'Range' and 'Call' components of 'TCEnv'. let withCall = @@ -214,60 +223,55 @@ defaultTraceClosureCall cl m = do #if MIN_VERSION_Agda(2,8,0) -- Taken from TCMT implementation -defaultFileFromId :: (MonadAgdaLib m) => TCM.FileId -> m File +defaultFileFromId :: (MonadAgdaProject m) => TCM.FileId -> m File defaultFileFromId fi = useTC TCM.stFileDict <&> (`getIdFile` fi) -- Taken from TCMT implementation -defaultIdFromFile :: (MonadAgdaLib m) => File -> m TCM.FileId +defaultIdFromFile :: (MonadAgdaProject m) => File -> m TCM.FileId defaultIdFromFile = TCM.stateTCLens TCM.stFileDict . TCM.registerFileIdWithBuiltin #endif -------------------------------------------------------------------------------- -newtype WithAgdaLibT m a = WithAgdaLibT {unWithAgdaLibT :: ReaderT AgdaLib m a} +newtype WithAgdaProjectT m a = WithAgdaProjectT {unWithAgdaProjectT :: ReaderT AgdaProject m a} deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) -runWithAgdaLibT :: AgdaLib -> WithAgdaLibT m a -> m a -runWithAgdaLibT agdaLib = flip runReaderT agdaLib . unWithAgdaLibT - -type WithAgdaLibM = WithAgdaLibT ServerM +runWithAgdaProjectT :: AgdaProject -> WithAgdaProjectT m a -> m a +runWithAgdaProjectT agdaProject = flip runReaderT agdaProject . unWithAgdaProjectT -runWithAgdaLib :: LSP.Uri -> WithAgdaLibM a -> ServerM a -runWithAgdaLib uri x = do - agdaLib <- findAgdaLib uri - runWithAgdaLibT agdaLib x +type WithAgdaProjectM = WithAgdaProjectT ServerM -instance (MonadIO m) => MonadAgdaLib (WithAgdaLibT m) where - askAgdaLib = WithAgdaLibT ask - localAgdaLib f = WithAgdaLibT . local f . unWithAgdaLibT +instance (MonadIO m) => MonadAgdaProject (WithAgdaProjectT m) where + askAgdaProject = WithAgdaProjectT ask + localAgdaProject f = WithAgdaProjectT . local f . unWithAgdaProjectT -instance (MonadIO m) => MonadTCEnv (WithAgdaLibT m) where +instance (MonadIO m) => MonadTCEnv (WithAgdaProjectT m) where askTC = defaultAskTC localTC = defaultLocalTC -instance (MonadIO m) => MonadTCState (WithAgdaLibT m) where +instance (MonadIO m) => MonadTCState (WithAgdaProjectT m) where getTC = defaultGetTC putTC = defaultPutTC modifyTC = defaultModifyTC -instance (MonadIO m) => ReadTCState (WithAgdaLibT m) where +instance (MonadIO m) => ReadTCState (WithAgdaProjectT m) where getTCState = defaultGetTC locallyTCState = defaultLocallyTCState -instance (MonadIO m) => HasOptions (WithAgdaLibT m) where +instance (MonadIO m) => HasOptions (WithAgdaProjectT m) where pragmaOptions = defaultPragmaOptionsImpl commandLineOptions = defaultCommandLineOptionsImpl -- TODO: how should this really be implemented? -instance (MonadIO m) => MonadTrace (WithAgdaLibT m) where +instance (MonadIO m) => MonadTrace (WithAgdaProjectT m) where traceClosureCall = defaultTraceClosureCall printHighlightingInfo _ _ = return () -instance (MonadIO m) => MonadTCM (WithAgdaLibT m) where +instance (MonadIO m) => MonadTCM (WithAgdaProjectT m) where liftTCM = defaultLiftTCM #if MIN_VERSION_Agda(2,8,0) -instance (MonadIO m) => TCM.MonadFileId (WithAgdaLibT m) where +instance (MonadIO m) => TCM.MonadFileId (WithAgdaProjectT m) where fileFromId = defaultFileFromId idFromFile = defaultIdFromFile #endif @@ -275,12 +279,12 @@ instance (MonadIO m) => TCM.MonadFileId (WithAgdaLibT m) where -------------------------------------------------------------------------------- data WithAgdaFileEnv = WithAgdaFileEnv - { _withAgdaFileEnvAgdaLib :: !AgdaLib, + { _withAgdaFileEnvAgdaProject :: !AgdaProject, _withAgdaFileEnvAgdaFile :: !AgdaFile } -withAgdaFileEnvAgdaLib :: Lens' WithAgdaFileEnv AgdaLib -withAgdaFileEnvAgdaLib f a = f (_withAgdaFileEnvAgdaLib a) <&> \x -> a {_withAgdaFileEnvAgdaLib = x} +withAgdaFileEnvAgdaProject :: Lens' WithAgdaFileEnv AgdaProject +withAgdaFileEnvAgdaProject f a = f (_withAgdaFileEnvAgdaProject a) <&> \x -> a {_withAgdaFileEnvAgdaProject = x} withAgdaFileEnvAgdaFile :: Lens' WithAgdaFileEnv AgdaFile withAgdaFileEnvAgdaFile f a = f (_withAgdaFileEnvAgdaFile a) <&> \x -> a {_withAgdaFileEnvAgdaFile = x} @@ -289,16 +293,16 @@ newtype WithAgdaFileT m a = WithAgdaFileT {unWithAgdaFileT :: ReaderT WithAgdaFileEnv m a} deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) -runWithAgdaFileT :: AgdaLib -> AgdaFile -> WithAgdaFileT m a -> m a -runWithAgdaFileT agdaLib agdaFile = - let env = WithAgdaFileEnv agdaLib agdaFile +runWithAgdaFileT :: AgdaProject -> AgdaFile -> WithAgdaFileT m a -> m a +runWithAgdaFileT agdaProject agdaFile = + let env = WithAgdaFileEnv agdaProject agdaFile in flip runReaderT env . unWithAgdaFileT type WithAgdaFileM = WithAgdaFileT ServerM -instance (MonadIO m) => MonadAgdaLib (WithAgdaFileT m) where - askAgdaLib = WithAgdaFileT $ view withAgdaFileEnvAgdaLib - localAgdaLib f = WithAgdaFileT . locally withAgdaFileEnvAgdaLib f . unWithAgdaFileT +instance (MonadIO m) => MonadAgdaProject (WithAgdaFileT m) where + askAgdaProject = WithAgdaFileT $ view withAgdaFileEnvAgdaProject + localAgdaProject f = WithAgdaFileT . locally withAgdaFileEnvAgdaProject f . unWithAgdaFileT instance (MonadIO m) => MonadAgdaFile (WithAgdaFileT m) where askAgdaFile = WithAgdaFileT $ view withAgdaFileEnvAgdaFile diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index 457db09..d435fda 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -15,11 +15,12 @@ import Monad (runServerT) import Server.AgdaLibResolver (findAgdaLib) import qualified Server.Filesystem as FS import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName, agdaLibOrigin) -import Server.Model.Monad (MonadAgdaLib, askAgdaLib, runWithAgdaLib, runWithAgdaLibT) +import Server.Model.Monad (MonadAgdaProject, askAgdaLib, runWithAgdaProjectT) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import qualified TestData +import Server.AgdaProjectResolver (findAgdaProject) natPath, constPath, agdaLibPath, srcPath :: FilePath natPath = "test/data/libs/no-deps/src/Data/Nat.agda" @@ -56,7 +57,8 @@ tests = LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - runWithAgdaLib (LSP.filePathToUri natPath) $ do + natProject <- findAgdaProject natPath + runWithAgdaProjectT natProject $ do natSrc <- TestData.parseSourceFromPath natPath _ <- indexFile natSrc return (), @@ -66,7 +68,8 @@ tests = LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - runWithAgdaLib (LSP.filePathToUri constPath) $ do + constProject <- findAgdaProject constPath + runWithAgdaProjectT constProject $ do constSrc <- TestData.parseSourceFromPath constPath _ <- indexFile constSrc return () diff --git a/test/Test/Indexer/Reload.hs b/test/Test/Indexer/Reload.hs index a3b4ef5..c0f2a3d 100644 --- a/test/Test/Indexer/Reload.hs +++ b/test/Test/Indexer/Reload.hs @@ -8,7 +8,8 @@ import Indexer (indexFile) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (runServerT) -import Server.Model.Monad (runWithAgdaLib) +import Server.AgdaProjectResolver (findAgdaProject) +import Server.Model.Monad (runWithAgdaProjectT) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import qualified TestData @@ -28,7 +29,8 @@ testReloadFile path = do LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - runWithAgdaLib uri $ do + project <- findAgdaProject uri + runWithAgdaProjectT project $ do src <- TestData.parseSourceFromPath path _ <- indexFile src _ <- indexFile src @@ -61,7 +63,8 @@ testReloadChanges = do LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - runWithAgdaLib uri $ do + project <- findAgdaProject uri + runWithAgdaProjectT project $ do src0 <- TestData.parseSourceFromPathAndContents path contentsA agdaFile0 <- indexFile src0 diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index 13bc440..7c6844f 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -22,7 +22,7 @@ import qualified Server.CommandController as CommandController import Server.Model (Model) import Server.Model.AgdaLib (agdaLibIncludes) import Server.Model.Handler (requestHandlerWithAgdaFile) -import Server.Model.Monad (MonadAgdaLib (askAgdaLib)) +import Server.Model.Monad (MonadAgdaProject, askAgdaLib) import qualified Server.ResponseController as ResponseController import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) diff --git a/test/TestData.hs b/test/TestData.hs index 4766974..7ab0d26 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -45,7 +45,7 @@ import qualified Server.CommandController as CommandController import Server.Model (Model (Model)) import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) -import Server.Model.Monad (runWithAgdaLib, MonadAgdaLib) +import Server.Model.Monad (MonadAgdaProject, runWithAgdaProjectT) import qualified Server.ResponseController as ResponseController import System.FilePath (takeBaseName, ()) import Agda.TypeChecking.Pretty (prettyTCM) @@ -53,6 +53,8 @@ import Data.Text (Text) import Agda.Interaction.Imports.Virtual (parseSourceFromContents) import qualified Server.Filesystem as FS import qualified Server.VfsIndex as VfsIndex +import Server.AgdaProjectResolver (findAgdaProject) +import qualified Server.Model.AgdaProject as AgdaProject data AgdaFileDetails = AgdaFileDetails { fileName :: String, @@ -69,13 +71,14 @@ agdaFileDetails inPath = do (file, interface) <- LSP.runLspT undefined $ do env <- TestData.getServerEnv model runServerT env $ do - let withSrc f = runWithAgdaLib uri $ do + project <- findAgdaProject uri + let withSrc f = runWithAgdaProjectT project $ do TCM.liftTCM $ TCM.setCommandLineOptions Agda.Interaction.Options.defaultOptions src <- parseSourceFromPath inPath f src - let onErr = \err -> runWithAgdaLib uri $ do + let onErr = \err -> runWithAgdaProjectT project $ do t <- TCM.liftTCM $ prettyTCM err error $ prettyShow t @@ -104,7 +107,7 @@ parseSourceFromPath path = do TCM.liftTCM $ Imp.parseSource srcFile parseSourceFromPathAndContents :: - (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaLib m) => + (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaProject m) => FilePath -> Text -> m Imp.Source @@ -153,6 +156,7 @@ getModel = do testLib1 <- initAgdaLib <&> set agdaLibIncludes includes1 + testProject1 <- AgdaProject.new testLib1 let includes2 = FS.Uri . LSP.toNormalizedUri . LSP.Uri @@ -160,8 +164,10 @@ getModel = do testLib2 <- initAgdaLib <&> set agdaLibIncludes includes2 + testProject2 <- AgdaProject.new testLib2 let libs = [testLib1, testLib2] + let projects = [testProject1, testProject2] let testFile1 = emptyAgdaFile let testFile2 = emptyAgdaFile @@ -174,7 +180,7 @@ getModel = do (fileUri3, testFile3) ] - return $ Model libs files + return $ Model libs projects files -------------------------------------------------------------------------------- From f141206068e4e480f9c2e69454d6e92e28caa6cf Mon Sep 17 00:00:00 2001 From: nvarner Date: Sat, 22 Nov 2025 10:24:18 -0600 Subject: [PATCH 40/47] Remove unused imports --- agda-language-server.cabal | 6 +- app/Main.hs | 2 - package.yaml | 90 ++++++------------- src/Agda.hs | 7 +- src/Agda/Convert.hs | 20 +++-- src/Agda/Interaction/Imports/More.hs | 49 +++++----- src/Agda/Interaction/Imports/Virtual.hs | 22 +---- src/Agda/Interaction/Library/More.hs | 11 ++- src/Agda/Interaction/Library/Parse/More.hs | 10 --- src/Agda/Parser.hs | 4 +- src/Agda/Position.hs | 3 + src/Agda/Syntax/Abstract/More.hs | 2 - src/Indexer.hs | 1 - src/Indexer/Indexer.hs | 1 - src/Language/LSP/Protocol/Types/Uri/More.hs | 2 - src/Monad.hs | 11 +-- src/Options.hs | 10 --- src/Render/Common.hs | 7 +- src/Render/Concrete.hs | 10 ++- src/Render/Internal.hs | 1 - src/Render/RichText.hs | 1 - src/Render/TypeChecking.hs | 2 +- src/Server.hs | 18 +--- src/Server/AgdaLibResolver.hs | 5 +- src/Server/AgdaProjectResolver.hs | 2 +- src/Server/Filesystem.hs | 7 +- src/Server/Handler.hs | 11 +-- .../Handler/TextDocument/DocumentSymbol.hs | 8 +- .../Handler/TextDocument/FileManagement.hs | 6 -- src/Server/Model.hs | 3 +- src/Server/Model/AgdaLib.hs | 52 ++++------- src/Server/Model/AgdaProject.hs | 2 +- src/Server/Model/Handler.hs | 6 +- src/Server/Model/Monad.hs | 43 ++------- src/Switchboard.hs | 3 - test/Test.hs | 2 - test/Test/AgdaLibResolution.hs | 6 +- test/Test/Indexer/Invariants/NoMissing.hs | 2 +- test/Test/Indexer/Invariants/NoOverlap.hs | 4 +- test/Test/Indexer/NoAnonFunSymbol.hs | 3 +- test/Test/Indexer/Reload.hs | 4 +- test/Test/Model.hs | 8 +- test/Test/ModelMonad.hs | 11 +-- test/Test/SrcLoc.hs | 1 - test/Test/WASM.hs | 1 - test/TestData.hs | 52 +++++------ 46 files changed, 167 insertions(+), 365 deletions(-) diff --git a/agda-language-server.cabal b/agda-language-server.cabal index e9abe10..0bce0f7 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -106,7 +106,7 @@ library OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Werror=incomplete-patterns -fno-warn-orphans + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror build-depends: Agda , aeson @@ -153,7 +153,7 @@ executable als OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -rtsopts -Werror=incomplete-patterns -fno-warn-orphans + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror -rtsopts build-depends: Agda , aeson @@ -268,7 +268,7 @@ test-suite als-test OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -rtsopts -Werror=incomplete-patterns -fno-warn-orphans + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror -rtsopts build-depends: Agda , aeson diff --git a/app/Main.hs b/app/Main.hs index 55ef5e2..89b5fc2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,12 +5,10 @@ import Control.Monad (when) import Options import Server (run) -- import Simple (run) -import System.Console.GetOpt import System.Directory (doesDirectoryExist) import System.Environment import System.FilePath (()) import System.IO -import Text.Read (readMaybe) #if MIN_VERSION_Agda(2,8,0) import Agda.Setup (setup) diff --git a/package.yaml b/package.yaml index 2db68d3..3e11982 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,10 @@ when: - condition: "arch(wasm32)" dependencies: - unix >= 2.8.0.0 && < 2.9 +- condition: "!arch(wasm32)" + ghc-options: + - -threaded + - -with-rtsopts=-N dependencies: - base >= 4.7 && < 5 @@ -78,48 +82,32 @@ default-extensions: - PatternSynonyms - TypeOperators +ghc-options: +- -Wincomplete-patterns +- -Werror=incomplete-patterns +- -Wunused-local-binds +- -Wunused-pattern-binds +- -Wunused-do-bind +- -Wunused-foralls +- -Wunused-imports +- -Wwarnings-deprecations +- -Wwrong-do-bind +- -Wmissing-fields +- -Wmissing-methods +- -Wmissing-pattern-synonym-signatures +- -Wmissing-signatures +- -Wsimplifiable-class-constraints +- -fno-warn-orphans + library: source-dirs: src - ghc-options: - - -Wincomplete-patterns - - -Wunused-do-bind - - -Wunused-foralls - - -Wwarnings-deprecations - - -Wwrong-do-bind - - -Wmissing-fields - - -Wmissing-methods - - -Wmissing-pattern-synonym-signatures - - -Wmissing-signatures - - -Werror=incomplete-patterns - - -fno-warn-orphans - when: - - condition: "!arch(wasm32)" - ghc-options: - - -threaded - - -with-rtsopts=-N executables: als: - main: Main.hs - source-dirs: app + main: Main.hs + source-dirs: app ghc-options: - - -Wincomplete-patterns - - -Wunused-do-bind - - -Wunused-foralls - - -Wwarnings-deprecations - - -Wwrong-do-bind - - -Wmissing-fields - - -Wmissing-methods - - -Wmissing-pattern-synonym-signatures - - -Wmissing-signatures - -rtsopts - - -Werror=incomplete-patterns - - -fno-warn-orphans - when: - - condition: "!arch(wasm32)" - ghc-options: - - -threaded - - -with-rtsopts=-N dependencies: - agda-language-server @@ -129,39 +117,11 @@ tests: source-dirs: - test - src + ghc-options: + - -rtsopts dependencies: - lsp-test - tasty - tasty-hunit - tasty-golden - tasty-quickcheck - - ghc-options: - - -Wincomplete-patterns - - -Wunused-do-bind - - -Wunused-foralls - - -Wwarnings-deprecations - - -Wwrong-do-bind - - -Wmissing-fields - - -Wmissing-methods - - -Wmissing-pattern-synonym-signatures - - -Wmissing-signatures - - -rtsopts - - -Werror=incomplete-patterns - - -fno-warn-orphans - when: - - condition: "!arch(wasm32)" - ghc-options: - - -threaded - - -with-rtsopts=-N - -# tests: -# als-test: -# main: Spec.hs -# source-dirs: test -# ghc-options: -# - -threaded -# - -rtsopts -# - -with-rtsopts=-N -# dependencies: -# - agda-language-server diff --git a/src/Agda.hs b/src/Agda.hs index ff053b1..acaea9f 100644 --- a/src/Agda.hs +++ b/src/Agda.hs @@ -24,7 +24,7 @@ import Agda.Interaction.Base ( Command , CommandM #endif , CommandState(optionsOnReload) - , IOTCM + , initCommandState , parseIOTCM ) @@ -61,7 +61,6 @@ import Agda.TypeChecking.Monad.Base ( TCM ) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Monad.State ( setInteractionOutputCallback ) -import Agda.Utils.FileName ( absolute ) import Agda.Utils.Impossible ( CatchImpossible ( catchImpossible ) @@ -82,10 +81,8 @@ import Data.Aeson ( FromJSON , fromJSON ) import qualified Data.Aeson as JSON -import Data.Maybe ( listToMaybe ) import Data.Text ( pack ) import GHC.Generics ( Generic ) -import Language.LSP.Server ( getConfig ) import Monad import Options ( Config(configRawAgdaOptions) , Options(optRawAgdaOptions, optRawResponses) @@ -93,7 +90,7 @@ import Options ( Config(configRawAgdaOptions) ) import qualified Agda.IR as IR -import Agda.Interaction.JSON ( encode, encodeTCM ) +import Agda.Interaction.JSON ( encodeTCM ) import Agda.Interaction.JSONTop () getAgdaVersion :: String diff --git a/src/Agda/Convert.hs b/src/Agda/Convert.hs index 4e8f9bc..f12a092 100644 --- a/src/Agda/Convert.hs +++ b/src/Agda/Convert.hs @@ -13,7 +13,6 @@ import Agda.Interaction.Highlighting.Precise (Aspects (..), DefinitionSite (..), import qualified Agda.Interaction.Highlighting.Range as Highlighting #if MIN_VERSION_Agda(2,8,0) import Agda.Interaction.Command (localStateCommandM) -import Agda.TypeChecking.Monad.Base (topLevelModuleFilePath) #else import Agda.Interaction.InteractionTop (localStateCommandM) #endif @@ -26,23 +25,26 @@ import Agda.Syntax.Abstract.Pretty (prettyATop) import Agda.Syntax.Common import Agda.Syntax.Concrete as C import Agda.Syntax.Internal (alwaysUnblock) -import Agda.Syntax.Position (HasRange (getRange), Range, noRange) -import Agda.Syntax.Scope.Base -import Agda.TypeChecking.Errors (explainWhyInScope, getAllWarningsOfTCErr, prettyError) +import Agda.Syntax.Position (noRange) +import Agda.TypeChecking.Errors (explainWhyInScope) import Agda.TypeChecking.Monad hiding (Function) -import Agda.TypeChecking.Monad.MetaVars (withInteractionId) import Agda.TypeChecking.Pretty (prettyTCM) import qualified Agda.TypeChecking.Pretty as TCP -import Agda.TypeChecking.Pretty.Warning (filterTCWarnings, prettyTCWarnings, prettyTCWarnings') +#if MIN_VERSION_Agda(2,7,0) +#else import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors (..)) +#endif +import Agda.TypeChecking.Pretty.Warning (filterTCWarnings) import Agda.Utils.FileName (filePath) import Agda.Utils.Function (applyWhen) import Agda.Utils.IO.TempFile (writeToTempFile) +#if MIN_VERSION_Agda(2,8,0) +#else import Agda.Utils.Impossible (__IMPOSSIBLE__) +#endif import Agda.Utils.Maybe (catMaybes) import Agda.Utils.Null (empty) import Agda.Utils.RangeMap (IsBasicRangeMap (toList)) -import Agda.Utils.String (delimiter) import Agda.Utils.Time (CPUTime) import Agda.VersionCommit (versionWithCommitInfo) import Control.Monad @@ -50,13 +52,15 @@ import Control.Monad.State hiding (state) import qualified Data.Aeson as JSON import qualified Data.ByteString.Lazy.Char8 as BS8 import qualified Data.List as List +#if MIN_VERSION_Agda(2,8,0) +#else import qualified Data.Map as Map +#endif import Data.String (IsString) import Render (Block (..), Inlines, Render (..), renderATop) import qualified Render import Agda.Syntax.Common.Pretty hiding (render) -import qualified Prettyprinter responseAbbr :: (IsString a) => Response -> a responseAbbr res = case res of diff --git a/src/Agda/Interaction/Imports/More.hs b/src/Agda/Interaction/Imports/More.hs index 1c2b374..a47374d 100644 --- a/src/Agda/Interaction/Imports/More.hs +++ b/src/Agda/Interaction/Imports/More.hs @@ -4,6 +4,7 @@ module Agda.Interaction.Imports.More ( setOptionsFromSourcePragmas, checkModuleName', runPMDropWarnings, + srcFilePath, moduleName, runPM, beginningOfFile, @@ -11,23 +12,21 @@ module Agda.Interaction.Imports.More where import Agda.Interaction.FindFile ( - SourceFile (SourceFile), checkModuleName, #if MIN_VERSION_Agda(2,8,0) + SourceFile, rootNameModule, #else + SourceFile (SourceFile), moduleName, #endif ) -import Agda.Interaction.Imports (Source (..)) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Library (OptionsPragma (..), _libPragmas) import Agda.Interaction.Library.More () import Agda.Syntax.Common (TopLevelModuleName') import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Parser ( - moduleParser, - parseFile, #if MIN_VERSION_Agda(2,8,0) parse, moduleNameParser, @@ -38,35 +37,28 @@ import Agda.Syntax.Parser ( ) import Agda.Syntax.Position ( Range, - Range' (Range), - RangeFile, getRange, - intervalToRange, - mkRangeFile, - posToRange, - posToRange', - startPos, #if MIN_VERSION_Agda(2,8,0) beginningOfFile, rangeFromAbsolutePath, +#else + RangeFile, + posToRange, + startPos, #endif ) +#if MIN_VERSION_Agda(2,8,0) import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName, RawTopLevelModuleName (..), -#if MIN_VERSION_Agda(2,8,0) rawTopLevelModuleNameForModule, -#endif ) -import Agda.Syntax.Common.Pretty (Pretty, pretty, text, prettyAssign, (<+>)) +#endif +import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) import Agda.TypeChecking.Monad - ( Interface, - TCM, + ( TCM, setCurrentRange, setOptionsFromPragma, - setTCLens, - stPragmaOptions, - useTC, #if MIN_VERSION_Agda(2,7,0) checkAndSetOptionsFromPragma, #endif @@ -76,17 +68,15 @@ import Agda.TypeChecking.Monad #endif ) import qualified Agda.TypeChecking.Monad as TCM -import qualified Agda.TypeChecking.Monad.Benchmark as Bench #if MIN_VERSION_Agda(2,8,0) +import qualified Agda.TypeChecking.Monad.Benchmark as Bench #else import Agda.TypeChecking.Warnings (runPM) #endif import Agda.Utils.FileName (AbsolutePath) -import Agda.Utils.Monad (bracket_) #if MIN_VERSION_Agda(2,8,0) import qualified Data.Text as T #endif -import qualified Data.Text.Lazy as TL import Control.Monad.Error.Class ( #if MIN_VERSION_Agda(2,8,0) catchError, @@ -98,13 +88,6 @@ import Control.Monad.Error.Class ( import Agda.Utils.Singleton (singleton) #endif -srcFilePath :: SourceFile -> TCM AbsolutePath -#if MIN_VERSION_Agda(2,8,0) -srcFilePath = TCM.srcFilePath -#else -srcFilePath (SourceFile f) = return f -#endif - #if MIN_VERSION_Agda(2,8,0) -- beginningOfFile was generalized in Agda 2.8.0 to support the features we -- need, so we just import it @@ -124,6 +107,14 @@ runPMDropWarnings m = do Right a -> return a #endif +#if MIN_VERSION_Agda(2,8,0) +srcFilePath :: (TCM.MonadFileId m) => SourceFile -> m AbsolutePath +srcFilePath = TCM.srcFilePath +#else +srcFilePath :: (Monad m) => SourceFile -> m AbsolutePath +srcFilePath (SourceFile path) = return path +#endif + -- Unexported Agda functions srcDefaultPragmas :: Imp.Source -> [OptionsPragma] diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 3e7e67c..843a141 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -10,7 +10,7 @@ module Agda.Interaction.Imports.Virtual where #if MIN_VERSION_Agda(2,8,0) -import Agda.TypeChecking.Monad (SourceFile (SourceFile)) +import Agda.TypeChecking.Monad (SourceFile) #else import Agda.Interaction.FindFile (SourceFile (SourceFile)) #endif @@ -19,15 +19,12 @@ import qualified Agda.Interaction.Imports.More as Imp import Agda.Syntax.Parser (moduleParser, parseFile) import Agda.Syntax.Position (mkRangeFile) import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.FileName (AbsolutePath) import Agda.Utils.Maybe (maybeToList) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans (lift) import qualified Data.Strict as Strict import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) -import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS import Server.Model.AgdaLib (agdaLibToFile) import Server.Model.Monad (MonadAgdaProject, askAgdaLib) @@ -38,21 +35,6 @@ data VSourceFile = VSourceFile vSrcVFile :: VFS.VirtualFile } -#if MIN_VERSION_Agda(2,8,0) -srcFilePath :: (TCM.MonadFileId m) => SourceFile -> m AbsolutePath -srcFilePath = TCM.srcFilePath -#else -srcFilePath :: (Monad m) => SourceFile -> m AbsolutePath -srcFilePath (SourceFile path) = return path -#endif - -#if MIN_VERSION_Agda(2,8,0) -vSrcFilePath :: (TCM.MonadFileId m) => VSourceFile -> m AbsolutePath -#else -vSrcFilePath :: (Monad m) => VSourceFile -> m AbsolutePath -#endif -vSrcFilePath = srcFilePath . vSrcFileSrcFile - #if MIN_VERSION_Agda(2,8,0) vSrcFromUri :: (TCM.MonadFileId m, MonadIO m) => @@ -82,7 +64,7 @@ parseSourceFromContents :: Text.Text -> m Imp.Source parseSourceFromContents srcUri srcFile contentsStrict = do - f <- TCM.liftTCM $ srcFilePath srcFile + f <- TCM.liftTCM $ Imp.srcFilePath srcFile let rf0 = mkRangeFile f Nothing TCM.setCurrentRange (Imp.beginningOfFile rf0) $ do diff --git a/src/Agda/Interaction/Library/More.hs b/src/Agda/Interaction/Library/More.hs index da5e264..e609a90 100644 --- a/src/Agda/Interaction/Library/More.hs +++ b/src/Agda/Interaction/Library/More.hs @@ -10,7 +10,16 @@ module Agda.Interaction.Library.More where import Agda.Interaction.Library (LibM, AgdaLibFile) -import Agda.Interaction.Library.Base (LibErrorIO, libName, libFile, libIncludes) +import Agda.Interaction.Library.Base + ( + libName, + libFile, + libIncludes, +#if MIN_VERSION_Agda(2,8,0) +#else + LibErrorIO, +#endif + ) import Agda.Utils.Either (maybeRight) import Agda.Utils.Null (Null (empty)) import Control.Category ((>>>)) diff --git a/src/Agda/Interaction/Library/Parse/More.hs b/src/Agda/Interaction/Library/Parse/More.hs index b8227f8..e41fe03 100644 --- a/src/Agda/Interaction/Library/Parse/More.hs +++ b/src/Agda/Interaction/Library/Parse/More.hs @@ -17,11 +17,8 @@ import Agda.Interaction.Library.Base import Agda.Syntax.Position import Agda.Utils.Applicative import Agda.Utils.FileName -import Agda.Utils.IO (catchIO) -import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Lens import Agda.Utils.List (duplicates) -import Agda.Utils.List1 (List1, toList) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Singleton @@ -31,12 +28,9 @@ import Control.Monad.Except import Control.Monad.Writer import Data.Char import qualified Data.List as List -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text as Text import Monad (ServerM) import qualified Server.Filesystem as FS -import System.FilePath -- | Parser monad: Can throw @LibParseError@s, and collects -- @LibWarning'@s library warnings. @@ -279,10 +273,6 @@ groupLines (Header _ h : ls) = (GenericEntry h [c | Content _ c <- cs] :) <$> gr isContent Content {} = True isContent Header {} = False --- | Remove leading whitespace and line comment. -trimLineComment :: String -> String -trimLineComment = stripComments . ltrim - -- | Break a comma-separated string. Result strings are @trim@med. splitCommas :: String -> [String] splitCommas = words . map (\c -> if c == ',' then ' ' else c) diff --git a/src/Agda/Parser.hs b/src/Agda/Parser.hs index 10cfc07..04b39fd 100644 --- a/src/Agda/Parser.hs +++ b/src/Agda/Parser.hs @@ -14,9 +14,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text, unpack) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Server (LspM) -import Monad (ServerM, ServerT) -import Options (Config) +import Monad (ServerM) -------------------------------------------------------------------------------- diff --git a/src/Agda/Position.hs b/src/Agda/Position.hs index d90e96d..8255962 100644 --- a/src/Agda/Position.hs +++ b/src/Agda/Position.hs @@ -24,7 +24,10 @@ import qualified Data.Strict.Maybe as Strict import Data.Text (Text) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Types as LSP +#if MIN_VERSION_Agda(2,8,0) +#else import Data.Functor (void) +#endif -- Note: LSP srclocs are 0-base -- Agda srclocs are 1-base diff --git a/src/Agda/Syntax/Abstract/More.hs b/src/Agda/Syntax/Abstract/More.hs index cf36516..8ef8b35 100644 --- a/src/Agda/Syntax/Abstract/More.hs +++ b/src/Agda/Syntax/Abstract/More.hs @@ -5,10 +5,8 @@ module Agda.Syntax.Abstract.More () where import Agda.Syntax.Abstract import Agda.Syntax.Common -import Agda.Syntax.Common (ArgInfo (argInfoOrigin)) import Agda.Syntax.Common.Pretty import Agda.Syntax.Info -import Agda.Utils.Functor ((<&>)) import Data.Foldable (Foldable (toList)) import qualified Data.Map as Map diff --git a/src/Indexer.hs b/src/Indexer.hs index 8c1ee38..a66866c 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -13,7 +13,6 @@ import Agda.Interaction.FindFile (srcFilePath) #endif import qualified Agda.Interaction.Imports as Imp import qualified Agda.Interaction.Imports.More as Imp -import Agda.Syntax.Common.Pretty (prettyShow) import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel), TopLevelInfo) import qualified Agda.TypeChecking.Monad as TCM diff --git a/src/Indexer/Indexer.hs b/src/Indexer/Indexer.hs index 40030ca..a2e7992 100644 --- a/src/Indexer/Indexer.hs +++ b/src/Indexer/Indexer.hs @@ -24,7 +24,6 @@ import Agda.Utils.Maybe (whenJust) import Agda.Utils.Monad (when) import Data.Foldable (forM_, traverse_, toList) import Data.Functor.Compose (Compose (Compose, getCompose)) -import qualified Data.Set as Set import Data.Void (absurd) import Indexer.Monad ( AmbiguousNameLike (..), diff --git a/src/Language/LSP/Protocol/Types/Uri/More.hs b/src/Language/LSP/Protocol/Types/Uri/More.hs index f5823d0..ddca511 100644 --- a/src/Language/LSP/Protocol/Types/Uri/More.hs +++ b/src/Language/LSP/Protocol/Types/Uri/More.hs @@ -14,10 +14,8 @@ import Agda.Utils.Lens (set, (^.)) import Agda.Utils.List (initMaybe, lastMaybe) import Agda.Utils.Maybe (fromMaybe) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Function ((&)) import Data.Text (Text) import qualified Data.Text as Text -import Language.LSP.Protocol.Types (uriToFilePath) import qualified Language.LSP.Protocol.Types as LSP import qualified Text.URI as ParsedUri import qualified Text.URI.Lens as ParsedUriLens diff --git a/src/Monad.hs b/src/Monad.hs index d3efe02..c86f851 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} @@ -7,13 +6,9 @@ module Monad where import Agda.IR import Agda.Interaction.Base (IOTCM) -import Agda.Interaction.Library (findProjectRoot) -import Agda.Interaction.Library.More (tryRunLibM) import Agda.TypeChecking.Monad (TCMT) import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.Lens (Lens', (^.)) import Control.Concurrent -import Control.Exception (Exception) import qualified Control.Exception as E import Control.Monad.Reader import Data.IORef @@ -21,14 +16,12 @@ import Data.IORef modifyIORef', newIORef, readIORef, - writeIORef, ) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Data.Text ( Text, pack, ) -import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server ( LspM, MonadLsp, @@ -42,12 +35,10 @@ import Server.Filesystem (MonadFilesystem) import qualified Server.Filesystem as FS import Server.Model (Model) import qualified Server.Model as Model -import Server.Model.AgdaLib (AgdaLib, initAgdaLib) import Server.ResponseController (ResponseController) import qualified Server.ResponseController as ResponseController import Server.VfsIndex (VfsIndex) import qualified Server.VfsIndex as VfsIndex -import System.FilePath (takeDirectory) -------------------------------------------------------------------------------- diff --git a/src/Options.hs b/src/Options.hs index d79be07..a68214e 100644 --- a/src/Options.hs +++ b/src/Options.hs @@ -125,16 +125,6 @@ parseOpts argv = case getOpt Permute options argv of (o, n, []) -> return (foldl (flip id) defaultOptions o, n) (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo usage options --- | Removes RTS options from a list of options (stolen from Agda) -stripRTS :: [String] -> [String] -stripRTS [] = [] -stripRTS ("--RTS" : argv) = argv -stripRTS (arg : argv) - | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv - | otherwise = arg : stripRTS argv - where - is x arg = [x] == take 1 (words arg) - -- | Extract Agda options (+AGDA ... -AGDA) from a list of options extractAgdaOpts :: [String] -> ([String], [String]) extractAgdaOpts argv = diff --git a/src/Render/Common.hs b/src/Render/Common.hs index 85eb735..6527c87 100644 --- a/src/Render/Common.hs +++ b/src/Render/Common.hs @@ -4,7 +4,9 @@ module Render.Common where import Agda.Syntax.Common ( Cohesion (..), +#if MIN_VERSION_Agda(2,7,0) Erased (..), +#endif Hiding (Hidden, Instance, NotHidden), Induction (..), LensCohesion (getCohesion), @@ -26,7 +28,9 @@ import Agda.Syntax.Common QωOrigin (..), Relevance (..), RewriteEqn' (..), +#if MIN_VERSION_Agda(2,7,0) asQuantity, +#endif #if MIN_VERSION_Agda(2,8,0) OriginRelevant (..), OriginIrrelevant (..), @@ -37,11 +41,12 @@ import Agda.Syntax.Common ) import Agda.Utils.Functor ((<&>)) import Agda.Utils.List1 (toList) +#if MIN_VERSION_Agda(2,7,0) import qualified Agda.Utils.List1 as List1 +#endif import qualified Agda.Utils.Null as Agda import Render.Class import Render.RichText -import Data.Text (Text) -------------------------------------------------------------------------------- diff --git a/src/Render/Concrete.hs b/src/Render/Concrete.hs index 347e2f4..4567746 100644 --- a/src/Render/Concrete.hs +++ b/src/Render/Concrete.hs @@ -10,13 +10,19 @@ import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Pretty (NamedBinding (..), Tel (..), isLabeled) import Agda.Utils.Float (toStringWithoutDotZero) import Agda.Utils.Function -import Agda.Utils.Functor (dget, (<&>), for) +import Agda.Utils.Functor import Agda.Utils.Impossible (__IMPOSSIBLE__) import Agda.Utils.List1 as List1 (fromList, toList, List1) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Null -import Data.Maybe (isNothing, maybeToList) +import Data.Maybe ( + isNothing, +#if MIN_VERSION_Agda(2,7,0) +#else + maybeToList, +#endif + ) import qualified Data.Strict.Maybe as Strict import qualified Data.Text as T import Render.Class diff --git a/src/Render/Internal.hs b/src/Render/Internal.hs index b4fe15b..36ad446 100644 --- a/src/Render/Internal.hs +++ b/src/Render/Internal.hs @@ -6,7 +6,6 @@ module Render.Internal where import Agda.Syntax.Common (Hiding (..), LensHiding (getHiding), Named (namedThing)) import Agda.Syntax.Internal hiding (telToList) import Agda.Utils.Function (applyWhen) -import Control.Monad import qualified Data.List as List import qualified Data.Set as Set import Render.Class diff --git a/src/Render/RichText.hs b/src/Render/RichText.hs index 02fe480..917e92b 100644 --- a/src/Render/RichText.hs +++ b/src/Render/RichText.hs @@ -46,7 +46,6 @@ import qualified Agda.Syntax.Position as Agda import qualified Agda.Utils.FileName as Agda import Agda.Utils.List (caseList, last1) import Agda.Utils.Null -import qualified Agda.Utils.Null as Agda import Agda.Utils.Suffix (toSubscriptDigit) import Data.Aeson (ToJSON (toJSON), Value (Null)) import Data.Foldable (toList) diff --git a/src/Render/TypeChecking.hs b/src/Render/TypeChecking.hs index 0ba57b8..8ac1ecc 100644 --- a/src/Render/TypeChecking.hs +++ b/src/Render/TypeChecking.hs @@ -4,7 +4,7 @@ import Agda.Syntax.Common import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Positivity.Occurrence import Render.Class -import Render.Common +import Render.Common () import Render.RichText instance Render NamedMeta where diff --git a/src/Server.hs b/src/Server.hs index 41fd5a6..0be8984 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -6,27 +6,21 @@ module Server (run) where import qualified Agda -import Control.Concurrent (writeChan) import Control.Monad (void) import Control.Monad.Reader (MonadIO (liftIO)) -import Data.Aeson - ( FromJSON, - ToJSON, - ) import qualified Data.Aeson as JSON import Data.Text (pack) import GHC.IO.IOMode (IOMode (ReadWriteMode)) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types (HoverParams (..), SaveOptions (..), TextDocumentIdentifier (..), TextDocumentSyncKind (..), TextDocumentSyncOptions (..), type (|?) (..)) import Language.LSP.Server hiding (Options) -import qualified Language.LSP.Server hiding (Options) import qualified Language.LSP.Server as LSP import Monad import qualified Network.Simple.TCP as TCP import Network.Socket (socketToHandle) import Options import qualified Server.Handler as Handler -import Switchboard (Switchboard, agdaCustomMethod) +import Switchboard (agdaCustomMethod) import qualified Switchboard import Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) import Server.Handler.TextDocument.FileManagement (didOpenHandler, didCloseHandler, didSaveHandler) @@ -85,16 +79,6 @@ run options = do lspOptions :: LSP.Options lspOptions = LSP.defaultOptions {optTextDocumentSync = Just syncOptions} --- these `TextDocumentSyncOptions` are essential for receiving notifications from the client --- syncOptions :: TextDocumentSyncOptions --- syncOptions = --- TextDocumentSyncOptions --- { _openClose = Just True, -- receive open and close notifications from the client --- _change = Just changeOptions, -- receive change notifications from the client --- _willSave = Just False, -- receive willSave notifications from the client --- _willSaveWaitUntil = Just False, -- receive willSave notifications from the client --- _save = Just $ InR saveOptions --- } syncOptions :: TextDocumentSyncOptions syncOptions = TextDocumentSyncOptions diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs index 187e06b..f6cc244 100644 --- a/src/Server/AgdaLibResolver.hs +++ b/src/Server/AgdaLibResolver.hs @@ -3,8 +3,7 @@ module Server.AgdaLibResolver (findAgdaLib) where import Agda.Interaction.Library (AgdaLibFile) import Agda.Interaction.Library.Parse.More (parseLibFile, runP) import Agda.Utils.Either (maybeRight) -import Agda.Utils.Maybe (caseMaybe, ifJust, listToMaybe) -import qualified Language.LSP.Protocol.Types as LSP +import Agda.Utils.Maybe (caseMaybe, listToMaybe) import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) import qualified Server.Filesystem as FS import qualified Server.Model as Model @@ -24,7 +23,7 @@ findAgdaLib isFileId = do result <- searchFilesystemForAgdaLib provider fileId lib <- case result of Just lib -> return lib - Nothing -> initAgdaLib + Nothing -> return initAgdaLib modifyModel $ Model.withAgdaLib lib return lib diff --git a/src/Server/AgdaProjectResolver.hs b/src/Server/AgdaProjectResolver.hs index 06cffb3..f7a2e27 100644 --- a/src/Server/AgdaProjectResolver.hs +++ b/src/Server/AgdaProjectResolver.hs @@ -1,6 +1,6 @@ module Server.AgdaProjectResolver (findAgdaProject) where -import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) +import Monad (ServerM, askModel, modifyModel) import Server.AgdaLibResolver (findAgdaLib) import qualified Server.Filesystem as FS import qualified Server.Model as Model diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs index 6b55725..73822bc 100644 --- a/src/Server/Filesystem.hs +++ b/src/Server/Filesystem.hs @@ -25,17 +25,16 @@ import Agda.Syntax.Common.Pretty (Pretty, pretty, prettyShow) import Agda.Utils.Either (maybeRight) import Agda.Utils.FileName (AbsolutePath, absolute, sameFile) import Agda.Utils.IO (catchIO) -import Agda.Utils.IO.UTF8 (ReadException, readTextFile) +import Agda.Utils.IO.UTF8 (readTextFile) import Agda.Utils.List (nubM) -import Agda.Utils.Maybe (fromMaybe, maybe) -import Control.Exception (try, tryJust) +import Agda.Utils.Maybe (fromMaybe) +import Control.Exception (try) import qualified Control.Exception as E import Control.Monad (foldM, forM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Strict as Strict import Data.Text (Text) import qualified Data.Text as Text -import Language.LSP.Protocol.Types (NormalizedUri) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Types.Uri.More as LSP import Language.LSP.Server (MonadLsp) diff --git a/src/Server/Handler.hs b/src/Server/Handler.hs index 1f3b64a..558c8c4 100644 --- a/src/Server/Handler.hs +++ b/src/Server/Handler.hs @@ -19,8 +19,6 @@ import Agda.Interaction.Base ( CommandQueue(..) import Agda.Interaction.BasicOps ( atTopLevel , typeInCurrent ) -import Agda.Interaction.Highlighting.Precise - ( HighlightingInfo ) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.InteractionTop ( cmd_load' @@ -49,9 +47,7 @@ import Agda.Syntax.Parser ( exprParser ) import Agda.Syntax.Translation.ConcreteToAbstract ( concreteToAbstract_ ) -import Agda.TypeChecking.Monad ( HasOptions(commandLineOptions) - , setInteractionOutputCallback - ) +import Agda.TypeChecking.Monad ( setInteractionOutputCallback ) #if MIN_VERSION_Agda(2,8,0) import Agda.Interaction.Command ( CommandM, localStateCommandM ) import Agda.TypeChecking.Monad.Trace ( runPM ) @@ -68,15 +64,10 @@ import Data.Text ( Text , pack , unpack ) -import qualified Data.Text as Text -import Language.LSP.Server ( LspM ) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.VFS as VFS import Monad -import Options ( Config - , Options(optRawAgdaOptions) - ) initialiseCommandQueue :: IO CommandQueue initialiseCommandQueue = CommandQueue <$> newTChanIO <*> newTVarIO Nothing diff --git a/src/Server/Handler/TextDocument/DocumentSymbol.hs b/src/Server/Handler/TextDocument/DocumentSymbol.hs index d82f581..768e9c4 100644 --- a/src/Server/Handler/TextDocument/DocumentSymbol.hs +++ b/src/Server/Handler/TextDocument/DocumentSymbol.hs @@ -1,10 +1,8 @@ module Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) where import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Maybe (fromMaybe, mapMaybe) import Agda.Utils.Monad (forMaybeM) -import Control.Monad (forM) import Control.Monad.Trans (lift) import Data.Map (Map) import qualified Data.Map as Map @@ -13,13 +11,13 @@ import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM) -import Server.Model.AgdaFile (AgdaFile, agdaFileSymbols, defNameRange, symbolByName, symbolsByParent) +import Server.Model.AgdaFile (AgdaFile, defNameRange, symbolByName, symbolsByParent) import Server.Model.Handler (requestHandlerWithAgdaFile) -import Server.Model.Monad (MonadAgdaFile (askAgdaFile), useAgdaFile) +import Server.Model.Monad (MonadAgdaFile (askAgdaFile)) import Server.Model.Symbol (SymbolInfo (symbolName), SymbolKind (..), lspSymbolKind, symbolKind, symbolShortName, symbolType) documentSymbolHandler :: LSP.Handlers ServerM -documentSymbolHandler = requestHandlerWithAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do +documentSymbolHandler = requestHandlerWithAgdaFile LSP.SMethod_TextDocumentDocumentSymbol $ \_req responder -> do file <- askAgdaFile let symbols = symbolsByParent file let topLevelNames = fromMaybe [] $ Map.lookup Nothing symbols diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index a060328..0f3f18e 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -5,22 +5,16 @@ module Server.Handler.TextDocument.FileManagement ) where -import Agda.Interaction.FindFile (SourceFile (SourceFile)) -import qualified Agda.Interaction.Imports.More as Imp import Agda.Interaction.Imports.Virtual (parseVSource, vSrcFromUri) import Agda.Syntax.Common.Pretty (prettyShow) -import Agda.TypeChecking.Monad (MonadTCM (liftTCM)) import Agda.Utils.Lens ((^.)) import Control.Monad.Trans (lift) -import Data.Strict (Strict (toLazy)) import qualified Data.Text as Text import Indexer (indexFile) import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidAbsolutePath) import qualified Language.LSP.Server as LSP -import qualified Language.LSP.VFS as VFS import Monad (ServerM, modifyModel, modifyVfsIndex) import qualified Server.Model as Model import Server.Model.Handler (notificationHandlerWithAgdaLib, takeOverNotificationHandlerWithAgdaLib) diff --git a/src/Server/Model.hs b/src/Server/Model.hs index 3ff320e..b63b7a2 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -12,14 +12,13 @@ module Server.Model where import Agda.Utils.Lens (Lens', over, (^.)) -import Control.Monad.IO.Class (MonadIO) import Data.Foldable (find) import Data.Functor ((<&>)) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.LSP.Protocol.Types as LSP import Server.Model.AgdaFile (AgdaFile) -import Server.Model.AgdaLib (AgdaLib, initAgdaLib, isAgdaLibForUri) +import Server.Model.AgdaLib (AgdaLib, isAgdaLibForUri) import Server.Model.AgdaProject (AgdaProject) import qualified Server.Model.AgdaProject as AgdaProject diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index 75f3832..e344dea 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Server.Model.AgdaLib ( AgdaLibOrigin (..), AgdaLib (AgdaLib), @@ -14,30 +12,21 @@ module Server.Model.AgdaLib ) where -import Agda.Interaction.Library ( - AgdaLibFile (_libIncludes, AgdaLibFile), - findProjectRoot, +import Agda.Interaction.Library + ( AgdaLibFile (AgdaLibFile), LibName, OptionsPragma (OptionsPragma), ) -import Agda.Interaction.Library.More (tryRunLibM) -import qualified Agda.TypeChecking.Monad as TCM -import Agda.Utils.IORef (IORef, newIORef) -import Agda.Utils.Lens (Lens', (<&>), (^.), set) -import Agda.Utils.Maybe (listToMaybe, catMaybes) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Map (Map) +import Agda.Interaction.Library.Base (libIncludes, libName, libPragmas) +import Agda.Syntax.Common.Pretty (Pretty, doubleQuotes, pretty, pshow, text, (<+>)) +import Agda.Utils.Lens (Lens', set, (<&>), (^.)) +import Agda.Utils.Null (empty) +import Control.Monad (forM) +import Control.Monad.IO.Class (MonadIO) import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Protocol.Types.Uri.More as LSP -import Server.Model.AgdaFile (AgdaFile) -import Agda.Interaction.Library.Base (libFile, LibName (..), libName, libIncludes, libPragmas) import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) -import Agda.Utils.Null (empty) -import Agda.Syntax.Common.Pretty (Pretty, pretty, vcat, prettyAssign, text, pshow, doubleQuotes, (<+>)) -import qualified Text.URI as ParsedUri -import qualified Data.Text as Text +import qualified Language.LSP.Protocol.Types.Uri.More as LSP import qualified Server.Filesystem as FS -import Control.Monad (forM) data AgdaLibOrigin = FromFile !FS.FileId | Defaulted deriving (Show, Eq) @@ -58,23 +47,12 @@ instance Pretty AgdaLib where <+> text "includes:" <+> pretty (agdaLib ^. agdaLibIncludes) -initAgdaLibWithOrigin :: (MonadIO m) => AgdaLibOrigin -> m AgdaLib -initAgdaLibWithOrigin origin = do -#if MIN_VERSION_Agda(2,8,0) - let libName = LibName "" [] - tcState <- liftIO TCM.initStateIO -#else - let libName = "" - let tcState = TCM.initState -#endif - let persistentState = TCM.stPersistentState tcState - let tcState' = tcState { TCM.stPersistentState = persistentState { TCM.stInteractionOutputCallback = \_ -> return () } } - tcStateRef <- liftIO $ newIORef tcState' - let tcEnv = TCM.initEnv +initAgdaLibWithOrigin :: AgdaLibOrigin -> AgdaLib +initAgdaLibWithOrigin origin = let optionsPragma = OptionsPragma [] empty - return $ AgdaLib libName [] optionsPragma [] origin + in AgdaLib empty [] optionsPragma [] origin -initAgdaLib :: (MonadIO m) => m AgdaLib +initAgdaLib :: AgdaLib initAgdaLib = initAgdaLibWithOrigin Defaulted agdaLibName :: Lens' AgdaLib LibName @@ -105,7 +83,7 @@ agdaLibFromFile agdaLibFile agdaLibIsFileId = do Nothing -> return . FS.LocalFilePath Just parent -> \include -> FS.LocalFilePath include `FS.fileIdRelativeTo` parent includes <- forM (agdaLibFile ^. libIncludes) includeToAbsolute - initAgdaLibWithOrigin (FromFile agdaLibFileId) + return (initAgdaLibWithOrigin (FromFile agdaLibFileId)) <&> set agdaLibName (agdaLibFile ^. libName) <&> set agdaLibIncludes includes <&> set agdaLibOptionsPragma (agdaLibFile ^. libPragmas) @@ -121,4 +99,4 @@ agdaLibToFile relativeToUri agdaLib = case agdaLib ^. agdaLibOrigin of uri = FS.fileIdToUri fileId above = LSP.uriHeightAbove uri relativeToUri filePath = LSP.uriToPossiblyInvalidFilePath uri - in Just $ AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) + in Just $ AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) diff --git a/src/Server/Model/AgdaProject.hs b/src/Server/Model/AgdaProject.hs index 609a96a..36a4af1 100644 --- a/src/Server/Model/AgdaProject.hs +++ b/src/Server/Model/AgdaProject.hs @@ -13,7 +13,7 @@ import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (IORef, newIORef) import Agda.Utils.Lens (Lens', (<&>), (^.)) import Control.Monad.IO.Class (MonadIO, liftIO) -import Server.Model.AgdaLib (AgdaLib, initAgdaLib) +import Server.Model.AgdaLib (AgdaLib) import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) data AgdaProject = AgdaProject diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index c29e1fd..aa89513 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -12,25 +12,21 @@ module Server.Model.Handler ) where -import Agda.Syntax.Common (WithHiding (whHiding)) import Agda.Syntax.Common.Pretty (prettyShow) import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Pretty as TCM import Agda.Utils.Either (fromRightM) import Agda.Utils.Lens ((^.)) -import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad.Trans (lift) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Protocol.Message as Lsp import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM, askModel, catchTCError) -import Server.AgdaLibResolver (findAgdaLib) import Server.AgdaProjectResolver (findAgdaProject) import qualified Server.Model as Model import Server.Model.Monad (WithAgdaFileM, WithAgdaProjectM, runWithAgdaFileT, runWithAgdaProjectT) -import qualified Server.Model.Monad as LSP #if MIN_VERSION_Agda(2,7,0) #else import Agda.TypeChecking.Errors () diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index e00f9ca..533dd8d 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -25,28 +25,17 @@ module Server.Model.Monad where import Agda.Interaction.Options (CommandLineOptions (optPragmaOptions), PragmaOptions) -import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position (getRange) -import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), MonadTrace, PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv (..), TCM, TCMT (..), TCState (stPersistentState), catchError_, modifyTCLens, setTCLens, stPragmaOptions, useTC, viewTC) +import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), MonadTCState (..), MonadTrace, PersistentTCState (stPersistentOptions), ReadTCState (..), TCEnv (..), TCM, TCMT (..), TCState (stPersistentState), modifyTCLens, setTCLens, stPragmaOptions, useTC) import qualified Agda.TypeChecking.Monad as TCM -import qualified Agda.TypeChecking.Pretty as TCM import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) -import Agda.Utils.Lens (Lens', locally, over, use, view, (<&>), (^.)) -import Agda.Utils.Monad (and2M, bracket_, ifNotM, unless) +import Agda.Utils.Lens (Lens', locally, over, view, (<&>), (^.)) +import Agda.Utils.Monad (and2M, bracket_, ifNotM) import Agda.Utils.Null (null) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask, asks) -import Control.Monad.Trans (MonadTrans, lift) -import qualified Data.Text as Text -import qualified Language.LSP.Protocol.Lens as LSP -import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Protocol.Types.Uri.More as LSP -import Language.LSP.Server (LspM) -import qualified Language.LSP.Server as LSP -import Monad (ServerM, ServerT, askModel, catchTCError) -import Options (Config) -import qualified Server.Model as Model +import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask) +import Control.Monad.Trans (MonadTrans) +import Monad (ServerM) import Server.Model.AgdaFile (AgdaFile) import Server.Model.AgdaLib (AgdaLib) import Server.Model.AgdaProject (AgdaProject) @@ -55,11 +44,6 @@ import Prelude hiding (null) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.FileId (File, getIdFile) #endif -#if MIN_VERSION_Agda(2,7,0) -import Agda.Interaction.Response (Response_boot(Resp_HighlightingInfo)) -#else -import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) -#endif -------------------------------------------------------------------------------- @@ -206,21 +190,6 @@ defaultTraceClosureCall cl m = do TCM.NoHighlighting {} -> True _ -> False - printHighlightingInfo remove info = do - modToSrc <- useTC TCM.stModuleToSource - method <- viewTC TCM.eHighlightingMethod - -- reportSDoc "highlighting" 50 $ - -- pure $ - -- vcat - -- [ "Printing highlighting info:", - -- nest 2 $ (text . show) info, - -- "File modules:", - -- nest 2 $ pretty modToSrc - -- ] - unless (null info) $ do - TCM.appInteractionOutputCallback $ - Resp_HighlightingInfo info remove method modToSrc - #if MIN_VERSION_Agda(2,8,0) -- Taken from TCMT implementation defaultFileFromId :: (MonadAgdaProject m) => TCM.FileId -> m File diff --git a/src/Switchboard.hs b/src/Switchboard.hs index 5d3183c..1f5a3d2 100644 --- a/src/Switchboard.hs +++ b/src/Switchboard.hs @@ -14,9 +14,6 @@ import Data.IORef import Data.Proxy (Proxy (Proxy)) import qualified Data.Text.IO as Text import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - ( TextDocumentSyncClientCapabilities (..), - ) import Language.LSP.Server import Monad import Options (Config) diff --git a/test/Test.hs b/test/Test.hs index f964065..2f7b6cd 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -11,8 +11,6 @@ import Test.Tasty import Test.Tasty.Options import qualified Test.Model as Model import qualified Test.ModelMonad as ModelMonad -import qualified Test.Indexer.Invariants as IndexerInvariants -import qualified Test.Indexer.NoAnonFunSymbol as NoAnonFunSymbol import qualified Test.Uri as URI import qualified Test.Indexer as Indexer import qualified Test.AgdaLibResolution as AgdaLibResolution diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index d435fda..cc0b45b 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -5,17 +5,15 @@ module Test.AgdaLibResolution (tests) where #if MIN_VERSION_Agda(2,8,0) import Agda.Interaction.Library (parseLibName) #endif -import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Lens ((^.)) import Control.Monad.IO.Class (liftIO) -import Indexer (indexFile, usingSrcAsCurrent) -import qualified Language.LSP.Protocol.Types as LSP +import Indexer (indexFile) import qualified Language.LSP.Server as LSP import Monad (runServerT) import Server.AgdaLibResolver (findAgdaLib) import qualified Server.Filesystem as FS import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName, agdaLibOrigin) -import Server.Model.Monad (MonadAgdaProject, askAgdaLib, runWithAgdaProjectT) +import Server.Model.Monad (runWithAgdaProjectT) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) diff --git a/test/Test/Indexer/Invariants/NoMissing.hs b/test/Test/Indexer/Invariants/NoMissing.hs index 33cc208..b959516 100644 --- a/test/Test/Indexer/Invariants/NoMissing.hs +++ b/test/Test/Indexer/Invariants/NoMissing.hs @@ -9,7 +9,7 @@ import Agda.Position (FromOffset, fromOffset, makeFromOffset) import Agda.Syntax.Common.Pretty (Pretty, align, pretty, prettyList, prettyShow, pshow, text, vcat, (<+>)) import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.Lens ((^.)) -import Agda.Utils.Maybe (isJust, isNothing) +import Agda.Utils.Maybe (isNothing) import Agda.Utils.RangeMap (PairInt (PairInt), RangeMap (rangeMap)) import Control.Monad (forM_, guard) import Control.Monad.Writer.CPS (Writer, execWriter, tell) diff --git a/test/Test/Indexer/Invariants/NoOverlap.hs b/test/Test/Indexer/Invariants/NoOverlap.hs index 7bdb0ec..dcbd632 100644 --- a/test/Test/Indexer/Invariants/NoOverlap.hs +++ b/test/Test/Indexer/Invariants/NoOverlap.hs @@ -3,9 +3,9 @@ module Test.Indexer.Invariants.NoOverlap (testNoOverlap) where import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common.Pretty (Doc, Pretty (prettyList), align, parens, pretty, prettyShow, text, vcat, (<+>)) +import Agda.Syntax.Common.Pretty (Doc, Pretty (prettyList), align, pretty, prettyShow, text, vcat, (<+>)) import Agda.Utils.Lens ((^.)) -import Control.Monad (forM, forM_) +import Control.Monad (forM_) import Control.Monad.Writer.CPS (Writer, execWriter, tell) import Data.Foldable (foldrM) import Data.IntMap (IntMap) diff --git a/test/Test/Indexer/NoAnonFunSymbol.hs b/test/Test/Indexer/NoAnonFunSymbol.hs index 4a6f997..60117c2 100644 --- a/test/Test/Indexer/NoAnonFunSymbol.hs +++ b/test/Test/Indexer/NoAnonFunSymbol.hs @@ -2,8 +2,7 @@ module Test.Indexer.NoAnonFunSymbol (tests) where import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Lens ((^.)) -import Agda.Utils.Maybe (ifJustM, whenJust, whenJustM) -import Control.Monad (forM) +import Agda.Utils.Maybe (whenJust) import Data.Foldable (find) import Data.List (isInfixOf) import qualified Data.Map as Map diff --git a/test/Test/Indexer/Reload.hs b/test/Test/Indexer/Reload.hs index c0f2a3d..b5dec65 100644 --- a/test/Test/Indexer/Reload.hs +++ b/test/Test/Indexer/Reload.hs @@ -1,7 +1,5 @@ module Test.Indexer.Reload (tests) where -import Agda.Interaction.Imports.Virtual (parseSourceFromContents) -import Agda.Syntax.Common.Pretty (prettyShow) import Control.Monad.IO.Class (liftIO) import qualified Data.Text as Text import Indexer (indexFile) @@ -11,7 +9,7 @@ import Monad (runServerT) import Server.AgdaProjectResolver (findAgdaProject) import Server.Model.Monad (runWithAgdaProjectT) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (testCase, (@?=)) import qualified TestData tests :: TestTree diff --git a/test/Test/Model.hs b/test/Test/Model.hs index e4f5432..7a5b3d9 100644 --- a/test/Test/Model.hs +++ b/test/Test/Model.hs @@ -1,13 +1,9 @@ module Test.Model (tests) where -import Agda.Utils.Lens (set, (<&>), (^.)) +import Agda.Utils.Lens ((^.)) import Agda.Utils.Maybe (isJust, isNothing) -import qualified Data.Map as Map -import qualified Language.LSP.Protocol.Types as LSP -import Server.Model (Model (Model)) import qualified Server.Model as Model -import Server.Model.AgdaFile (emptyAgdaFile) -import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import Server.Model.AgdaLib (agdaLibIncludes) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) import qualified TestData diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index 7c6844f..1e0aa09 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -5,25 +5,20 @@ module Test.ModelMonad (tests) where -import qualified Agda.Compiler.Backend as TestData import Agda.Utils.Either (isLeft, isRight) import Agda.Utils.IORef (newIORef, readIORef, writeIORef) import Agda.Utils.Lens ((^.)) -import Control.Concurrent (newChan) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap import qualified Language.LSP.Server as LSP -import Monad (Env (Env, envModel), ServerT, createInitEnv, runServerT) -import Options (Config, defaultOptions, initConfig) -import qualified Server.CommandController as CommandController +import Monad (ServerT, runServerT) +import Options (Config) import Server.Model (Model) import Server.Model.AgdaLib (agdaLibIncludes) import Server.Model.Handler (requestHandlerWithAgdaFile) -import Server.Model.Monad (MonadAgdaProject, askAgdaLib) -import qualified Server.ResponseController as ResponseController +import Server.Model.Monad (askAgdaLib) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?), (@?=)) import qualified TestData diff --git a/test/Test/SrcLoc.hs b/test/Test/SrcLoc.hs index c3928b7..5d5640c 100644 --- a/test/Test/SrcLoc.hs +++ b/test/Test/SrcLoc.hs @@ -2,7 +2,6 @@ module Test.SrcLoc where import Agda.Position import qualified Data.IntMap as IntMap -import Data.List (sort) import Data.Text (Text) import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Test/WASM.hs b/test/Test/WASM.hs index 0f8584c..7a9b083 100644 --- a/test/Test/WASM.hs +++ b/test/Test/WASM.hs @@ -4,7 +4,6 @@ module Test.WASM (tests) where import Test.Tasty -import Test.Tasty.HUnit #if defined(wasm32_HOST_ARCH) diff --git a/test/TestData.hs b/test/TestData.hs index 7ab0d26..8259e92 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -17,49 +17,50 @@ module TestData where import Agda.Interaction.FindFile - ( SourceFile (SourceFile), + ( #if MIN_VERSION_Agda(2,8,0) + SourceFile, #else - srcFilePath, + SourceFile (SourceFile), #endif ) import qualified Agda.Interaction.Imports as Imp +import Agda.Interaction.Imports.Virtual (parseSourceFromContents) import qualified Agda.Interaction.Options import Agda.Syntax.Abstract.More () import Agda.Syntax.Common.Pretty (prettyShow) -import Agda.Syntax.Translation.ConcreteToAbstract (topLevelDecls) import qualified Agda.TypeChecking.Monad as TCM +import Agda.TypeChecking.Pretty (prettyTCM) import Agda.Utils.FileName (absolute) import Agda.Utils.IORef (newIORef) -import Agda.Utils.Lens (set, (<&>)) +import Agda.Utils.Lens (set) import Control.Concurrent (newChan) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Function ((&)) import qualified Data.Map as Map -import Indexer (indexFile, withAstFor, usingSrcAsCurrent) +import Data.Text (Text) +import Indexer (indexFile, usingSrcAsCurrent) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Monad (Env (Env), runServerT, catchTCError) +import Monad (Env (Env), catchTCError, runServerT) import Options (defaultOptions, initConfig) +import Server.AgdaProjectResolver (findAgdaProject) import qualified Server.CommandController as CommandController +import qualified Server.Filesystem as FS import Server.Model (Model (Model)) import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import qualified Server.Model.AgdaProject as AgdaProject import Server.Model.Monad (MonadAgdaProject, runWithAgdaProjectT) import qualified Server.ResponseController as ResponseController -import System.FilePath (takeBaseName, ()) -import Agda.TypeChecking.Pretty (prettyTCM) -import Data.Text (Text) -import Agda.Interaction.Imports.Virtual (parseSourceFromContents) -import qualified Server.Filesystem as FS import qualified Server.VfsIndex as VfsIndex -import Server.AgdaProjectResolver (findAgdaProject) -import qualified Server.Model.AgdaProject as AgdaProject +import System.FilePath (takeBaseName) data AgdaFileDetails = AgdaFileDetails - { fileName :: String, - agdaFile :: AgdaFile, - interface :: TCM.Interface + { fileName :: !String, + agdaFile :: !AgdaFile, + interface :: !TCM.Interface } agdaFileDetails :: FilePath -> IO AgdaFileDetails @@ -82,9 +83,12 @@ agdaFileDetails inPath = do t <- TCM.liftTCM $ prettyTCM err error $ prettyShow t - interface <- (withSrc $ \src -> usingSrcAsCurrent src $ do - checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src - return $ Imp.crInterface checkResult) `catchTCError` onErr + interface <- + ( withSrc $ \src -> usingSrcAsCurrent src $ do + checkResult <- TCM.liftTCM $ Imp.typeCheckMain Imp.TypeCheck src + return $ Imp.crInterface checkResult + ) + `catchTCError` onErr file <- withSrc indexFile `catchTCError` onErr @@ -110,7 +114,7 @@ parseSourceFromPathAndContents :: (TCM.MonadTCM m, TCM.MonadTrace m, MonadAgdaProject m) => FilePath -> Text -> - m Imp.Source + m Imp.Source parseSourceFromPathAndContents path contents = do srcFile <- sourceFileFromPath path let uri = LSP.toNormalizedUri $ LSP.filePathToUri path @@ -153,17 +157,13 @@ getModel = do "file:///home/user2/project2/", "https://example.com/agda/" ] - testLib1 <- - initAgdaLib - <&> set agdaLibIncludes includes1 + let testLib1 = initAgdaLib & set agdaLibIncludes includes1 testProject1 <- AgdaProject.new testLib1 let includes2 = FS.Uri . LSP.toNormalizedUri . LSP.Uri <$> ["file:///home/user/project2/"] - testLib2 <- - initAgdaLib - <&> set agdaLibIncludes includes2 + let testLib2 = initAgdaLib & set agdaLibIncludes includes2 testProject2 <- AgdaProject.new testLib2 let libs = [testLib1, testLib2] From 1fb3974536d73e81c3074a5304c7ff5d27eba7d9 Mon Sep 17 00:00:00 2001 From: nvarner Date: Sun, 23 Nov 2025 09:20:00 -0600 Subject: [PATCH 41/47] Very WIP library dependency resolution --- agda-language-server.cabal | 10 +- src/Agda/Interaction/Imports/Virtual.hs | 2 +- src/Agda/Interaction/Library/More.hs | 21 +++- src/Agda/Interaction/Library/Parse/More.hs | 5 + src/Agda/TypeChecking/Monad/Options/More.hs | 78 +++++++------- src/Indexer.hs | 8 +- src/Indexer/Prepare.hs | 95 +++++++++++++++++ src/Monad.hs | 2 +- src/Server/AgdaLibResolver.hs | 112 +++++++++++--------- src/Server/AgdaProjectResolver.hs | 47 +++++--- src/Server/Filesystem.hs | 43 ++++++-- src/Server/Model.hs | 35 +++--- src/Server/Model/AgdaLib.hs | 67 +++++------- src/Server/Model/AgdaProject.hs | 19 +++- src/Server/Model/InstalledLibsFile.hs | 63 +++++++++++ src/Server/Model/Monad.hs | 8 +- test/Test/AgdaLibResolution.hs | 37 ++++--- test/Test/Model.hs | 28 ++--- test/Test/ModelMonad.hs | 22 ++-- test/TestData.hs | 15 +-- 20 files changed, 481 insertions(+), 236 deletions(-) create mode 100644 src/Indexer/Prepare.hs create mode 100644 src/Server/Model/InstalledLibsFile.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 0bce0f7..fc67a75 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -63,6 +63,7 @@ library Indexer.Indexer Indexer.Monad Indexer.Postprocess + Indexer.Prepare Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad @@ -92,6 +93,7 @@ library Server.Model.AgdaLib Server.Model.AgdaProject Server.Model.Handler + Server.Model.InstalledLibsFile Server.Model.Monad Server.Model.Symbol Server.ResponseController @@ -106,7 +108,7 @@ library OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans build-depends: Agda , aeson @@ -153,7 +155,7 @@ executable als OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror -rtsopts + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -rtsopts build-depends: Agda , aeson @@ -225,6 +227,7 @@ test-suite als-test Indexer.Indexer Indexer.Monad Indexer.Postprocess + Indexer.Prepare Language.LSP.Protocol.Types.More Language.LSP.Protocol.Types.Uri.More Monad @@ -254,6 +257,7 @@ test-suite als-test Server.Model.AgdaLib Server.Model.AgdaProject Server.Model.Handler + Server.Model.InstalledLibsFile Server.Model.Monad Server.Model.Symbol Server.ResponseController @@ -268,7 +272,7 @@ test-suite als-test OverloadedStrings PatternSynonyms TypeOperators - ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -Werror -rtsopts + ghc-options: -Wincomplete-patterns -Werror=incomplete-patterns -Wunused-local-binds -Wunused-pattern-binds -Wunused-do-bind -Wunused-foralls -Wunused-imports -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Wsimplifiable-class-constraints -fno-warn-orphans -rtsopts build-depends: Agda , aeson diff --git a/src/Agda/Interaction/Imports/Virtual.hs b/src/Agda/Interaction/Imports/Virtual.hs index 843a141..cfcbe90 100644 --- a/src/Agda/Interaction/Imports/Virtual.hs +++ b/src/Agda/Interaction/Imports/Virtual.hs @@ -81,7 +81,7 @@ parseSourceFromContents srcUri srcFile contentsStrict = do parsedModName <- TCM.liftTCM $ Imp.moduleName f parsedMod agdaLib <- askAgdaLib - let libs = maybeToList $ agdaLibToFile srcUri agdaLib + let libs = maybeToList $ agdaLibToFile srcUri <$> agdaLib return Imp.Source diff --git a/src/Agda/Interaction/Library/More.hs b/src/Agda/Interaction/Library/More.hs index e609a90..669f882 100644 --- a/src/Agda/Interaction/Library/More.hs +++ b/src/Agda/Interaction/Library/More.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} module Agda.Interaction.Library.More - ( tryRunLibM, + ( defaultLibraryFileIds, + tryRunLibM, #if MIN_VERSION_Agda(2,8,0) #else runLibErrorIO, @@ -29,6 +30,24 @@ import Control.Monad.State.Lazy (evalStateT) import Control.Monad.Writer.Lazy (runWriterT) import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) import Agda.Utils.Lens ((^.)) +import Agda.Utils.List1 (List1, NonEmpty ((:|))) +import Agda.Version (version) +import qualified Server.Filesystem as FS + +-- | The @~/.agda/libraries@ file lists the libraries Agda should know about. +-- The content of @libraries@ is a list of paths to @.agda-lib@ files. +-- +-- Agda honors also version-specific @libraries@ files, e.g. @libraries-2.6.0@. +-- +-- @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process +-- by default. The first file in this list that exists is actually used. +-- +defaultLibraryFiles :: List1 FilePath +defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : [] + +defaultLibraryFileIds :: (MonadIO m) => FS.FileId -> m (List1 FS.FileId) +defaultLibraryFileIds agdaDir = + traverse (`FS.fileIdRelativeTo` agdaDir) . fmap FS.LocalFilePath $ defaultLibraryFiles #if MIN_VERSION_Agda(2,8,0) -- Unneeded in 2.8.0 due to API changes diff --git a/src/Agda/Interaction/Library/Parse/More.hs b/src/Agda/Interaction/Library/Parse/More.hs index e41fe03..27bf62d 100644 --- a/src/Agda/Interaction/Library/Parse/More.hs +++ b/src/Agda/Interaction/Library/Parse/More.hs @@ -10,6 +10,7 @@ module Agda.Interaction.Library.Parse.More ( parseLibFile, runP, + trimLineComment, ) where @@ -277,6 +278,10 @@ groupLines (Header _ h : ls) = (GenericEntry h [c | Content _ c <- cs] :) <$> gr splitCommas :: String -> [String] splitCommas = words . map (\c -> if c == ',' then ' ' else c) +-- | Remove leading whitespace and line comment. +trimLineComment :: String -> String +trimLineComment = stripComments . ltrim + -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String stripComments "" = "" diff --git a/src/Agda/TypeChecking/Monad/Options/More.hs b/src/Agda/TypeChecking/Monad/Options/More.hs index b1ed972..b8f3168 100644 --- a/src/Agda/TypeChecking/Monad/Options/More.hs +++ b/src/Agda/TypeChecking/Monad/Options/More.hs @@ -1,4 +1,4 @@ -module Agda.TypeChecking.Monad.Options.More (setCommandLineOptionsByLib) where +module Agda.TypeChecking.Monad.Options.More () where import Agda.Interaction.Options (CommandLineOptions (..)) import qualified Agda.Interaction.Options.Lenses as Lens @@ -15,45 +15,45 @@ import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes) import Server.Model.Monad (MonadAgdaProject, askAgdaLib) import System.Directory (getCurrentDirectory) -setCommandLineOptionsByLib :: - (MonadTCM m, MonadAgdaProject m) => - CommandLineOptions -> - m () -setCommandLineOptionsByLib opts = do - root <- liftIO (absolute =<< getCurrentDirectory) - setCommandLineOptionsByLib' root opts +-- setCommandLineOptionsByLib :: +-- (MonadTCM m, MonadAgdaProject m) => +-- CommandLineOptions -> +-- m () +-- setCommandLineOptionsByLib opts = do +-- root <- liftIO (absolute =<< getCurrentDirectory) +-- setCommandLineOptionsByLib' root opts -setCommandLineOptionsByLib' :: - (MonadTCM m, MonadAgdaProject m) => - AbsolutePath -> - CommandLineOptions -> - m () -setCommandLineOptionsByLib' root opts = do - incs <- case optAbsoluteIncludePaths opts of - [] -> do - opts' <- setLibraryPathsByLib opts - let incs = optIncludePaths opts' - TCM.liftTCM $ TCM.setIncludeDirs incs root - List1.toList <$> TCM.getIncludeDirs - incs -> return incs - TCM.modifyTC $ Lens.setCommandLineOptions opts {optAbsoluteIncludePaths = incs} - TCM.liftTCM $ TCM.setPragmaOptions (optPragmaOptions opts) - TCM.liftTCM updateBenchmarkingStatus +-- setCommandLineOptionsByLib' :: +-- (MonadTCM m, MonadAgdaProject m) => +-- AbsolutePath -> +-- CommandLineOptions -> +-- m () +-- setCommandLineOptionsByLib' root opts = do +-- incs <- case optAbsoluteIncludePaths opts of +-- [] -> do +-- opts' <- setLibraryPathsByLib opts +-- let incs = optIncludePaths opts' +-- TCM.liftTCM $ TCM.setIncludeDirs incs root +-- List1.toList <$> TCM.getIncludeDirs +-- incs -> return incs +-- TCM.modifyTC $ Lens.setCommandLineOptions opts {optAbsoluteIncludePaths = incs} +-- TCM.liftTCM $ TCM.setPragmaOptions (optPragmaOptions opts) +-- TCM.liftTCM updateBenchmarkingStatus -setLibraryPathsByLib :: - (MonadTCM m, MonadAgdaProject m) => - CommandLineOptions -> - m CommandLineOptions -setLibraryPathsByLib o = do - agdaLib <- askAgdaLib - return $ addDefaultLibrariesByLib agdaLib o +-- setLibraryPathsByLib :: +-- (MonadTCM m, MonadAgdaProject m) => +-- CommandLineOptions -> +-- m CommandLineOptions +-- setLibraryPathsByLib o = do +-- agdaLib <- askAgdaLib +-- return $ addDefaultLibrariesByLib agdaLib o --- TODO: resolve dependency libs; see setLibraryIncludes in Agda +-- -- TODO: resolve dependency libs; see setLibraryIncludes in Agda -addDefaultLibrariesByLib :: AgdaLib -> CommandLineOptions -> CommandLineOptions -addDefaultLibrariesByLib agdaLib o - | not (null $ optLibraries o) || not (optUseLibs o) = o - | otherwise = do - let libs = agdaLib ^. agdaLibDependencies - let incs = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes - o {optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs} +-- addDefaultLibrariesByLib :: AgdaLib -> CommandLineOptions -> CommandLineOptions +-- addDefaultLibrariesByLib agdaLib o +-- | not (null $ optLibraries o) || not (optUseLibs o) = o +-- | otherwise = do +-- let libs = agdaLib ^. agdaLibDependencies +-- let incs = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes +-- o {optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs} diff --git a/src/Indexer.hs b/src/Indexer.hs index a66866c..a762b85 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -16,13 +16,13 @@ import qualified Agda.Interaction.Imports.More as Imp import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Translation.ConcreteToAbstract (ToAbstract (toAbstract), TopLevel (TopLevel), TopLevelInfo) import qualified Agda.TypeChecking.Monad as TCM -import Agda.TypeChecking.Monad.Options.More (setCommandLineOptionsByLib) import qualified Data.Map as Map import Indexer.Indexer (indexAst) import Indexer.Monad (execIndexerM) import Indexer.Postprocess (postprocess) import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (WithAgdaProjectM) +import Indexer.Prepare (setCommandLineOptionsByLib) usingSrcAsCurrent :: Imp.Source -> WithAgdaProjectM a -> WithAgdaProjectM a usingSrcAsCurrent src x = do @@ -30,9 +30,9 @@ usingSrcAsCurrent src x = do TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src - TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ - -- Now reset the options - setCommandLineOptionsByLib . TCM.stPersistentOptions . TCM.stPersistentState =<< TCM.getTC + TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ do + persistentOptions <- TCM.stPersistentOptions . TCM.stPersistentState <$> TCM.getTC + setCommandLineOptionsByLib persistentOptions #if MIN_VERSION_Agda(2,8,0) TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) diff --git a/src/Indexer/Prepare.hs b/src/Indexer/Prepare.hs new file mode 100644 index 0000000..e10efca --- /dev/null +++ b/src/Indexer/Prepare.hs @@ -0,0 +1,95 @@ +module Indexer.Prepare (setCommandLineOptionsByLib) where + +import Agda.Interaction.Library (LibName) +import Agda.Interaction.Library.Base (libNameForCurrentDir) +import Agda.Interaction.Options (CommandLineOptions (..)) +import qualified Agda.Interaction.Options.Lenses as Lens +import qualified Agda.TypeChecking.Monad as TCM +import Agda.TypeChecking.Monad.Benchmark (updateBenchmarkingStatus) +import Agda.Utils.FileName (AbsolutePath, absolute) +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.Utils.Lens ((^.)) +import qualified Agda.Utils.List1 as List1 +import Agda.Utils.Maybe (ifJustM, maybeToList) +import Agda.Utils.Monad (lift) +import Control.Monad.IO.Class (liftIO) +import qualified Server.AgdaLibResolver as AgdaLibResolver +import qualified Server.Filesystem as FS +import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes, agdaLibName) +import Server.Model.Monad (MonadAgdaProject, WithAgdaProjectM, askAgdaLib) +import System.Directory (getCurrentDirectory) + +setCommandLineOptionsByLib :: CommandLineOptions -> WithAgdaProjectM () +setCommandLineOptionsByLib opts = do + root <- liftIO (absolute =<< getCurrentDirectory) + setCommandLineOptionsByLib' root opts + +setCommandLineOptionsByLib' :: AbsolutePath -> CommandLineOptions -> WithAgdaProjectM () +setCommandLineOptionsByLib' root opts = do + incs <- case optAbsoluteIncludePaths opts of + [] -> do + opts' <- updateOptionsWithDependencyLibs opts + let incs = optIncludePaths opts' + TCM.liftTCM $ TCM.setIncludeDirs incs root + List1.toList <$> TCM.getIncludeDirs + incs -> return incs + TCM.modifyTC $ Lens.setCommandLineOptions opts {optAbsoluteIncludePaths = incs} + TCM.liftTCM $ TCM.setPragmaOptions (optPragmaOptions opts) + TCM.liftTCM updateBenchmarkingStatus + +-- | Determine the libraries we directly depend on +directDependencyLibNames :: + (MonadAgdaProject m) => + -- | Persistent command line options + CommandLineOptions -> + m [LibName] +directDependencyLibNames persistentOptions + | not (null $ optLibraries persistentOptions) = return $ optLibraries persistentOptions + | not (optUseLibs persistentOptions) = return [] + | otherwise = + ifJustM + askAgdaLib + (\agdaLib -> return $ agdaLib ^. agdaLibDependencies) + (defaultLibNames persistentOptions) + +-- | Determine the libraries we depend on when there is no .agda-lib +-- TODO: read from default file +defaultLibNames :: + (MonadAgdaProject m) => + CommandLineOptions -> + m [LibName] +defaultLibNames persistentOptions + | optDefaultLibs persistentOptions = return [libNameForCurrentDir] + | otherwise = return [] + +dependencyLibs :: CommandLineOptions -> WithAgdaProjectM [AgdaLib] +dependencyLibs persistentOptions = do + directDependencies <- directDependencyLibNames persistentOptions + installed <- lift $ AgdaLibResolver.installedLibraries (FS.LocalFilePath <$> optOverrideLibrariesFile persistentOptions) + let libs = resolveDeps installed directDependencies [] [] + case libs of + Nothing -> __IMPOSSIBLE__ -- TODO: very wrong, do real error handling + Just libs -> do + projectLib <- askAgdaLib + return $ maybeToList projectLib <> libs + where + resolveDeps :: [AgdaLib] -> [LibName] -> [LibName] -> [AgdaLib] -> Maybe [AgdaLib] + resolveDeps _installed [] _doneNames doneLibs = Just doneLibs + resolveDeps installed (next : todo) doneNames doneLibs + | next `elem` doneNames = resolveDeps installed todo doneNames doneLibs + | otherwise = do + lib <- AgdaLibResolver.byLibName next installed + let newDeps = lib ^. agdaLibDependencies + resolveDeps installed (newDeps <> todo) (next : doneNames) (lib : doneLibs) + +updateOptionsWithDependencyLibs :: CommandLineOptions -> WithAgdaProjectM CommandLineOptions +updateOptionsWithDependencyLibs o = do + libs <- dependencyLibs o + let includes = concatMap (^. agdaLibIncludes) libs + let libNames = fmap (^. agdaLibName) libs + let includePaths = FS.fileIdToPossiblyInvalidFilePath <$> includes + return $ + o + { optIncludePaths = includePaths <> optIncludePaths o, + optLibraries = libNames + } diff --git a/src/Monad.hs b/src/Monad.hs index c86f851..5ce9326 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -65,7 +65,7 @@ createInitEnv options = <*> liftIO ResponseController.new <*> (pure $ FS.Layered [FS.Wrap FS.LspVirtualFilesystem, FS.Wrap FS.OsFilesystem]) <*> liftIO (newIORef VfsIndex.empty) - <*> liftIO (newIORef Model.empty) + <*> liftIO (newIORef Model.mkEmpty) -------------------------------------------------------------------------------- diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs index f6cc244..7ad8b2d 100644 --- a/src/Server/AgdaLibResolver.hs +++ b/src/Server/AgdaLibResolver.hs @@ -1,61 +1,73 @@ -module Server.AgdaLibResolver (findAgdaLib) where +module Server.AgdaLibResolver + ( byFileId, + byLibName, + installedLibraries, + ) +where -import Agda.Interaction.Library (AgdaLibFile) +import Agda.Interaction.Library (AgdaLibFile, LibName) +import Agda.Interaction.Library.Base (libName) +import Agda.Interaction.Library.More (defaultLibraryFileIds) import Agda.Interaction.Library.Parse.More (parseLibFile, runP) +import Agda.Setup (getAgdaAppDir) import Agda.Utils.Either (maybeRight) -import Agda.Utils.Maybe (caseMaybe, listToMaybe) +import Agda.Utils.Lens ((^.)) +import Agda.Utils.List (nubOn) +import Agda.Utils.Maybe (caseMaybeM, listToMaybe) +import Agda.Utils.Monad (mapMaybeM) +import Agda.Utils.Singleton (Singleton (singleton)) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (Foldable (toList), find) import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) +import Server.Filesystem (FileId (LocalFilePath)) import qualified Server.Filesystem as FS import qualified Server.Model as Model -import Server.Model.AgdaLib (AgdaLib, agdaLibFromFile, initAgdaLib) +import Server.Model.AgdaLib (AgdaLib, agdaLibFromFile, agdaLibName) +import Server.Model.InstalledLibsFile (InstalledLibsFile) +import qualified Server.Model.InstalledLibsFile as InstalledLibsFile --- | Find cached 'AgdaLib', or else make one from @.agda-lib@ files on the file --- system, or else provide a default -findAgdaLib :: (FS.IsFileId f) => f -> ServerM AgdaLib -findAgdaLib isFileId = do - let fileId = FS.toFileId isFileId - let uri = FS.fileIdToUri fileId +byFileId :: FS.FileId -> ServerM (Maybe AgdaLib) +byFileId agdaLibFileId = do model <- askModel - case Model.getKnownAgdaLib uri model of - Just lib -> return lib - Nothing -> do - provider <- askFilesystemProvider - result <- searchFilesystemForAgdaLib provider fileId - lib <- case result of - Just lib -> return lib - Nothing -> return initAgdaLib - modifyModel $ Model.withAgdaLib lib - return lib + provider <- askFilesystemProvider + caseMaybeM + (fileIdToAgdaLibFile provider agdaLibFileId) + (return Nothing) + $ \agdaLibFile -> + case Model.getKnownAgdaLib (agdaLibFile ^. libName) model of + Just lib -> return $ Just lib + Nothing -> do + lib <- agdaLibFromFile agdaLibFile agdaLibFileId + modifyModel $ Model.withAgdaLib lib + return $ Just lib -searchFilesystemForAgdaLib :: (FS.Provider p, FS.IsFileId f) => p -> f -> ServerM (Maybe AgdaLib) -searchFilesystemForAgdaLib provider agdaIsFileId = do - let agdaFileId = FS.toFileId agdaIsFileId - libFileId <- searchForAgdaLibFile provider agdaFileId - case libFileId of +byLibName :: LibName -> [AgdaLib] -> Maybe AgdaLib +byLibName libName = find (\lib -> libName == lib ^. agdaLibName) + +fileIdToAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe AgdaLibFile) +fileIdToAgdaLibFile provider fileId = do + agdaLibFile <- parseLibFile provider fileId + case agdaLibFile of Nothing -> return Nothing - Just fileId -> do - agdaLibFile <- fileIdToAgdaLibFile provider fileId - case agdaLibFile of - Nothing -> return Nothing - Just agdaLibFile -> do - agdaLib <- agdaLibFromFile agdaLibFile fileId - return $ Just agdaLib - where - searchForAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe FS.FileId) - searchForAgdaLibFile provider childFileId = do - parentFileId <- FS.fileIdParent childFileId - caseMaybe parentFileId (return Nothing) $ \parentFileId -> do - children <- FS.getChildren provider parentFileId - let candidates = filter (\child -> FS.fileIdExtension child == ".agda-lib") children - case listToMaybe candidates of - Nothing -> searchForAgdaLibFile provider parentFileId - Just candidate -> return $ Just candidate + Just agdaLibFile -> do + let (result, _warnings) = runP agdaLibFile + return $ maybeRight result + +installedLibraries :: Maybe FS.FileId -> ServerM [AgdaLib] +installedLibraries overrideLibFile' = do + provider <- askFilesystemProvider + let overrideLibFile = FS.toFileId <$> overrideLibFile' + libsFile <- librariesFile provider overrideLibFile + let entries = maybe [] (^. InstalledLibsFile.entries) libsFile + let entries' = nubOn (^. InstalledLibsFile.entryLibFileId) entries + mapMaybeM + (\entry -> byFileId (entry ^. InstalledLibsFile.entryLibFileId)) + entries' - fileIdToAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe AgdaLibFile) - fileIdToAgdaLibFile provider fileId = do - agdaLibFile <- parseLibFile provider fileId - case agdaLibFile of - Nothing -> return Nothing - Just agdaLibFile -> do - let (result, _warnings) = runP agdaLibFile - return $ maybeRight result +librariesFile :: (FS.MonadFilesystem m, FS.Provider p) => p -> Maybe FS.FileId -> m (Maybe InstalledLibsFile) +librariesFile provider overrideLibFile = do + agdaDir <- liftIO $ LocalFilePath <$> getAgdaAppDir + defaults <- defaultLibraryFileIds agdaDir + let candidates = toList $ maybe defaults singleton overrideLibFile + libsFiles <- mapMaybeM (InstalledLibsFile.fromFileId provider) candidates + return $ listToMaybe libsFiles diff --git a/src/Server/AgdaProjectResolver.hs b/src/Server/AgdaProjectResolver.hs index f7a2e27..e3399a9 100644 --- a/src/Server/AgdaProjectResolver.hs +++ b/src/Server/AgdaProjectResolver.hs @@ -1,7 +1,8 @@ module Server.AgdaProjectResolver (findAgdaProject) where -import Monad (ServerM, askModel, modifyModel) -import Server.AgdaLibResolver (findAgdaLib) +import Agda.Utils.Maybe (caseMaybe, fromMaybe, fromMaybeM, ifJustM, listToMaybe) +import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) +import qualified Server.AgdaLibResolver as AgdaLibResolver import qualified Server.Filesystem as FS import qualified Server.Model as Model import Server.Model.AgdaProject (AgdaProject) @@ -10,14 +11,36 @@ import qualified Server.Model.AgdaProject as AgdaProject -- | Find cached 'AgdaProject', or else make one from @.agda-lib@ files on the -- file system, or else provide a default findAgdaProject :: (FS.IsFileId f) => f -> ServerM AgdaProject -findAgdaProject isFileId = do - let fileId = FS.toFileId isFileId - let uri = FS.fileIdToUri fileId +findAgdaProject agdaFile' = do + let agdaFile = FS.toFileId agdaFile' model <- askModel - case Model.getKnownAgdaProject uri model of - Just project -> return project - Nothing -> do - lib <- findAgdaLib fileId - project <- AgdaProject.new lib - modifyModel $ Model.withAgdaProject project - return project + provider <- askFilesystemProvider + root <- projectRoot provider agdaFile + ifJustM (Model.getKnownAgdaProject agdaFile model) return $ do + ProjectRoot rootFileId agdaLibFileId <- projectRoot provider agdaFile + agdaLib <- caseMaybe agdaLibFileId (pure Nothing) AgdaLibResolver.byFileId + project <- AgdaProject.new rootFileId agdaLib + modifyModel $ Model.withAgdaProject project + return project + +data ProjectRoot = ProjectRoot + { rootFileId :: !FS.FileId, + agdaLibFileId :: !(Maybe FS.FileId) + } + +projectRoot :: (FS.MonadFilesystem m, FS.Provider p) => p -> FS.FileId -> m ProjectRoot +projectRoot provider child = do + agdaLib <- ancestorAgdaLib provider child + let base = fromMaybe child agdaLib + rootDir <- fromMaybeM (pure base) $ FS.fileIdParent base + return $ ProjectRoot rootDir agdaLib + +ancestorAgdaLib :: (FS.MonadFilesystem m, FS.Provider p) => p -> FS.FileId -> m (Maybe FS.FileId) +ancestorAgdaLib provider childFileId = do + parentFileId <- FS.fileIdParent childFileId + caseMaybe parentFileId (return Nothing) $ \parentFileId -> do + children <- FS.getChildren provider parentFileId + let candidates = filter (\child -> FS.fileIdExtension child == ".agda-lib") children + case listToMaybe candidates of + Nothing -> ancestorAgdaLib provider parentFileId + Just candidate -> return $ Just candidate diff --git a/src/Server/Filesystem.hs b/src/Server/Filesystem.hs index 73822bc..b064f7f 100644 --- a/src/Server/Filesystem.hs +++ b/src/Server/Filesystem.hs @@ -4,7 +4,9 @@ module Server.Filesystem ( FileId (..), + referToSameFile, fileIdToUri, + fileIdToPossiblyInvalidFilePath, fileIdToPossiblyInvalidAbsolutePath, fileIdRelativeTo, fileIdParent, @@ -12,6 +14,7 @@ module Server.Filesystem IsFileId (..), MonadFilesystem (..), Provider, + doesFileExist, getFileContents, getChildren, LspVirtualFilesystem (..), @@ -27,7 +30,8 @@ import Agda.Utils.FileName (AbsolutePath, absolute, sameFile) import Agda.Utils.IO (catchIO) import Agda.Utils.IO.UTF8 (readTextFile) import Agda.Utils.List (nubM) -import Agda.Utils.Maybe (fromMaybe) +import Agda.Utils.Maybe (fromMaybe, isJust) +import Agda.Utils.Monad (anyM) import Control.Exception (try) import qualified Control.Exception as E import Control.Monad (foldM, forM) @@ -43,6 +47,7 @@ import qualified Language.LSP.VFS as VFS import Options (Config) import Server.VfsIndex (VfsIndex, getEntry, getEntryChildren) import System.Directory (canonicalizePath, doesDirectoryExist, getDirectoryContents) +import qualified System.Directory import System.FilePath (isAbsolute, takeDirectory, takeExtension, ()) import System.IO.Error (isPermissionError) import qualified Text.URI as ParsedUri @@ -50,7 +55,7 @@ import qualified Text.URI as ParsedUri data FileId = Uri !LSP.NormalizedUri | LocalFilePath !FilePath - deriving (Eq) + deriving (Eq, Ord) instance Pretty FileId where pretty (Uri uri) = pretty $ LSP.getNormalizedUri uri @@ -59,13 +64,13 @@ instance Pretty FileId where instance Show FileId where show = prettyShow -referToSameFile :: FileId -> FileId -> IO Bool +referToSameFile :: (MonadIO m) => FileId -> FileId -> m Bool referToSameFile a b = case (tryFileIdToFilePath a, tryFileIdToFilePath b) of (Just a, Just b) -> do - absA <- absolute a - absB <- absolute b - sameFile absA absB + absA <- liftIO $ absolute a + absB <- liftIO $ absolute b + liftIO $ sameFile absA absB (Just _, Nothing) -> return False (Nothing, Just _) -> return False (Nothing, Nothing) -> do @@ -86,6 +91,10 @@ tryFileIdToFilePath = \case Uri uri -> LSP.uriToFilePath $ LSP.fromNormalizedUri uri LocalFilePath filePath -> Just filePath +fileIdToPossiblyInvalidFilePath :: FileId -> FilePath +fileIdToPossiblyInvalidFilePath (Uri uri) = LSP.uriToPossiblyInvalidFilePath uri +fileIdToPossiblyInvalidFilePath (LocalFilePath path) = path + fileIdToPossiblyInvalidAbsolutePath :: (MonadIO m) => FileId -> m AbsolutePath fileIdToPossiblyInvalidAbsolutePath (Uri uri) = LSP.uriToPossiblyInvalidAbsolutePath uri fileIdToPossiblyInvalidAbsolutePath (LocalFilePath path) = liftIO $ absolute path @@ -101,7 +110,8 @@ fileIdIsAbsolute (LocalFilePath path) = isAbsolute path -- | Makes the first 'FileId' absolute, treating the second 'FileId' as the base fileIdRelativeTo :: (MonadIO m) => FileId -> FileId -> m FileId fileIdRelativeTo fileId _baseFileId | fileIdIsAbsolute fileId = return fileId -fileIdRelativeTo (LocalFilePath path) (LocalFilePath basePath) = fmap LocalFilePath . liftIO $ canonicalizePath $ basePath path +fileIdRelativeTo (LocalFilePath path) (LocalFilePath basePath) = + fmap LocalFilePath . liftIO $ canonicalizePath $ basePath path fileIdRelativeTo fileId baseFileId = fromMaybe (pure fileId) $ do uri <- fileIdToParsedUri fileId baseUri <- fileIdToParsedUri baseFileId @@ -154,9 +164,13 @@ class (MonadLsp Config m) => MonadFilesystem m where askVfsIndex :: m VfsIndex class Provider a where + doesFileExistImpl :: (MonadFilesystem m) => a -> FileId -> m Bool getFileImpl :: (MonadFilesystem m) => a -> FileId -> m (Maybe File) getChildrenImpl :: (MonadFilesystem m) => a -> FileId -> m [FileId] +doesFileExist :: (MonadFilesystem m, Provider a, IsFileId f) => a -> f -> m Bool +doesFileExist provider fileId = doesFileExistImpl provider (toFileId fileId) + getFile :: (MonadFilesystem m, Provider a, IsFileId f) => a -> f -> m (Maybe File) getFile provider fileId = getFileImpl provider (toFileId fileId) @@ -171,6 +185,10 @@ getChildren provider fileId = getChildrenImpl provider (toFileId fileId) data LspVirtualFilesystem = LspVirtualFilesystem instance Provider LspVirtualFilesystem where + doesFileExistImpl _provider fileId = do + let uri = fileIdToUri fileId + isJust <$> LSP.getVirtualFile uri + getFileImpl _provider fileId = do let uri = fileIdToUri fileId vfile <- LSP.getVirtualFile uri @@ -189,6 +207,12 @@ instance Provider LspVirtualFilesystem where data OsFilesystem = OsFilesystem instance Provider OsFilesystem where + doesFileExistImpl _provider fileId = + case tryFileIdToFilePath fileId of + Nothing -> return False + Just filePath -> + liftIO $ System.Directory.doesFileExist filePath + getFileImpl _provider fileId = case tryFileIdToFilePath fileId of Nothing -> return Nothing @@ -220,6 +244,8 @@ instance Provider OsFilesystem where data ProviderWrapper = forall a. (Provider a) => Wrap a instance Provider ProviderWrapper where + doesFileExistImpl (Wrap provider) = doesFileExistImpl provider + getFileImpl (Wrap provider) = getFileImpl provider getChildrenImpl (Wrap provider) = getChildrenImpl provider @@ -227,6 +253,9 @@ instance Provider ProviderWrapper where data Layered = Layered {layeredProviders :: ![ProviderWrapper]} instance Provider Layered where + doesFileExistImpl (Layered providers) fileId = + anyM (\provider -> doesFileExistImpl provider fileId) providers + getFileImpl (Layered providers) fileId = do let results = flip getFileImpl fileId <$> providers foldM diff --git a/src/Server/Model.hs b/src/Server/Model.hs index b63b7a2..0b8ba80 100644 --- a/src/Server/Model.hs +++ b/src/Server/Model.hs @@ -1,6 +1,6 @@ module Server.Model ( Model (Model), - empty, + mkEmpty, getKnownAgdaLib, getKnownAgdaProject, withAgdaLib, @@ -11,27 +11,32 @@ module Server.Model ) where +import Agda.Interaction.Library (LibName) import Agda.Utils.Lens (Lens', over, (^.)) -import Data.Foldable (find) +import Agda.Utils.Maybe (listToMaybe) +import Agda.Utils.Monad (filterM) +import Agda.Utils.Null (empty) +import Control.Monad.IO.Class (MonadIO) import Data.Functor ((<&>)) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.LSP.Protocol.Types as LSP +import qualified Server.Filesystem as FS import Server.Model.AgdaFile (AgdaFile) -import Server.Model.AgdaLib (AgdaLib, isAgdaLibForUri) +import Server.Model.AgdaLib (AgdaLib, agdaLibName) import Server.Model.AgdaProject (AgdaProject) import qualified Server.Model.AgdaProject as AgdaProject data Model = Model - { _modelAgdaLibs :: ![AgdaLib], + { _modelAgdaLibs :: !(Map LibName AgdaLib), _modelAgdaProjects :: ![AgdaProject], _modelAgdaFiles :: !(Map LSP.NormalizedUri AgdaFile) } -empty :: Model -empty = Model [] [] Map.empty +mkEmpty :: Model +mkEmpty = Model empty empty empty -agdaLibs :: Lens' Model [AgdaLib] +agdaLibs :: Lens' Model (Map LibName AgdaLib) agdaLibs f a = f (_modelAgdaLibs a) <&> \x -> a {_modelAgdaLibs = x} agdaProjects :: Lens' Model [AgdaProject] @@ -40,16 +45,20 @@ agdaProjects f a = f (_modelAgdaProjects a) <&> \x -> a {_modelAgdaProjects = x} agdaFiles :: Lens' Model (Map LSP.NormalizedUri AgdaFile) agdaFiles f a = f (_modelAgdaFiles a) <&> \x -> a {_modelAgdaFiles = x} -getKnownAgdaLib :: LSP.NormalizedUri -> Model -> Maybe AgdaLib -getKnownAgdaLib uri model = find (`isAgdaLibForUri` uri) $ model ^. agdaLibs +getKnownAgdaLib :: LibName -> Model -> Maybe AgdaLib +getKnownAgdaLib libName model = Map.lookup libName $ model ^. agdaLibs -getKnownAgdaProject :: LSP.NormalizedUri -> Model -> Maybe AgdaProject -getKnownAgdaProject uri model = - find ((`isAgdaLibForUri` uri) . (^. AgdaProject.agdaLib)) $ model ^. agdaProjects +getKnownAgdaProject :: (MonadIO m) => FS.FileId -> Model -> m (Maybe AgdaProject) +getKnownAgdaProject agdaFileId model = do + let projects = model ^. agdaProjects + let projectMatches = \project -> FS.referToSameFile agdaFileId (project ^. AgdaProject.projectRoot) + listToMaybe <$> filterM projectMatches projects -- | Add an 'AgdaLib' to the model withAgdaLib :: AgdaLib -> Model -> Model -withAgdaLib lib = over agdaLibs (lib :) +withAgdaLib lib = + let libName = lib ^. agdaLibName + in over agdaLibs (Map.insert libName lib) -- | Add an 'AgdaProject' to the model withAgdaProject :: AgdaProject -> Model -> Model diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index e344dea..ccf4ed3 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -1,26 +1,18 @@ module Server.Model.AgdaLib ( AgdaLibOrigin (..), AgdaLib (AgdaLib), - initAgdaLib, agdaLibName, agdaLibIncludes, agdaLibDependencies, - agdaLibOrigin, - isAgdaLibForUri, agdaLibFromFile, agdaLibToFile, ) where -import Agda.Interaction.Library - ( AgdaLibFile (AgdaLibFile), - LibName, - OptionsPragma (OptionsPragma), - ) -import Agda.Interaction.Library.Base (libIncludes, libName, libPragmas) +import Agda.Interaction.Library (AgdaLibFile (AgdaLibFile), LibName, OptionsPragma) +import Agda.Interaction.Library.Base (libDepends, libIncludes, libName, libPragmas) import Agda.Syntax.Common.Pretty (Pretty, doubleQuotes, pretty, pshow, text, (<+>)) -import Agda.Utils.Lens (Lens', set, (<&>), (^.)) -import Agda.Utils.Null (empty) +import Agda.Utils.Lens (Lens', (<&>), (^.)) import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO) import qualified Language.LSP.Protocol.Types as LSP @@ -36,25 +28,18 @@ data AgdaLib = AgdaLib _agdaLibIncludes :: ![FS.FileId], _agdaLibOptionsPragma :: !OptionsPragma, _agdaLibDependencies :: ![LibName], - _agdaLibOrigin :: !AgdaLibOrigin + _agdaLibFile :: !FS.FileId } instance Pretty AgdaLib where pretty agdaLib = text "AgdaLib" <+> doubleQuotes (pretty $ agdaLib ^. agdaLibName) - <+> pshow (agdaLib ^. agdaLibOrigin) + <+> text "file:" + <+> pshow (agdaLib ^. agdaLibFile) <+> text "includes:" <+> pretty (agdaLib ^. agdaLibIncludes) -initAgdaLibWithOrigin :: AgdaLibOrigin -> AgdaLib -initAgdaLibWithOrigin origin = - let optionsPragma = OptionsPragma [] empty - in AgdaLib empty [] optionsPragma [] origin - -initAgdaLib :: AgdaLib -initAgdaLib = initAgdaLibWithOrigin Defaulted - agdaLibName :: Lens' AgdaLib LibName agdaLibName f a = f (_agdaLibName a) <&> \x -> a {_agdaLibName = x} @@ -67,11 +52,8 @@ agdaLibOptionsPragma f a = f (_agdaLibOptionsPragma a) <&> \x -> a {_agdaLibOpti agdaLibDependencies :: Lens' AgdaLib [LibName] agdaLibDependencies f a = f (_agdaLibDependencies a) <&> \x -> a {_agdaLibDependencies = x} -agdaLibOrigin :: Lens' AgdaLib AgdaLibOrigin -agdaLibOrigin f a = f (_agdaLibOrigin a) <&> \x -> a {_agdaLibOrigin = x} - -isAgdaLibForUri :: AgdaLib -> LSP.NormalizedUri -> Bool -isAgdaLibForUri agdaLib uri = any (\include -> FS.fileIdToUri include `LSP.isUriAncestorOf` uri) (agdaLib ^. agdaLibIncludes) +agdaLibFile :: Lens' AgdaLib FS.FileId +agdaLibFile f a = f (_agdaLibFile a) <&> \x -> a {_agdaLibFile = x} -- | Given an 'AgdaLibFile' and the URI of that file, create the -- corresponding 'AgdaLib' @@ -83,20 +65,21 @@ agdaLibFromFile agdaLibFile agdaLibIsFileId = do Nothing -> return . FS.LocalFilePath Just parent -> \include -> FS.LocalFilePath include `FS.fileIdRelativeTo` parent includes <- forM (agdaLibFile ^. libIncludes) includeToAbsolute - return (initAgdaLibWithOrigin (FromFile agdaLibFileId)) - <&> set agdaLibName (agdaLibFile ^. libName) - <&> set agdaLibIncludes includes - <&> set agdaLibOptionsPragma (agdaLibFile ^. libPragmas) + return $ + AgdaLib + (agdaLibFile ^. libName) + includes + (agdaLibFile ^. libPragmas) + (agdaLibFile ^. libDepends) + agdaLibFileId --- | If the given `AgdaLib` came from a file, turn it back into one. Since --- `AgdaLibFile`s are relative to an Agda file on the filesystem, the first --- parameter is for the URI for the Agda file -agdaLibToFile :: LSP.NormalizedUri -> AgdaLib -> Maybe AgdaLibFile -agdaLibToFile relativeToUri agdaLib = case agdaLib ^. agdaLibOrigin of - Defaulted -> Nothing - FromFile fileId -> - let includePaths = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes - uri = FS.fileIdToUri fileId - above = LSP.uriHeightAbove uri relativeToUri - filePath = LSP.uriToPossiblyInvalidFilePath uri - in Just $ AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) +-- | Turn an `AgdaLib` back into a file. Since `AgdaLibFile`s are relative to an +-- Agda file on the filesystem, the first parameter is for the URI for the Agda +-- file +agdaLibToFile :: LSP.NormalizedUri -> AgdaLib -> AgdaLibFile +agdaLibToFile relativeToUri agdaLib = + let includePaths = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes + uri = FS.fileIdToUri $ agdaLib ^. agdaLibFile + above = LSP.uriHeightAbove uri relativeToUri + filePath = LSP.uriToPossiblyInvalidFilePath uri + in AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) diff --git a/src/Server/Model/AgdaProject.hs b/src/Server/Model/AgdaProject.hs index 36a4af1..0180c60 100644 --- a/src/Server/Model/AgdaProject.hs +++ b/src/Server/Model/AgdaProject.hs @@ -3,6 +3,7 @@ module Server.Model.AgdaProject ( AgdaProject, new, + projectRoot, agdaLib, tcStateRef, tcEnv, @@ -15,10 +16,15 @@ import Agda.Utils.Lens (Lens', (<&>), (^.)) import Control.Monad.IO.Class (MonadIO, liftIO) import Server.Model.AgdaLib (AgdaLib) import Agda.Syntax.Common.Pretty (Pretty, pretty, text, (<+>)) +import qualified Server.Filesystem as FS + +data Origin = FromLib !FS.FileId | Defaulted + deriving (Show, Eq) data AgdaProject = AgdaProject { - _agdaLib :: !AgdaLib, + _projectRoot :: !(FS.FileId), + _agdaLib :: !(Maybe AgdaLib), _tcStateRef :: !(IORef TCM.TCState), _tcEnv :: !TCM.TCEnv } @@ -28,8 +34,8 @@ instance Pretty AgdaProject where text "AgdaProject" <+> pretty (agdaProject ^. agdaLib) -new :: (MonadIO m) => AgdaLib -> m AgdaProject -new agdaLib = do +new :: (MonadIO m) => FS.FileId -> Maybe AgdaLib -> m AgdaProject +new projectRoot agdaLib = do #if MIN_VERSION_Agda(2,8,0) tcState <- liftIO TCM.initStateIO #else @@ -41,9 +47,12 @@ new agdaLib = do let tcState' = tcState { TCM.stPersistentState = persistentState { TCM.stInteractionOutputCallback = \_ -> return () } } tcStateRef <- liftIO $ newIORef tcState' let tcEnv = TCM.initEnv - return $ AgdaProject agdaLib tcStateRef tcEnv + return $ AgdaProject projectRoot agdaLib tcStateRef tcEnv + +projectRoot :: Lens' AgdaProject FS.FileId +projectRoot f a = f (_projectRoot a) <&> \x -> a {_projectRoot = x} -agdaLib :: Lens' AgdaProject AgdaLib +agdaLib :: Lens' AgdaProject (Maybe AgdaLib) agdaLib f a = f (_agdaLib a) <&> \x -> a {_agdaLib = x} tcStateRef :: Lens' AgdaProject (IORef TCM.TCState) diff --git a/src/Server/Model/InstalledLibsFile.hs b/src/Server/Model/InstalledLibsFile.hs new file mode 100644 index 0000000..ce81d17 --- /dev/null +++ b/src/Server/Model/InstalledLibsFile.hs @@ -0,0 +1,63 @@ +module Server.Model.InstalledLibsFile + ( InstalledLibsFile, + entries, + fromFileId, + Entry, + entryLineNumber, + entryLibFileId, + ) +where + +import Agda.Interaction.Library.Base (LineNumber) +import Agda.Interaction.Library.Parse.More (trimLineComment) +import Agda.Utils.Environment (expandEnvironmentVariables) +import Agda.Utils.Lens (Lens', (<&>)) +import Agda.Utils.Maybe (caseMaybeM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Server.Filesystem as FS + +data InstalledLibsFile = InstalledLibsFile + { _fileId :: !FS.FileId, + _libFileEntries :: ![Entry] + } + +fileId :: Lens' InstalledLibsFile FS.FileId +fileId f a = f (_fileId a) <&> \x -> a {_fileId = x} + +entries :: Lens' InstalledLibsFile [Entry] +entries f a = f (_libFileEntries a) <&> \x -> a {_libFileEntries = x} + +data Entry = Entry + { _lineNumber :: !LineNumber, + _libFileId :: !FS.FileId + } + +entryLineNumber :: Lens' Entry LineNumber +entryLineNumber f a = f (_lineNumber a) <&> \x -> a {_lineNumber = x} + +entryLibFileId :: Lens' Entry FS.FileId +entryLibFileId f a = f (_libFileId a) <&> \x -> a {_libFileId = x} + +fromFileId :: (FS.MonadFilesystem m, FS.Provider p) => p -> FS.FileId -> m (Maybe InstalledLibsFile) +fromFileId provider fileId = + caseMaybeM + (FS.getFileContents provider fileId) + (return Nothing) + $ \contents -> + Just . InstalledLibsFile fileId <$> parse contents + +parse :: (MonadIO m) => Text -> m [Entry] +parse contents = do + let strContents = Text.unpack contents + let lines = stripCommentLines strContents + liftIO $ sequence [Entry i . FS.LocalFilePath <$> expandEnvironmentVariables s | (i, s) <- lines] + +-- | Remove trailing white space and line comments. +stripCommentLines :: String -> [(LineNumber, String)] +stripCommentLines = concatMap strip . zip [1 ..] . lines + where + strip (i, s) = [(i, s') | not $ null s'] + where + s' = trimLineComment s diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index 533dd8d..b70b871 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -12,7 +12,6 @@ module Server.Model.Monad ( MonadAgdaProject (..), askAgdaLib, - useAgdaLib, MonadAgdaFile (..), useAgdaFile, WithAgdaProjectT, @@ -56,14 +55,9 @@ useAgdaProject lens = do agdaProject <- askAgdaProject return $ agdaProject ^. lens -askAgdaLib :: (MonadAgdaProject m) => m AgdaLib +askAgdaLib :: (MonadAgdaProject m) => m (Maybe AgdaLib) askAgdaLib = useAgdaProject AgdaProject.agdaLib -useAgdaLib :: (MonadAgdaProject m) => Lens' AgdaLib a -> m a -useAgdaLib lens = do - agdaLib <- askAgdaLib - return $ agdaLib ^. lens - class (MonadAgdaProject m) => MonadAgdaFile m where askAgdaFile :: m AgdaFile localAgdaFile :: (AgdaFile -> AgdaFile) -> m a -> m a diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index cc0b45b..bb64ec2 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -10,15 +10,14 @@ import Control.Monad.IO.Class (liftIO) import Indexer (indexFile) import qualified Language.LSP.Server as LSP import Monad (runServerT) -import Server.AgdaLibResolver (findAgdaLib) +import Server.AgdaProjectResolver (findAgdaProject) import qualified Server.Filesystem as FS -import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName, agdaLibOrigin) +import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName) import Server.Model.Monad (runWithAgdaProjectT) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import qualified TestData -import Server.AgdaProjectResolver (findAgdaProject) natPath, constPath, agdaLibPath, srcPath :: FilePath natPath = "test/data/libs/no-deps/src/Data/Nat.agda" @@ -30,25 +29,25 @@ tests :: TestTree tests = testGroup "Agda lib resolution" - [ testCase "Explicit" $ do - model <- TestData.getModel + [ -- testCase "Explicit" $ do + -- model <- TestData.getModel - absConstPath <- makeAbsolute constPath - absAgdaLibPath <- makeAbsolute agdaLibPath - absSrcPath <- makeAbsolute srcPath + -- absConstPath <- makeAbsolute constPath + -- absAgdaLibPath <- makeAbsolute agdaLibPath + -- absSrcPath <- makeAbsolute srcPath - LSP.runLspT undefined $ do - env <- TestData.getServerEnv model - runServerT env $ do - lib <- findAgdaLib absConstPath + -- LSP.runLspT undefined $ do + -- env <- TestData.getServerEnv model + -- runServerT env $ do + -- lib <- findAgdaLib absConstPath -#if MIN_VERSION_Agda(2,8,0) - liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" -#else - liftIO $ lib ^. agdaLibName @?= "no-deps" -#endif - liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) - liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath], + -- #if MIN_VERSION_Agda(2,8,0) + -- liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" + -- #else + -- liftIO $ lib ^. agdaLibName @?= "no-deps" + -- #endif + -- liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) + -- liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath], testCase "Module without imports in lib without dependencies" $ do model <- TestData.getModel diff --git a/test/Test/Model.hs b/test/Test/Model.hs index 7a5b3d9..fa6bed3 100644 --- a/test/Test/Model.hs +++ b/test/Test/Model.hs @@ -12,26 +12,26 @@ tests :: TestTree tests = testGroup "Model" - [ testCase "getKnownAgdaLib gets known Agda lib" $ do - model <- TestData.getModel + [ -- testCase "getKnownAgdaLib gets known Agda lib" $ do + -- model <- TestData.getModel - let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri1 model - length (agdaLib ^. agdaLibIncludes) @?= 3 + -- let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri1 model + -- length (agdaLib ^. agdaLibIncludes) @?= 3 - let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri2 model - length (agdaLib ^. agdaLibIncludes) @?= 1 + -- let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri2 model + -- length (agdaLib ^. agdaLibIncludes) @?= 1 - let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri3 model - length (agdaLib ^. agdaLibIncludes) @?= 3 + -- let Just agdaLib = Model.getKnownAgdaLib TestData.fileUri3 model + -- length (agdaLib ^. agdaLibIncludes) @?= 3 - return (), - testCase "getKnownAgdaLib fails on unknown Agda lib" $ do - model <- TestData.getModel + -- return (), + -- testCase "getKnownAgdaLib fails on unknown Agda lib" $ do + -- model <- TestData.getModel - let result = Model.getKnownAgdaLib TestData.fakeUri model - isNothing result @? "got Agda lib, but should be unknown" + -- let result = Model.getKnownAgdaLib TestData.fakeUri model + -- isNothing result @? "got Agda lib, but should be unknown" - return (), + -- return (), testCase "getAgdaFile gets known Agda file" $ do model <- TestData.getModel diff --git a/test/Test/ModelMonad.hs b/test/Test/ModelMonad.hs index 1e0aa09..cba1f96 100644 --- a/test/Test/ModelMonad.hs +++ b/test/Test/ModelMonad.hs @@ -29,21 +29,21 @@ tests = "Model monads" [ testGroup "WithAgdaFileM" - [ testCase "gets known Agda file" $ do - let method = LSP.SMethod_TextDocumentDocumentSymbol - message = TestData.documentSymbolMessage TestData.fileUri1 + [ -- testCase "gets known Agda file" $ do + -- let method = LSP.SMethod_TextDocumentDocumentSymbol + -- message = TestData.documentSymbolMessage TestData.fileUri1 - let handlers = requestHandlerWithAgdaFile method $ \req responder -> do - agdaLib <- askAgdaLib - liftIO $ length (agdaLib ^. agdaLibIncludes) @?= 3 - responder $ Right $ LSP.InL [] + -- let handlers = requestHandlerWithAgdaFile method $ \req responder -> do + -- agdaLib <- askAgdaLib + -- liftIO $ length (agdaLib ^. agdaLibIncludes) @?= 3 + -- responder $ Right $ LSP.InL [] - model <- TestData.getModel - result <- runHandler method message model handlers + -- model <- TestData.getModel + -- result <- runHandler method message model handlers - isRight result @? "didn't get known Agda file: " <> show result + -- isRight result @? "didn't get known Agda file: " <> show result - return (), + -- return (), testCase "fails on unknown Agda file" $ do let method = LSP.SMethod_TextDocumentDocumentSymbol message = TestData.documentSymbolMessage TestData.fakeUri diff --git a/test/TestData.hs b/test/TestData.hs index 8259e92..92c5fb4 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -50,12 +50,14 @@ import qualified Server.CommandController as CommandController import qualified Server.Filesystem as FS import Server.Model (Model (Model)) import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) -import Server.Model.AgdaLib (agdaLibIncludes, initAgdaLib) +import Server.Model.AgdaLib (agdaLibIncludes, AgdaLib (AgdaLib)) import qualified Server.Model.AgdaProject as AgdaProject import Server.Model.Monad (MonadAgdaProject, runWithAgdaProjectT) import qualified Server.ResponseController as ResponseController import qualified Server.VfsIndex as VfsIndex import System.FilePath (takeBaseName) +import Agda.Utils.Null (empty) +import Server.Filesystem (FileId(LocalFilePath)) data AgdaFileDetails = AgdaFileDetails { fileName :: !String, @@ -157,16 +159,15 @@ getModel = do "file:///home/user2/project2/", "https://example.com/agda/" ] - let testLib1 = initAgdaLib & set agdaLibIncludes includes1 - testProject1 <- AgdaProject.new testLib1 + let testLib1 = AgdaLib empty includes1 mempty empty (FS.LocalFilePath "") + testProject1 <- AgdaProject.new (FS.Uri . LSP.toNormalizedUri . LSP.Uri $ "file:///home/user/project1/") (Just testLib1) let includes2 = FS.Uri . LSP.toNormalizedUri . LSP.Uri <$> ["file:///home/user/project2/"] - let testLib2 = initAgdaLib & set agdaLibIncludes includes2 - testProject2 <- AgdaProject.new testLib2 + let testLib2 = AgdaLib empty includes2 mempty empty (FS.LocalFilePath "") + testProject2 <- AgdaProject.new (FS.Uri . LSP.toNormalizedUri . LSP.Uri $ "file:///home/user/project2/") (Just testLib2) - let libs = [testLib1, testLib2] let projects = [testProject1, testProject2] let testFile1 = emptyAgdaFile @@ -180,7 +181,7 @@ getModel = do (fileUri3, testFile3) ] - return $ Model libs projects files + return $ Model empty projects files -------------------------------------------------------------------------------- From 2d9b95c00f8de9fd428e7d164afb98a30bcaf0a5 Mon Sep 17 00:00:00 2001 From: nvarner Date: Fri, 26 Dec 2025 15:02:26 -0500 Subject: [PATCH 42/47] More dependency resolution --- agda-language-server.cabal | 8 ++++ package.yaml | 2 + src/Indexer/Prepare.hs | 34 +++++++------- src/Language/LSP/Protocol/Types/More.hs | 4 ++ src/Monad.hs | 22 +++++++++ src/Server/AgdaLibResolver.hs | 26 ++++++---- .../Handler/TextDocument/FileManagement.hs | 11 +++-- src/Server/Log.hs | 47 +++++++++++++++++++ src/Server/Model/Handler.hs | 10 ++-- src/Server/Model/Monad.hs | 18 +++++-- test/Test/AgdaLibResolution.hs | 35 +++++++------- test/TestData.hs | 7 +-- 12 files changed, 162 insertions(+), 62 deletions(-) create mode 100644 src/Server/Log.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index fc67a75..8f5e1e2 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -88,6 +88,7 @@ library Server.Handler Server.Handler.TextDocument.DocumentSymbol Server.Handler.TextDocument.FileManagement + Server.Log Server.Model Server.Model.AgdaFile Server.Model.AgdaLib @@ -114,6 +115,7 @@ library , aeson , base >=4.7 && <5 , bytestring + , co-log-core , containers , directory , filepath @@ -128,6 +130,7 @@ library , stm , strict , text + , unliftio-core default-language: Haskell2010 if flag(Agda-2-6-4) build-depends: @@ -162,6 +165,7 @@ executable als , agda-language-server , base >=4.7 && <5 , bytestring + , co-log-core , containers , directory , filepath @@ -176,6 +180,7 @@ executable als , stm , strict , text + , unliftio-core default-language: Haskell2010 if flag(Agda-2-6-4) build-depends: @@ -252,6 +257,7 @@ test-suite als-test Server.Handler Server.Handler.TextDocument.DocumentSymbol Server.Handler.TextDocument.FileManagement + Server.Log Server.Model Server.Model.AgdaFile Server.Model.AgdaLib @@ -278,6 +284,7 @@ test-suite als-test , aeson , base >=4.7 && <5 , bytestring + , co-log-core , containers , directory , filepath @@ -297,6 +304,7 @@ test-suite als-test , tasty-hunit , tasty-quickcheck , text + , unliftio-core default-language: Haskell2010 if flag(Agda-2-6-4) build-depends: diff --git a/package.yaml b/package.yaml index 3e11982..fe839c9 100644 --- a/package.yaml +++ b/package.yaml @@ -61,6 +61,7 @@ dependencies: - Agda - aeson - bytestring + - co-log-core - containers - directory - filepath @@ -75,6 +76,7 @@ dependencies: - text - process - prettyprinter + - unliftio-core default-extensions: - LambdaCase diff --git a/src/Indexer/Prepare.hs b/src/Indexer/Prepare.hs index e10efca..fce284f 100644 --- a/src/Indexer/Prepare.hs +++ b/src/Indexer/Prepare.hs @@ -4,10 +4,10 @@ import Agda.Interaction.Library (LibName) import Agda.Interaction.Library.Base (libNameForCurrentDir) import Agda.Interaction.Options (CommandLineOptions (..)) import qualified Agda.Interaction.Options.Lenses as Lens +import Agda.Syntax.Common.Pretty (pretty) import qualified Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Monad.Benchmark (updateBenchmarkingStatus) import Agda.Utils.FileName (AbsolutePath, absolute) -import Agda.Utils.Impossible (__IMPOSSIBLE__) import Agda.Utils.Lens ((^.)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe (ifJustM, maybeToList) @@ -15,6 +15,7 @@ import Agda.Utils.Monad (lift) import Control.Monad.IO.Class (liftIO) import qualified Server.AgdaLibResolver as AgdaLibResolver import qualified Server.Filesystem as FS +import qualified Server.Log as Log import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes, agdaLibName) import Server.Model.Monad (MonadAgdaProject, WithAgdaProjectM, askAgdaLib) import System.Directory (getCurrentDirectory) @@ -43,32 +44,33 @@ directDependencyLibNames :: -- | Persistent command line options CommandLineOptions -> m [LibName] -directDependencyLibNames persistentOptions - | not (null $ optLibraries persistentOptions) = return $ optLibraries persistentOptions - | not (optUseLibs persistentOptions) = return [] +directDependencyLibNames o + | not (null $ optLibraries o) = return $ optLibraries o + | not (optUseLibs o) = return [] | otherwise = ifJustM askAgdaLib (\agdaLib -> return $ agdaLib ^. agdaLibDependencies) - (defaultLibNames persistentOptions) + (defaultLibNames o) -- | Determine the libraries we depend on when there is no .agda-lib -- TODO: read from default file -defaultLibNames :: - (MonadAgdaProject m) => - CommandLineOptions -> - m [LibName] -defaultLibNames persistentOptions - | optDefaultLibs persistentOptions = return [libNameForCurrentDir] - | otherwise = return [] +defaultLibNames :: (MonadAgdaProject m) => CommandLineOptions -> m [LibName] +defaultLibNames o = + if optDefaultLibs o + then return [libNameForCurrentDir] + else return [] dependencyLibs :: CommandLineOptions -> WithAgdaProjectM [AgdaLib] -dependencyLibs persistentOptions = do - directDependencies <- directDependencyLibNames persistentOptions - installed <- lift $ AgdaLibResolver.installedLibraries (FS.LocalFilePath <$> optOverrideLibrariesFile persistentOptions) +dependencyLibs o = do + directDependencies <- directDependencyLibNames o + Log.infoP $ "Direct dependencies: " <> pretty directDependencies + installed <- lift $ AgdaLibResolver.installedLibraries (FS.LocalFilePath <$> optOverrideLibrariesFile o) + Log.infoP $ "Installed libraries: " <> pretty installed let libs = resolveDeps installed directDependencies [] [] + Log.infoP $ "Resolved dependencies: " <> pretty libs case libs of - Nothing -> __IMPOSSIBLE__ -- TODO: very wrong, do real error handling + Nothing -> return [] -- TODO: very wrong, do real error handling Just libs -> do projectLib <- askAgdaLib return $ maybeToList projectLib <> libs diff --git a/src/Language/LSP/Protocol/Types/More.hs b/src/Language/LSP/Protocol/Types/More.hs index c64f51f..11b2a0d 100644 --- a/src/Language/LSP/Protocol/Types/More.hs +++ b/src/Language/LSP/Protocol/Types/More.hs @@ -5,10 +5,14 @@ import Agda.Utils.Lens ((^.)) import qualified Data.Text as Text import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Types.Uri.More as LSP instance Pretty LSP.Uri where pretty = text . Text.unpack . LSP.getUri +instance Pretty LSP.NormalizedUri where + pretty = text . Text.unpack . LSP.getNormalizedUri + instance Pretty LSP.Position where pretty pos = pshow (pos ^. LSP.line + 1) <> text ":" <> pshow (pos ^. LSP.character + 1) diff --git a/src/Monad.hs b/src/Monad.hs index 5ce9326..45f4eac 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} @@ -46,6 +47,7 @@ data Env = Env { envOptions :: Options, envDevMode :: Bool, envConfig :: Config, + envMockLsp :: Bool, envLogChan :: Chan Text, envCommandController :: CommandController, envResponseChan :: Chan Response, @@ -59,6 +61,7 @@ createInitEnv :: (MonadIO m, MonadLsp Config m) => Options -> m Env createInitEnv options = Env options (isJust (optViaTCP options)) <$> getConfig + <*> (pure False) <*> liftIO newChan <*> liftIO CommandController.new <*> liftIO newChan @@ -148,3 +151,22 @@ signalCommandFinish = do -- | Sends a Response to the client via "envResponseChan" sendResponse :: (Monad m, MonadIO m) => Env -> Response -> TCMT m () sendResponse env response = liftIO $ writeChan (envResponseChan env) response + +-------------------------------------------------------------------------------- + +class (Monad m) => MonadMockLsp m where + -- | When true, we're mocking LspM to the best of our ability. Usually, this + -- should be false. + -- + -- Used for testing purposes. It's hard to run @LspT@ without invoking the + -- @lsp@ library, which means spinning up a server and no direct control, so + -- in unit tests we hack around this with some @undefined@. To prevent this + -- from being used, we can't access @LspT@ functionality, most notably + -- logging. So, for example, this tells the logging implementation not to + -- use LSP features. + shouldMockLsp :: m Bool + default shouldMockLsp :: (MonadTrans t, MonadMockLsp n, m ~ t n) => m Bool + shouldMockLsp = lift shouldMockLsp + +instance MonadMockLsp ServerM where + shouldMockLsp = asks envMockLsp diff --git a/src/Server/AgdaLibResolver.hs b/src/Server/AgdaLibResolver.hs index 7ad8b2d..f1151a6 100644 --- a/src/Server/AgdaLibResolver.hs +++ b/src/Server/AgdaLibResolver.hs @@ -5,8 +5,8 @@ module Server.AgdaLibResolver ) where -import Agda.Interaction.Library (AgdaLibFile, LibName) -import Agda.Interaction.Library.Base (libName) +import Agda.Interaction.Library (AgdaLibFile, LibName, findLib') +import Agda.Interaction.Library.Base (libName, libNameForCurrentDir) import Agda.Interaction.Library.More (defaultLibraryFileIds) import Agda.Interaction.Library.Parse.More (parseLibFile, runP) import Agda.Setup (getAgdaAppDir) @@ -15,17 +15,17 @@ import Agda.Utils.Lens ((^.)) import Agda.Utils.List (nubOn) import Agda.Utils.Maybe (caseMaybeM, listToMaybe) import Agda.Utils.Monad (mapMaybeM) -import Agda.Utils.Singleton (Singleton (singleton)) +import Agda.Utils.Singleton (singleton) import Control.Monad.IO.Class (liftIO) -import Data.Foldable (Foldable (toList), find) +import Data.Foldable (toList) import Monad (ServerM, askFilesystemProvider, askModel, modifyModel) -import Server.Filesystem (FileId (LocalFilePath)) import qualified Server.Filesystem as FS import qualified Server.Model as Model import Server.Model.AgdaLib (AgdaLib, agdaLibFromFile, agdaLibName) import Server.Model.InstalledLibsFile (InstalledLibsFile) import qualified Server.Model.InstalledLibsFile as InstalledLibsFile +-- | Get an 'AgdaLib' given the 'FS.FileId' of its @.agda-lib@ file byFileId :: FS.FileId -> ServerM (Maybe AgdaLib) byFileId agdaLibFileId = do model <- askModel @@ -41,8 +41,9 @@ byFileId agdaLibFileId = do modifyModel $ Model.withAgdaLib lib return $ Just lib +-- | Get an 'AgdaLib' given its name and the list of installed libraries byLibName :: LibName -> [AgdaLib] -> Maybe AgdaLib -byLibName libName = find (\lib -> libName == lib ^. agdaLibName) +byLibName libName = listToMaybe . findLib' (^. agdaLibName) libName fileIdToAgdaLibFile :: (FS.Provider p) => p -> FS.FileId -> ServerM (Maybe AgdaLibFile) fileIdToAgdaLibFile provider fileId = do @@ -54,9 +55,8 @@ fileIdToAgdaLibFile provider fileId = do return $ maybeRight result installedLibraries :: Maybe FS.FileId -> ServerM [AgdaLib] -installedLibraries overrideLibFile' = do +installedLibraries overrideLibFile = do provider <- askFilesystemProvider - let overrideLibFile = FS.toFileId <$> overrideLibFile' libsFile <- librariesFile provider overrideLibFile let entries = maybe [] (^. InstalledLibsFile.entries) libsFile let entries' = nubOn (^. InstalledLibsFile.entryLibFileId) entries @@ -66,8 +66,16 @@ installedLibraries overrideLibFile' = do librariesFile :: (FS.MonadFilesystem m, FS.Provider p) => p -> Maybe FS.FileId -> m (Maybe InstalledLibsFile) librariesFile provider overrideLibFile = do - agdaDir <- liftIO $ LocalFilePath <$> getAgdaAppDir + agdaDir <- liftIO $ FS.LocalFilePath <$> getAgdaAppDir defaults <- defaultLibraryFileIds agdaDir let candidates = toList $ maybe defaults singleton overrideLibFile libsFiles <- mapMaybeM (InstalledLibsFile.fromFileId provider) candidates return $ listToMaybe libsFiles + +-- | Determine the libraries we depend on when there is no .agda-lib +-- TODO: read from default file +defaultLibNames :: (FS.MonadFilesystem m, FS.Provider p) => p -> Bool -> m [LibName] +defaultLibNames provider useDefaultsFile = + if useDefaultsFile + then return [libNameForCurrentDir] + else return [] diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index 0f3f18e..e176cb5 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -6,16 +6,16 @@ module Server.Handler.TextDocument.FileManagement where import Agda.Interaction.Imports.Virtual (parseVSource, vSrcFromUri) -import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Syntax.Common.Pretty (pretty, (<+>)) import Agda.Utils.Lens ((^.)) import Control.Monad.Trans (lift) -import qualified Data.Text as Text import Indexer (indexFile) import qualified Language.LSP.Protocol.Lens as LSP import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM, modifyModel, modifyVfsIndex) +import qualified Server.Log as Log import qualified Server.Model as Model import Server.Model.Handler (notificationHandlerWithAgdaLib, takeOverNotificationHandlerWithAgdaLib) import qualified Server.VfsIndex as VFSIndex @@ -24,6 +24,7 @@ import qualified Server.VfsIndex as VfsIndex didOpenHandler :: LSP.Handlers ServerM didOpenHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidOpen $ \notification -> do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + Log.infoP $ "Opening URI" <+> pretty uri modifyVfsIndex $ VfsIndex.onOpen uri takeOverNotificationHandlerWithAgdaLib notification $ \uri notification -> do vfile <- lift $ LSP.getVirtualFile uri @@ -32,24 +33,26 @@ didOpenHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidOpen $ \noti Just vfile -> do vSourceFile <- vSrcFromUri uri vfile src <- parseVSource vSourceFile - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src + Log.infoP $ "Opening source" <+> pretty src agdaFile <- indexFile src lift $ modifyModel $ Model.setAgdaFile uri agdaFile didCloseHandler :: LSP.Handlers ServerM didCloseHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidClose $ \notification -> do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri + Log.infoP $ "Closing URI" <+> pretty uri modifyVfsIndex $ VFSIndex.onClose uri modifyModel $ Model.deleteAgdaFile $ LSP.toNormalizedUri uri didSaveHandler :: LSP.Handlers ServerM didSaveHandler = notificationHandlerWithAgdaLib LSP.SMethod_TextDocumentDidSave $ \uri notification -> do + Log.infoP $ "Saving URI" <+> pretty uri vfile <- lift $ LSP.getVirtualFile uri case vfile of Nothing -> return () Just vfile -> do vSourceFile <- vSrcFromUri uri vfile src <- parseVSource vSourceFile - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow src + Log.infoP $ "Saving source" <+> pretty src agdaFile <- indexFile src lift $ modifyModel $ Model.setAgdaFile uri agdaFile diff --git a/src/Server/Log.hs b/src/Server/Log.hs new file mode 100644 index 0000000..281ddbd --- /dev/null +++ b/src/Server/Log.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Server.Log + ( infoT, + infoP, + errorT, + errorP, + errorTCM, + ) +where + +import Agda.Syntax.Common.Pretty (Pretty, prettyShow) +import Agda.TypeChecking.Monad (MonadTCM, liftTCM) +import Agda.TypeChecking.Pretty (PrettyTCM, prettyTCM) +import Agda.Utils.Monad (ifM, (<=<)) +import Colog.Core (Severity (Error, Info), WithSeverity (WithSeverity), (<&)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Language.LSP.Logging as LSP +import Language.LSP.Server (MonadLsp) +import Monad (MonadMockLsp (shouldMockLsp)) +import Options (Config) + +console :: (MonadLsp Config m, MonadMockLsp m) => Severity -> Text -> m () +console severity text = + ifM shouldMockLsp (pure ()) $ + (LSP.logToLogMessage <& WithSeverity text severity) + +popup :: (MonadLsp Config m, MonadMockLsp m) => Severity -> Text -> m () +popup severity text = + ifM shouldMockLsp (pure ()) $ + LSP.logToShowMessage <& WithSeverity text severity + +infoT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () +infoT text = console Info text + +infoP :: (MonadLsp Config m, MonadMockLsp m, Pretty p) => p -> m () +infoP = infoT . Text.pack . prettyShow + +errorT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () +errorT text = console Error text >> popup Error text + +errorP :: (MonadLsp Config m, MonadMockLsp m, Pretty p) => p -> m () +errorP = errorT . Text.pack . prettyShow + +errorTCM :: (MonadLsp Config m, MonadMockLsp m, MonadTCM m, PrettyTCM p) => p -> m () +errorTCM = errorP <=< liftTCM . prettyTCM diff --git a/src/Server/Model/Handler.hs b/src/Server/Model/Handler.hs index aa89513..7715d93 100644 --- a/src/Server/Model/Handler.hs +++ b/src/Server/Model/Handler.hs @@ -12,7 +12,7 @@ module Server.Model.Handler ) where -import Agda.Syntax.Common.Pretty (prettyShow) +import Agda.Syntax.Common.Pretty (pretty, prettyShow) import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Pretty as TCM import Agda.Utils.Either (fromRightM) @@ -25,6 +25,7 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Monad (ServerM, askModel, catchTCError) import Server.AgdaProjectResolver (findAgdaProject) +import qualified Server.Log as Log import qualified Server.Model as Model import Server.Model.Monad (WithAgdaFileM, WithAgdaProjectM, runWithAgdaFileT, runWithAgdaProjectT) #if MIN_VERSION_Agda(2,7,0) @@ -58,15 +59,12 @@ takeOverNotificationHandlerWithAgdaLib notification handlerWithAgdaLib = do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri normUri = LSP.toNormalizedUri uri agdaProject <- findAgdaProject uri - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Info $ Text.pack $ prettyShow agdaProject + Log.infoP $ "For URI " <> pretty uri <> ", resolved project " <> pretty agdaProject let notificationHandler = runWithAgdaProjectT agdaProject . handlerWithAgdaLib normUri let handler = tryTC $ notificationHandler notification - let onErr = \err -> runWithAgdaProjectT agdaProject $ do - message <- Text.pack . prettyShow <$> TCM.liftTCM (TCM.prettyTCM err) - lift $ LSP.sendNotification LSP.SMethod_WindowShowMessage $ LSP.ShowMessageParams LSP.MessageType_Error message - lift $ LSP.sendNotification LSP.SMethod_WindowLogMessage $ LSP.LogMessageParams LSP.MessageType_Error message + let onErr = \err -> runWithAgdaProjectT agdaProject $ Log.errorTCM err fromRightM onErr handler diff --git a/src/Server/Model/Monad.hs b/src/Server/Model/Monad.hs index b70b871..f39dd71 100644 --- a/src/Server/Model/Monad.hs +++ b/src/Server/Model/Monad.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -29,12 +30,11 @@ import Agda.TypeChecking.Monad (HasOptions (..), MonadTCEnv (..), MonadTCM (..), import qualified Agda.TypeChecking.Monad as TCM import Agda.Utils.IORef (modifyIORef', readIORef, writeIORef) import Agda.Utils.Lens (Lens', locally, over, view, (<&>), (^.)) -import Agda.Utils.Monad (and2M, bracket_, ifNotM) +import Agda.Utils.Monad (MonadTrans (lift), and2M, bracket_, ifNotM) import Agda.Utils.Null (null) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), ask) -import Control.Monad.Trans (MonadTrans) -import Monad (ServerM) +import Monad (MonadMockLsp, ServerM) import Server.Model.AgdaFile (AgdaFile) import Server.Model.AgdaLib (AgdaLib) import Server.Model.AgdaProject (AgdaProject) @@ -42,6 +42,9 @@ import qualified Server.Model.AgdaProject as AgdaProject import Prelude hiding (null) #if MIN_VERSION_Agda(2,8,0) import Agda.Utils.FileId (File, getIdFile) +import Language.LSP.Server (MonadLsp, getLspEnv) +import Options (Config) +import Control.Monad.IO.Unlift (MonadUnliftIO) #endif -------------------------------------------------------------------------------- @@ -197,7 +200,7 @@ defaultIdFromFile = TCM.stateTCLens TCM.stFileDict . TCM.registerFileIdWithBuilt -------------------------------------------------------------------------------- newtype WithAgdaProjectT m a = WithAgdaProjectT {unWithAgdaProjectT :: ReaderT AgdaProject m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadUnliftIO) runWithAgdaProjectT :: AgdaProject -> WithAgdaProjectT m a -> m a runWithAgdaProjectT agdaProject = flip runReaderT agdaProject . unWithAgdaProjectT @@ -208,6 +211,8 @@ instance (MonadIO m) => MonadAgdaProject (WithAgdaProjectT m) where askAgdaProject = WithAgdaProjectT ask localAgdaProject f = WithAgdaProjectT . local f . unWithAgdaProjectT +instance (MonadMockLsp m) => MonadMockLsp (WithAgdaProjectT m) + instance (MonadIO m) => MonadTCEnv (WithAgdaProjectT m) where askTC = defaultAskTC localTC = defaultLocalTC @@ -239,6 +244,9 @@ instance (MonadIO m) => TCM.MonadFileId (WithAgdaProjectT m) where idFromFile = defaultIdFromFile #endif +instance (MonadLsp Config m) => MonadLsp Config (WithAgdaProjectT m) where + getLspEnv = lift getLspEnv + -------------------------------------------------------------------------------- data WithAgdaFileEnv = WithAgdaFileEnv @@ -271,6 +279,8 @@ instance (MonadIO m) => MonadAgdaFile (WithAgdaFileT m) where askAgdaFile = WithAgdaFileT $ view withAgdaFileEnvAgdaFile localAgdaFile f = WithAgdaFileT . locally withAgdaFileEnvAgdaFile f . unWithAgdaFileT +instance (MonadMockLsp m) => MonadMockLsp (WithAgdaFileT m) + instance (MonadIO m) => MonadTCEnv (WithAgdaFileT m) where askTC = defaultAskTC localTC = defaultLocalTC diff --git a/test/Test/AgdaLibResolution.hs b/test/Test/AgdaLibResolution.hs index bb64ec2..e90e868 100644 --- a/test/Test/AgdaLibResolution.hs +++ b/test/Test/AgdaLibResolution.hs @@ -6,13 +6,17 @@ module Test.AgdaLibResolution (tests) where import Agda.Interaction.Library (parseLibName) #endif import Agda.Utils.Lens ((^.)) +import Agda.Utils.Maybe (fromJust) import Control.Monad.IO.Class (liftIO) +import Data.Function ((&)) import Indexer (indexFile) import qualified Language.LSP.Server as LSP import Monad (runServerT) import Server.AgdaProjectResolver (findAgdaProject) +import qualified Server.AgdaProjectResolver as AgdaProjectResolver import qualified Server.Filesystem as FS -import Server.Model.AgdaLib (AgdaLibOrigin (FromFile), agdaLibIncludes, agdaLibName) +import Server.Model.AgdaLib (agdaLibIncludes, agdaLibName) +import qualified Server.Model.AgdaProject as AgdaProject import Server.Model.Monad (runWithAgdaProjectT) import System.Directory (makeAbsolute) import Test.Tasty (TestTree, testGroup) @@ -29,25 +33,20 @@ tests :: TestTree tests = testGroup "Agda lib resolution" - [ -- testCase "Explicit" $ do - -- model <- TestData.getModel - - -- absConstPath <- makeAbsolute constPath - -- absAgdaLibPath <- makeAbsolute agdaLibPath - -- absSrcPath <- makeAbsolute srcPath + [ testCase "Explicit" $ do + model <- TestData.getModel - -- LSP.runLspT undefined $ do - -- env <- TestData.getServerEnv model - -- runServerT env $ do - -- lib <- findAgdaLib absConstPath + absConstPath <- makeAbsolute constPath + absAgdaLibPath <- makeAbsolute agdaLibPath + absSrcPath <- makeAbsolute srcPath - -- #if MIN_VERSION_Agda(2,8,0) - -- liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" - -- #else - -- liftIO $ lib ^. agdaLibName @?= "no-deps" - -- #endif - -- liftIO $ lib ^. agdaLibOrigin @?= FromFile (FS.LocalFilePath absAgdaLibPath) - -- liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath], + LSP.runLspT undefined $ do + env <- TestData.getServerEnv model + runServerT env $ do + project <- AgdaProjectResolver.findAgdaProject absConstPath + let lib = project ^. AgdaProject.agdaLib & fromJust + liftIO $ lib ^. agdaLibName @?= parseLibName "no-deps" + liftIO $ lib ^. agdaLibIncludes @?= [FS.LocalFilePath absSrcPath], testCase "Module without imports in lib without dependencies" $ do model <- TestData.getModel diff --git a/test/TestData.hs b/test/TestData.hs index 92c5fb4..5f34247 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -33,10 +33,8 @@ import qualified Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Pretty (prettyTCM) import Agda.Utils.FileName (absolute) import Agda.Utils.IORef (newIORef) -import Agda.Utils.Lens (set) import Control.Concurrent (newChan) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Function ((&)) import qualified Data.Map as Map import Data.Text (Text) import Indexer (indexFile, usingSrcAsCurrent) @@ -50,14 +48,13 @@ import qualified Server.CommandController as CommandController import qualified Server.Filesystem as FS import Server.Model (Model (Model)) import Server.Model.AgdaFile (AgdaFile, emptyAgdaFile) -import Server.Model.AgdaLib (agdaLibIncludes, AgdaLib (AgdaLib)) +import Server.Model.AgdaLib (AgdaLib (AgdaLib)) import qualified Server.Model.AgdaProject as AgdaProject import Server.Model.Monad (MonadAgdaProject, runWithAgdaProjectT) import qualified Server.ResponseController as ResponseController import qualified Server.VfsIndex as VfsIndex import System.FilePath (takeBaseName) import Agda.Utils.Null (empty) -import Server.Filesystem (FileId(LocalFilePath)) data AgdaFileDetails = AgdaFileDetails { fileName :: !String, @@ -187,7 +184,7 @@ getModel = do getServerEnv :: (MonadIO m) => Model -> m Env getServerEnv model = - Env defaultOptions True initConfig + Env defaultOptions True initConfig True <$> liftIO newChan <*> liftIO CommandController.new <*> liftIO newChan From 13c79e7aeaeb7008f71babdeeacf5661fad26bc1 Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 29 Dec 2025 16:00:18 -0500 Subject: [PATCH 43/47] set options better --- src/Indexer.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Indexer.hs b/src/Indexer.hs index a762b85..8e95007 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -34,6 +34,8 @@ usingSrcAsCurrent src x = do persistentOptions <- TCM.stPersistentOptions . TCM.stPersistentState <$> TCM.getTC setCommandLineOptionsByLib persistentOptions + TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src + #if MIN_VERSION_Agda(2,8,0) TCM.modifyTCLens TCM.stModuleToSourceId $ Map.insert (Imp.srcModuleName src) (Imp.srcOrigin src) TCM.localTC (\e -> e {TCM.envCurrentPath = Just (TCM.srcFileId $ Imp.srcOrigin src)}) x From 96c46b3001bf8c70929b0f9cfb616e76cb43d72b Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 29 Dec 2025 16:00:55 -0500 Subject: [PATCH 44/47] Improved logging --- agda-language-server.cabal | 2 - src/Agda/TypeChecking/Monad/Options/More.hs | 59 ------------------- src/Indexer.hs | 14 +++-- src/Indexer/Prepare.hs | 6 +- src/Server.hs | 18 +++++- .../Handler/TextDocument/FileManagement.hs | 5 +- src/Server/Log.hs | 29 ++++++++- src/Server/Model/AgdaLib.hs | 12 +++- 8 files changed, 69 insertions(+), 76 deletions(-) delete mode 100644 src/Agda/TypeChecking/Monad/Options/More.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 8f5e1e2..7870391 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -57,7 +57,6 @@ library Agda.Parser Agda.Position Agda.Syntax.Abstract.More - Agda.TypeChecking.Monad.Options.More Control.Concurrent.SizedChan Indexer Indexer.Indexer @@ -226,7 +225,6 @@ test-suite als-test Agda.Parser Agda.Position Agda.Syntax.Abstract.More - Agda.TypeChecking.Monad.Options.More Control.Concurrent.SizedChan Indexer Indexer.Indexer diff --git a/src/Agda/TypeChecking/Monad/Options/More.hs b/src/Agda/TypeChecking/Monad/Options/More.hs deleted file mode 100644 index b8f3168..0000000 --- a/src/Agda/TypeChecking/Monad/Options/More.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Agda.TypeChecking.Monad.Options.More () where - -import Agda.Interaction.Options (CommandLineOptions (..)) -import qualified Agda.Interaction.Options.Lenses as Lens -import Agda.TypeChecking.Monad (MonadTCM) -import qualified Agda.TypeChecking.Monad as TCM -import Agda.TypeChecking.Monad.Benchmark (updateBenchmarkingStatus) -import Agda.Utils.FileName (AbsolutePath, absolute) -import Agda.Utils.Lens ((^.)) -import qualified Agda.Utils.List1 as List1 -import Control.Monad.IO.Class (liftIO) -import Language.LSP.Protocol.Types.Uri.More (uriToPossiblyInvalidFilePath) -import qualified Server.Filesystem as FS -import Server.Model.AgdaLib (AgdaLib, agdaLibDependencies, agdaLibIncludes) -import Server.Model.Monad (MonadAgdaProject, askAgdaLib) -import System.Directory (getCurrentDirectory) - --- setCommandLineOptionsByLib :: --- (MonadTCM m, MonadAgdaProject m) => --- CommandLineOptions -> --- m () --- setCommandLineOptionsByLib opts = do --- root <- liftIO (absolute =<< getCurrentDirectory) --- setCommandLineOptionsByLib' root opts - --- setCommandLineOptionsByLib' :: --- (MonadTCM m, MonadAgdaProject m) => --- AbsolutePath -> --- CommandLineOptions -> --- m () --- setCommandLineOptionsByLib' root opts = do --- incs <- case optAbsoluteIncludePaths opts of --- [] -> do --- opts' <- setLibraryPathsByLib opts --- let incs = optIncludePaths opts' --- TCM.liftTCM $ TCM.setIncludeDirs incs root --- List1.toList <$> TCM.getIncludeDirs --- incs -> return incs --- TCM.modifyTC $ Lens.setCommandLineOptions opts {optAbsoluteIncludePaths = incs} --- TCM.liftTCM $ TCM.setPragmaOptions (optPragmaOptions opts) --- TCM.liftTCM updateBenchmarkingStatus - --- setLibraryPathsByLib :: --- (MonadTCM m, MonadAgdaProject m) => --- CommandLineOptions -> --- m CommandLineOptions --- setLibraryPathsByLib o = do --- agdaLib <- askAgdaLib --- return $ addDefaultLibrariesByLib agdaLib o - --- -- TODO: resolve dependency libs; see setLibraryIncludes in Agda - --- addDefaultLibrariesByLib :: AgdaLib -> CommandLineOptions -> CommandLineOptions --- addDefaultLibrariesByLib agdaLib o --- | not (null $ optLibraries o) || not (optUseLibs o) = o --- | otherwise = do --- let libs = agdaLib ^. agdaLibDependencies --- let incs = uriToPossiblyInvalidFilePath . FS.fileIdToUri <$> agdaLib ^. agdaLibIncludes --- o {optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs} diff --git a/src/Indexer.hs b/src/Indexer.hs index 8e95007..793b652 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -20,9 +20,11 @@ import qualified Data.Map as Map import Indexer.Indexer (indexAst) import Indexer.Monad (execIndexerM) import Indexer.Postprocess (postprocess) +import qualified Server.Log as Log import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (WithAgdaProjectM) import Indexer.Prepare (setCommandLineOptionsByLib) +import Agda.Syntax.Common.Pretty (pretty) usingSrcAsCurrent :: Imp.Source -> WithAgdaProjectM a -> WithAgdaProjectM a usingSrcAsCurrent src x = do @@ -59,9 +61,9 @@ withAstFor src f = usingSrcAsCurrent src $ do ast <- TCM.liftTCM $ toAbstract topLevel f ast -indexFile :: - Imp.Source -> - WithAgdaProjectM AgdaFile -indexFile src = withAstFor src $ \ast -> execIndexerM $ do - indexAst ast - postprocess +indexFile :: Imp.Source -> WithAgdaProjectM AgdaFile +indexFile src = do + Log.infoP $ "Indexing " <> pretty src + withAstFor src $ \ast -> execIndexerM $ do + indexAst ast + postprocess diff --git a/src/Indexer/Prepare.hs b/src/Indexer/Prepare.hs index fce284f..a5b4af1 100644 --- a/src/Indexer/Prepare.hs +++ b/src/Indexer/Prepare.hs @@ -64,11 +64,11 @@ defaultLibNames o = dependencyLibs :: CommandLineOptions -> WithAgdaProjectM [AgdaLib] dependencyLibs o = do directDependencies <- directDependencyLibNames o - Log.infoP $ "Direct dependencies: " <> pretty directDependencies + Log.traceP $ "Direct dependencies: " <> pretty directDependencies installed <- lift $ AgdaLibResolver.installedLibraries (FS.LocalFilePath <$> optOverrideLibrariesFile o) - Log.infoP $ "Installed libraries: " <> pretty installed + Log.traceP $ "Installed libraries: " <> pretty installed let libs = resolveDeps installed directDependencies [] [] - Log.infoP $ "Resolved dependencies: " <> pretty libs + Log.traceP $ "Resolved dependencies: " <> pretty libs case libs of Nothing -> return [] -- TODO: very wrong, do real error handling Just libs -> do diff --git a/src/Server.hs b/src/Server.hs index 0be8984..4e37ee8 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -24,6 +24,12 @@ import Switchboard (agdaCustomMethod) import qualified Switchboard import Server.Handler.TextDocument.DocumentSymbol (documentSymbolHandler) import Server.Handler.TextDocument.FileManagement (didOpenHandler, didCloseHandler, didSaveHandler) +import System.IO (stdout, stdin) +import Colog.Core (LogAction, WithSeverity) +import qualified Colog.Core as L +import Prettyprinter (viaShow, pretty) +import Language.LSP.Logging (defaultClientLogger) +import qualified Data.Text as T #if defined(wasm32_HOST_ARCH) import Agda.Utils.IO (catchIO) @@ -51,7 +57,7 @@ run options = do liftIO $ setFdOption stdInput NonBlockingRead True `catchIO` (\ (e :: IOError) -> hPutStrLn stderr $ "Failed to enable nonblocking on stdin: " ++ (show e) ++ "\nThe WASM module might not behave correctly.") #endif - runServer (serverDefn options) + runServerWithHandles defaultIOLogger defaultLspLogger stdin stdout (serverDefn options) where serverDefn :: Options -> ServerDefinition Config serverDefn options = @@ -76,6 +82,16 @@ run options = do options = lspOptions } +-- Unexported by lsp library +defaultIOLogger :: LogAction IO (WithSeverity LspServerLog) +defaultIOLogger = L.cmap (show . prettyMsg) L.logStringStderr + where + prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l) + +-- Modified from lsp library to remove stderr +defaultLspLogger :: LogAction (LspM config) (WithSeverity LspServerLog) +defaultLspLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger + lspOptions :: LSP.Options lspOptions = LSP.defaultOptions {optTextDocumentSync = Just syncOptions} diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index e176cb5..12fdc49 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -24,12 +24,13 @@ import qualified Server.VfsIndex as VfsIndex didOpenHandler :: LSP.Handlers ServerM didOpenHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidOpen $ \notification -> do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri - Log.infoP $ "Opening URI" <+> pretty uri + Log.infoP $ "Opening" <+> pretty uri modifyVfsIndex $ VfsIndex.onOpen uri takeOverNotificationHandlerWithAgdaLib notification $ \uri notification -> do vfile <- lift $ LSP.getVirtualFile uri case vfile of - Nothing -> return () + Nothing -> do + Log.warnT "Failed to open: could not find file" Just vfile -> do vSourceFile <- vSrcFromUri uri vfile src <- parseVSource vSourceFile diff --git a/src/Server/Log.hs b/src/Server/Log.hs index 281ddbd..4e86b2f 100644 --- a/src/Server/Log.hs +++ b/src/Server/Log.hs @@ -1,8 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} module Server.Log - ( infoT, + ( traceT, + traceP, + infoT, infoP, + warnT, + warnP, errorT, errorP, errorTCM, @@ -13,14 +17,23 @@ import Agda.Syntax.Common.Pretty (Pretty, prettyShow) import Agda.TypeChecking.Monad (MonadTCM, liftTCM) import Agda.TypeChecking.Pretty (PrettyTCM, prettyTCM) import Agda.Utils.Monad (ifM, (<=<)) -import Colog.Core (Severity (Error, Info), WithSeverity (WithSeverity), (<&)) +import Colog.Core (Severity (Error, Info, Warning), WithSeverity (WithSeverity), (<&)) import Data.Text (Text) import qualified Data.Text as Text import qualified Language.LSP.Logging as LSP +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server (MonadLsp) +import qualified Language.LSP.Server as LSP import Monad (MonadMockLsp (shouldMockLsp)) import Options (Config) +trace :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () +trace text = + ifM shouldMockLsp (pure ()) $ + LSP.sendNotification LSP.SMethod_LogTrace $ + LSP.LogTraceParams text Nothing + console :: (MonadLsp Config m, MonadMockLsp m) => Severity -> Text -> m () console severity text = ifM shouldMockLsp (pure ()) $ @@ -31,12 +44,24 @@ popup severity text = ifM shouldMockLsp (pure ()) $ LSP.logToShowMessage <& WithSeverity text severity +traceT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () +traceT text = trace text + +traceP :: (MonadLsp Config m, MonadMockLsp m, Pretty p) => p -> m () +traceP = traceT . Text.pack . prettyShow + infoT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () infoT text = console Info text infoP :: (MonadLsp Config m, MonadMockLsp m, Pretty p) => p -> m () infoP = infoT . Text.pack . prettyShow +warnT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () +warnT text = console Warning text + +warnP :: (MonadLsp Config m, MonadMockLsp m, Pretty p) => p -> m () +warnP = warnT . Text.pack . prettyShow + errorT :: (MonadLsp Config m, MonadMockLsp m) => Text -> m () errorT text = console Error text >> popup Error text diff --git a/src/Server/Model/AgdaLib.hs b/src/Server/Model/AgdaLib.hs index ccf4ed3..9351398 100644 --- a/src/Server/Model/AgdaLib.hs +++ b/src/Server/Model/AgdaLib.hs @@ -39,6 +39,10 @@ instance Pretty AgdaLib where <+> pshow (agdaLib ^. agdaLibFile) <+> text "includes:" <+> pretty (agdaLib ^. agdaLibIncludes) + <+> text "options:" + <+> pshow (agdaLib ^. agdaLibOptionsPragma) + <+> text "dependencies:" + <+> pretty (agdaLib ^. agdaLibDependencies) agdaLibName :: Lens' AgdaLib LibName agdaLibName f a = f (_agdaLibName a) <&> \x -> a {_agdaLibName = x} @@ -82,4 +86,10 @@ agdaLibToFile relativeToUri agdaLib = uri = FS.fileIdToUri $ agdaLib ^. agdaLibFile above = LSP.uriHeightAbove uri relativeToUri filePath = LSP.uriToPossiblyInvalidFilePath uri - in AgdaLibFile (agdaLib ^. agdaLibName) filePath above includePaths [] (agdaLib ^. agdaLibOptionsPragma) + in AgdaLibFile + (agdaLib ^. agdaLibName) + filePath + above + includePaths + (agdaLib ^. agdaLibDependencies) + (agdaLib ^. agdaLibOptionsPragma) From 73e90b9bc792a9add89a96536af6d1f8bc924166 Mon Sep 17 00:00:00 2001 From: nvarner Date: Mon, 29 Dec 2025 16:42:55 -0500 Subject: [PATCH 45/47] consistent spelling --- src/Server/Handler/TextDocument/FileManagement.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Server/Handler/TextDocument/FileManagement.hs b/src/Server/Handler/TextDocument/FileManagement.hs index 12fdc49..b1cfbb3 100644 --- a/src/Server/Handler/TextDocument/FileManagement.hs +++ b/src/Server/Handler/TextDocument/FileManagement.hs @@ -18,7 +18,6 @@ import Monad (ServerM, modifyModel, modifyVfsIndex) import qualified Server.Log as Log import qualified Server.Model as Model import Server.Model.Handler (notificationHandlerWithAgdaLib, takeOverNotificationHandlerWithAgdaLib) -import qualified Server.VfsIndex as VFSIndex import qualified Server.VfsIndex as VfsIndex didOpenHandler :: LSP.Handlers ServerM @@ -42,7 +41,7 @@ didCloseHandler :: LSP.Handlers ServerM didCloseHandler = LSP.notificationHandler LSP.SMethod_TextDocumentDidClose $ \notification -> do let uri = notification ^. LSP.params . LSP.textDocument . LSP.uri Log.infoP $ "Closing URI" <+> pretty uri - modifyVfsIndex $ VFSIndex.onClose uri + modifyVfsIndex $ VfsIndex.onClose uri modifyModel $ Model.deleteAgdaFile $ LSP.toNormalizedUri uri didSaveHandler :: LSP.Handlers ServerM From b7d130f786a4fa36df1c05e93c2e11f9f80a2dea Mon Sep 17 00:00:00 2001 From: nvarner Date: Tue, 30 Dec 2025 11:58:23 -0500 Subject: [PATCH 46/47] import primitives --- src/Indexer.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Indexer.hs b/src/Indexer.hs index 793b652..cd1d72a 100644 --- a/src/Indexer.hs +++ b/src/Indexer.hs @@ -25,13 +25,18 @@ import Server.Model.AgdaFile (AgdaFile) import Server.Model.Monad (WithAgdaProjectM) import Indexer.Prepare (setCommandLineOptionsByLib) import Agda.Syntax.Common.Pretty (pretty) +import Agda.Interaction.Options (defaultOptions) usingSrcAsCurrent :: Imp.Source -> WithAgdaProjectM a -> WithAgdaProjectM a usingSrcAsCurrent src x = do TCM.liftTCM TCM.resetState + setCommandLineOptionsByLib defaultOptions + TCM.liftTCM $ Imp.setOptionsFromSourcePragmas True src + TCM.liftTCM Imp.importPrimitiveModules + TCM.setCurrentRange (C.modPragmas . Imp.srcModule $ src) $ do persistentOptions <- TCM.stPersistentOptions . TCM.stPersistentState <$> TCM.getTC setCommandLineOptionsByLib persistentOptions From 5824ac86f8133e02ae5a66bd052f6e872e459823 Mon Sep 17 00:00:00 2001 From: nvarner Date: Wed, 31 Dec 2025 15:34:27 -0500 Subject: [PATCH 47/47] start on integration test --- agda-language-server.cabal | 2 ++ test/Test.hs | 4 ++- .../Integration/LibraryDependencies/Test.hs | 29 +++++++++++++++++++ .../data/has-dep/has-dep.agda-lib | 3 ++ .../data/has-dep/src/Three.agda | 7 +++++ .../data/no-deps/no-deps.agda-lib | 2 ++ .../data/no-deps/src/Constants.agda | 9 ++++++ .../data/no-deps/src/Data/Nat.agda | 5 ++++ test/Test/Integration/Test.hs | 11 +++++++ 9 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 test/Test/Integration/LibraryDependencies/Test.hs create mode 100644 test/Test/Integration/LibraryDependencies/data/has-dep/has-dep.agda-lib create mode 100644 test/Test/Integration/LibraryDependencies/data/has-dep/src/Three.agda create mode 100644 test/Test/Integration/LibraryDependencies/data/no-deps/no-deps.agda-lib create mode 100644 test/Test/Integration/LibraryDependencies/data/no-deps/src/Constants.agda create mode 100644 test/Test/Integration/LibraryDependencies/data/no-deps/src/Data/Nat.agda create mode 100644 test/Test/Integration/Test.hs diff --git a/agda-language-server.cabal b/agda-language-server.cabal index 7870391..d4506fa 100644 --- a/agda-language-server.cabal +++ b/agda-language-server.cabal @@ -208,6 +208,8 @@ test-suite als-test Test.Indexer.Invariants.NoOverlap Test.Indexer.NoAnonFunSymbol Test.Indexer.Reload + Test.Integration.LibraryDependencies.Test + Test.Integration.Test Test.LSP Test.Model Test.ModelMonad diff --git a/test/Test.hs b/test/Test.hs index 2f7b6cd..07ca085 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -14,6 +14,7 @@ import qualified Test.ModelMonad as ModelMonad import qualified Test.Uri as URI import qualified Test.Indexer as Indexer import qualified Test.AgdaLibResolution as AgdaLibResolution +import qualified Test.Integration.Test as Integration -- Define the custom option newtype AlsPathOption = AlsPathOption FilePath @@ -43,7 +44,8 @@ tests = do Model.tests, ModelMonad.tests, AgdaLibResolution.tests, - indexerTests + indexerTests, + Integration.tests alsPath #if defined(wasm32_HOST_ARCH) , WASM.tests alsPath #endif diff --git a/test/Test/Integration/LibraryDependencies/Test.hs b/test/Test/Integration/LibraryDependencies/Test.hs new file mode 100644 index 0000000..16a4dbb --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/Test.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Test.Integration.LibraryDependencies.Test (test) where + +import Agda.Utils.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Function ((&)) +import Data.Text (Text) +import Language.LSP.Protocol.Lens (HasName, name) +import Language.LSP.Test +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +test :: FilePath -> TestTree +test alsPath = testCase "Library dependencies" $ + runSession alsPath fullLatestClientCaps "test/Test/Integration/LibraryDependencies/data" $ do + doc <- openDoc "has-dep/src/Three.agda" "agda" + + notification <- anyNotification + liftIO $ print notification + + -- Check that we really opened and indexed the file + docSymbols <- getDocumentSymbols doc + + let fromNamed :: (HasName a Text) => [a] -> [Text] + fromNamed = fmap $ \named -> named ^. name + let docSymbolNames = docSymbols & either fromNamed fromNamed + + liftIO $ docSymbolNames @?= ["three"] diff --git a/test/Test/Integration/LibraryDependencies/data/has-dep/has-dep.agda-lib b/test/Test/Integration/LibraryDependencies/data/has-dep/has-dep.agda-lib new file mode 100644 index 0000000..146e518 --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/data/has-dep/has-dep.agda-lib @@ -0,0 +1,3 @@ +name: has-dep +include: src +depend: no-deps diff --git a/test/Test/Integration/LibraryDependencies/data/has-dep/src/Three.agda b/test/Test/Integration/LibraryDependencies/data/has-dep/src/Three.agda new file mode 100644 index 0000000..4528d6a --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/data/has-dep/src/Three.agda @@ -0,0 +1,7 @@ +module Three where + +open import Data.Nat +open import Constants + +three : Nat +three = suc two diff --git a/test/Test/Integration/LibraryDependencies/data/no-deps/no-deps.agda-lib b/test/Test/Integration/LibraryDependencies/data/no-deps/no-deps.agda-lib new file mode 100644 index 0000000..9970791 --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/data/no-deps/no-deps.agda-lib @@ -0,0 +1,2 @@ +name: no-deps +include: src diff --git a/test/Test/Integration/LibraryDependencies/data/no-deps/src/Constants.agda b/test/Test/Integration/LibraryDependencies/data/no-deps/src/Constants.agda new file mode 100644 index 0000000..699e243 --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/data/no-deps/src/Constants.agda @@ -0,0 +1,9 @@ +module Constants where + +open import Data.Nat + +one : Nat +one = suc zero + +two : Nat +two = suc one diff --git a/test/Test/Integration/LibraryDependencies/data/no-deps/src/Data/Nat.agda b/test/Test/Integration/LibraryDependencies/data/no-deps/src/Data/Nat.agda new file mode 100644 index 0000000..9ee2cba --- /dev/null +++ b/test/Test/Integration/LibraryDependencies/data/no-deps/src/Data/Nat.agda @@ -0,0 +1,5 @@ +module Data.Nat where + +data Nat : Set where + zero : Nat + suc : Nat -> Nat diff --git a/test/Test/Integration/Test.hs b/test/Test/Integration/Test.hs new file mode 100644 index 0000000..63b2bff --- /dev/null +++ b/test/Test/Integration/Test.hs @@ -0,0 +1,11 @@ +module Test.Integration.Test (tests) where + +import qualified Test.Integration.LibraryDependencies.Test as LibraryDependencies +import Test.Tasty (TestTree, testGroup) + +tests :: FilePath -> TestTree +tests alsPath = + testGroup + "Integration tests" + [ LibraryDependencies.test alsPath + ]