From da469c2f69ad853c3415f86efad7d336e6ab8603 Mon Sep 17 00:00:00 2001 From: fwcd Date: Fri, 26 Jul 2024 18:38:46 +0200 Subject: [PATCH 1/6] Migrate Config to new record dot syntax --- src/Curry/LanguageServer/Compiler.hs | 8 +-- src/Curry/LanguageServer/Config.hs | 52 +++++++++---------- .../Handlers/TextDocument/Completion.hs | 4 +- src/Curry/LanguageServer/Index/Store.hs | 3 +- src/Curry/LanguageServer/Utils/Logging.hs | 6 +-- 5 files changed, 37 insertions(+), 36 deletions(-) diff --git a/src/Curry/LanguageServer/Compiler.hs b/src/Curry/LanguageServer/Compiler.hs index fabb19f..193983e 100644 --- a/src/Curry/LanguageServer/Compiler.hs +++ b/src/Curry/LanguageServer/Compiler.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} module Curry.LanguageServer.Compiler ( CompileAuxiliary (..) , CompileState (..) @@ -113,9 +113,9 @@ compileCurryFileWithDeps cfg aux importPaths outDirPath filePath = (fromMaybe me let defOpts = CO.defaultOptions cppOpts = CO.optCppOpts defOpts cppDefs = M.insert "__PAKCS__" 300 (CO.cppDefinitions cppOpts) - opts = CO.defaultOptions { CO.optForce = CFG.cfgForceRecompilation cfg - , CO.optImportPaths = importPaths ++ CFG.cfgImportPaths cfg - , CO.optLibraryPaths = CFG.cfgLibraryPaths cfg + opts = CO.defaultOptions { CO.optForce = cfg.forceRecompilation + , CO.optImportPaths = importPaths ++ cfg.importPaths + , CO.optLibraryPaths = cfg.libraryPaths , CO.optCppOpts = cppOpts { CO.cppDefinitions = cppDefs } , CO.optExtensions = nub $ CSE.kielExtensions ++ CO.optExtensions defOpts , CO.optOriginPragmas = True diff --git a/src/Curry/LanguageServer/Config.hs b/src/Curry/LanguageServer/Config.hs index cc53a00..2c78148 100644 --- a/src/Curry/LanguageServer/Config.hs +++ b/src/Curry/LanguageServer/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings, TypeApplications #-} +{-# LANGUAGE NoFieldSelectors, OverloadedRecordDot, RecordWildCards, OverloadedStrings, TypeApplications #-} module Curry.LanguageServer.Config ( Config (..) , LogLevel (..) @@ -18,49 +18,49 @@ import Data.Aeson import Data.Default (Default(..)) import qualified Data.Text as T -newtype LogLevel = LogLevel { llSeverity :: Severity } +newtype LogLevel = LogLevel { severity :: Severity } deriving (Show, Eq) -data Config = Config { cfgForceRecompilation :: Bool - , cfgImportPaths :: [FilePath] - , cfgLibraryPaths :: [FilePath] - , cfgLogLevel :: LogLevel - , cfgCurryPath :: String - , cfgUseSnippetCompletions :: Bool +data Config = Config { forceRecompilation :: Bool + , importPaths :: [FilePath] + , libraryPaths :: [FilePath] + , logLevel :: LogLevel + , curryPath :: String + , useSnippetCompletions :: Bool } deriving (Show, Eq) instance Default Config where - def = Config { cfgForceRecompilation = False - , cfgImportPaths = [] - , cfgLibraryPaths = [] - , cfgLogLevel = LogLevel Info - , cfgCurryPath = "pakcs" - , cfgUseSnippetCompletions = False + def = Config { forceRecompilation = False + , importPaths = [] + , libraryPaths = [] + , logLevel = LogLevel Info + , curryPath = "pakcs" + , useSnippetCompletions = False } instance FromJSON Config where parseJSON = withObject "Config" $ \o -> do c <- o .: "curry" l <- c .: "languageServer" - cfgForceRecompilation <- l .:? "forceRecompilation" .!= cfgForceRecompilation def - cfgImportPaths <- l .:? "importPaths" .!= cfgImportPaths def - cfgLibraryPaths <- l .:? "libraryPaths" .!= cfgLibraryPaths def - cfgLogLevel <- l .:? "logLevel" .!= cfgLogLevel def - cfgCurryPath <- l .:? "curryPath" .!= cfgCurryPath def - cfgUseSnippetCompletions <- l .:? "useSnippetCompletions" .!= cfgUseSnippetCompletions def + forceRecompilation <- l .:? "forceRecompilation" .!= (def @Config).forceRecompilation + importPaths <- l .:? "importPaths" .!= (def @Config).importPaths + libraryPaths <- l .:? "libraryPaths" .!= (def @Config).libraryPaths + logLevel <- l .:? "logLevel" .!= (def @Config).logLevel + curryPath <- l .:? "curryPath" .!= (def @Config).curryPath + useSnippetCompletions <- l .:? "useSnippetCompletions" .!= (def @Config).useSnippetCompletions return Config {..} instance ToJSON Config where toJSON Config {..} = object ["curry" .= object [ "languageServer" .= object - [ "forceRecompilation" .= cfgForceRecompilation - , "importPaths" .= cfgImportPaths - , "libraryPaths" .= cfgLibraryPaths - , "logLevel" .= cfgLogLevel - , "curryPath" .= cfgCurryPath - , "useSnippetCompletions" .= cfgUseSnippetCompletions + [ "forceRecompilation" .= forceRecompilation + , "importPaths" .= importPaths + , "libraryPaths" .= libraryPaths + , "logLevel" .= logLevel + , "curryPath" .= curryPath + , "useSnippetCompletions" .= useSnippetCompletions ] ] ] diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs index c580617..3f81841 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, FlexibleContexts, FlexibleInstances, MultiWayIf #-} module Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) where -- Curry Compiler Libraries + Dependencies @@ -48,7 +48,7 @@ completionHandler = S.requestHandler J.STextDocumentCompletion $ \req responder query <- MaybeT $ VFS.getCompletionPrefix pos vfile let opts = CompletionOptions - { cmoUseSnippets = CFG.cfgUseSnippetCompletions cfg && fromMaybe False (do + { cmoUseSnippets = cfg.useSnippetCompletions && fromMaybe False (do docCapabilities <- capabilities ^. J.textDocument cmCapabilities <- docCapabilities ^. J.completion ciCapabilities <- cmCapabilities ^. J.completionItem diff --git a/src/Curry/LanguageServer/Index/Store.hs b/src/Curry/LanguageServer/Index/Store.hs index 471e558..7b97517 100644 --- a/src/Curry/LanguageServer/Index/Store.hs +++ b/src/Curry/LanguageServer/Index/Store.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} module Curry.LanguageServer.Index.Store ( ModuleStoreEntry (..) , IndexStore (..) @@ -184,7 +185,7 @@ findCurrySourcesInWorkspace cfg dirPath = do -- | Finds the Curry source files in a (project) directory. findCurrySourcesInProject :: (MonadIO m, MonadLsp CFG.Config m) => CFG.Config -> FilePath -> m [CurrySourceFile] findCurrySourcesInProject cfg dirPath = do - let curryPath = CFG.cfgCurryPath cfg + let curryPath = cfg.curryPath cpmPath = curryPath ++ " cypm" libPath binPath = takeDirectory (takeDirectory binPath) "lib" diff --git a/src/Curry/LanguageServer/Utils/Logging.hs b/src/Curry/LanguageServer/Utils/Logging.hs index e0dad3e..bdd9dde 100644 --- a/src/Curry/LanguageServer/Utils/Logging.hs +++ b/src/Curry/LanguageServer/Utils/Logging.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} module Curry.LanguageServer.Utils.Logging ( logAt, showAt , errorM, warnM, infoM, debugM @@ -6,7 +6,7 @@ module Curry.LanguageServer.Utils.Logging import Colog.Core (Severity (..), WithSeverity (..), (<&)) import Control.Monad (when) -import Curry.LanguageServer.Config (Config (cfgLogLevel), LogLevel (llSeverity)) +import Curry.LanguageServer.Config (Config (..), LogLevel (..)) import qualified Data.Text as T import Language.LSP.Logging (logToLogMessage, logToShowMessage) import Language.LSP.Server (MonadLsp, getConfig) @@ -15,7 +15,7 @@ import Language.LSP.Server (MonadLsp, getConfig) logAt :: MonadLsp Config m => Severity -> T.Text -> m () logAt sev msg = do cfg <- getConfig - when (sev >= llSeverity (cfgLogLevel cfg)) $ + when (sev >= cfg.logLevel.severity) $ logToLogMessage <& WithSeverity msg sev -- | Presents a log message in a notification to the user (window/showMessage). From 6b1b0164673b5601876cb4c05b47dc370d5e4fb2 Mon Sep 17 00:00:00 2001 From: fwcd Date: Fri, 26 Jul 2024 18:40:50 +0200 Subject: [PATCH 2/6] Migrate Compiler to record dot syntax --- src/Curry/LanguageServer/Compiler.hs | 22 +++++++++++----------- src/Curry/LanguageServer/Index/Store.hs | 4 ++-- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Curry/LanguageServer/Compiler.hs b/src/Curry/LanguageServer/Compiler.hs index 193983e..3e0cb49 100644 --- a/src/Curry/LanguageServer/Compiler.hs +++ b/src/Curry/LanguageServer/Compiler.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} +{-# LANGUAGE LambdaCase, NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} module Curry.LanguageServer.Compiler ( CompileAuxiliary (..) , CompileState (..) @@ -63,20 +63,20 @@ newtype CompileAuxiliary = CompileAuxiliary -- | Read/write state used during compilation. data CompileState = CompileState - { csWarnings :: [CM.Message] - , csErrors :: [CM.Message] + { warnings :: [CM.Message] + , errors :: [CM.Message] } instance Semigroup CompileState where x <> y = CompileState - { csWarnings = csWarnings x ++ csWarnings y - , csErrors = csErrors x ++ csErrors y + { warnings = x.warnings ++ y.warnings + , errors = x.errors ++ y.errors } instance Monoid CompileState where mempty = CompileState - { csWarnings = [] - , csErrors = [] + { warnings = [] + , errors = [] } -- | A custom monad for compilation state as a CYIO-replacement that doesn't track errors in an ExceptT. @@ -88,10 +88,10 @@ runCMT cm aux = flip runReaderT aux . flip runStateT mempty . runMaybeT $ cm catchCYIO :: MonadIO m => CYIO a -> CMT m (Maybe a) catchCYIO cyio = liftIO (runCYIO cyio) >>= \case Left es -> do - modify $ \s -> s { csErrors = csErrors s ++ es } + modify $ \s -> s { errors = s.errors ++ es } return Nothing Right (x, ws) -> do - modify $ \s -> s { csWarnings = csWarnings s ++ ws } + modify $ \s -> s { warnings = s.warnings ++ ws } return $ Just x liftToCM :: Monad m => m a -> CMT m a @@ -170,7 +170,7 @@ compileCurryModule opts outDirPath m fp = do loadAndCheckCurryModule :: MonadIO m => CO.Options -> CI.ModuleIdent -> FilePath -> CMT m (CE.CompEnv ModuleAST) loadAndCheckCurryModule opts m fp = do -- Read source file (possibly from VFS) - fl <- asks fileLoader + fl <- asks (.fileLoader) src <- liftIO $ fl fp -- Load and check module loaded <- liftCYIO $ loadCurryModule opts m src fp @@ -231,7 +231,7 @@ parseCurryModule opts _ src fp = do return (lexed, ast) failedCompilation :: String -> (CompileOutput, CompileState) -failedCompilation msg = (mempty, mempty { csErrors = [makeFailMessage msg] }) +failedCompilation msg = (mempty, mempty { errors = [makeFailMessage msg] }) makeFailMessage :: String -> CM.Message makeFailMessage = CM.message . PP.text diff --git a/src/Curry/LanguageServer/Index/Store.hs b/src/Curry/LanguageServer/Index/Store.hs index 7b97517..24ecc32 100644 --- a/src/Curry/LanguageServer/Index/Store.hs +++ b/src/Curry/LanguageServer/Index/Store.hs @@ -285,8 +285,8 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do -- Ignore parses from interface files, only consider source files for now asts <- mapM (\(fp, mdl) -> (, mdl) <$> filePathToNormalizedUri fp) $ filter ((".curry" `T.isSuffixOf`) . T.pack . fst) co - warns <- groupIntoMapByM msgNormUri $ C.csWarnings cs - errors <- groupIntoMapByM msgNormUri $ C.csErrors cs + warns <- groupIntoMapByM msgNormUri cs.warnings + errors <- groupIntoMapByM msgNormUri cs.errors debugM $ "Recompiled module paths: " <> T.pack (show (fst <$> asts)) From 7f1f8a0af40f7d06537d58dc2188444bddae385e Mon Sep 17 00:00:00 2001 From: fwcd Date: Fri, 26 Jul 2024 18:43:14 +0200 Subject: [PATCH 3/6] Migrate Monad to record dot syntax --- src/Curry/LanguageServer/Monad.hs | 44 +++++++++++++++---------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Curry/LanguageServer/Monad.hs b/src/Curry/LanguageServer/Monad.hs index 9a4ea1e..493634e 100644 --- a/src/Curry/LanguageServer/Monad.hs +++ b/src/Curry/LanguageServer/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, MultiParamTypeClasses, OverloadedStrings #-} module Curry.LanguageServer.Monad ( LSState (..) , newLSStateVar @@ -24,20 +24,20 @@ import qualified Data.Map as M import Language.LSP.Server (LspT, LanguageContextEnv, runLspT) import qualified Language.LSP.Types as J -data DirtyModuleHandlers = DirtyModuleHandlers { dmhRecompileHandler :: IO () - , dmhAuxiliaryHandler :: IO () +data DirtyModuleHandlers = DirtyModuleHandlers { recompileHandler :: IO () + , auxiliaryHandler :: IO () } instance Default DirtyModuleHandlers where def = DirtyModuleHandlers - { dmhRecompileHandler = return () - , dmhAuxiliaryHandler = return () + { recompileHandler = return () + , auxiliaryHandler = return () } -- The language server's state, e.g. holding loaded/compiled modules. -data LSState = LSState { lssIndexStore :: I.IndexStore - , lssDirtyModuleHandlers :: M.Map J.Uri DirtyModuleHandlers - , lssDebouncer :: Debouncer (IO ()) IO +data LSState = LSState { indexStore :: I.IndexStore + , dirtyModuleHandlers :: M.Map J.Uri DirtyModuleHandlers + , debouncer :: Debouncer (IO ()) IO } newLSState :: IO LSState @@ -46,9 +46,9 @@ newLSState = do let delayMs = 500 debouncer <- debounce (delayMs * 1000) id return LSState - { lssIndexStore = def - , lssDirtyModuleHandlers = M.empty - , lssDebouncer = debouncer + { indexStore = def + , dirtyModuleHandlers = M.empty + , debouncer = debouncer } newLSStateVar :: IO (MVar LSState) @@ -81,34 +81,34 @@ modifyLSState m = do -- | Fetches the index store holding compiled modules. getStore :: LSM I.IndexStore -getStore = lssIndexStore <$> getLSState +getStore = (.indexStore) <$> getLSState -- | Replaces the index store holding compiled modules. putStore :: I.IndexStore -> LSM () -putStore i = modifyLSState $ \s -> s { lssIndexStore = i } +putStore i = modifyLSState $ \s -> s { indexStore = i } -- | Updates the index store holding compiled modules. modifyStore :: (I.IndexStore -> I.IndexStore) -> LSM () -modifyStore m = modifyLSState $ \s -> s { lssIndexStore = m $ lssIndexStore s } +modifyStore m = modifyLSState $ \s -> s { indexStore = m s.indexStore } -- | Updates the dirty module handlers for a module. updateDirtyModuleHandlers :: J.Uri -> (DirtyModuleHandlers -> DirtyModuleHandlers) -> LSM () -updateDirtyModuleHandlers uri f = modifyLSState $ \s -> s { lssDirtyModuleHandlers = M.alter (Just . f . fromMaybe def) uri $ lssDirtyModuleHandlers s } +updateDirtyModuleHandlers uri f = modifyLSState $ \s -> s { dirtyModuleHandlers = M.alter (Just . f . fromMaybe def) uri s.dirtyModuleHandlers } -- | Runs all dirty module handlers. runDirtyModuleHandlers :: LSM () runDirtyModuleHandlers = do - hs <- lssDirtyModuleHandlers <$> getLSState - liftIO $ M.foldl' (>>) (return ()) $ M.map (\dmh -> dmhRecompileHandler dmh >> dmhAuxiliaryHandler dmh) hs + hs <- (.dirtyModuleHandlers) <$> getLSState + liftIO $ M.foldl' (>>) (return ()) $ M.map (\dmh -> dmh.recompileHandler >> dmh.auxiliaryHandler) hs -- | Clears all dirty module handlers. clearDirtyModuleHandlers :: LSM () -clearDirtyModuleHandlers = modifyLSState $ \s -> s { lssDirtyModuleHandlers = M.empty } +clearDirtyModuleHandlers = modifyLSState $ \s -> s { dirtyModuleHandlers = M.empty } -- | Triggers the debouncer that (eventually) executes and removes all dirty module handlers. triggerDebouncer :: LSM () triggerDebouncer = do - (db, _) <- lssDebouncer <$> getLSState + (db, _) <- (.debouncer) <$> getLSState runInIO <- askRunInIO liftIO $ db $ runInIO $ do runDirtyModuleHandlers @@ -118,17 +118,17 @@ triggerDebouncer = do markModuleDirty :: J.Uri -> LSM () -> LSM () markModuleDirty uri h = do runInIO <- askRunInIO - updateDirtyModuleHandlers uri $ \dmh -> dmh { dmhRecompileHandler = runInIO h } + updateDirtyModuleHandlers uri $ \dmh -> dmh { recompileHandler = runInIO h } triggerDebouncer -- | Adds a handler that either executes directly if the module is clean (= compiled, unedited) or defers its execution to the next compilation. scheduleModuleHandler :: J.Uri -> LSM () -> LSM () scheduleModuleHandler uri h = do - hs <- lssDirtyModuleHandlers <$> getLSState + hs <- (.dirtyModuleHandlers) <$> getLSState if M.member uri hs then do -- Module is dirty (edited since the last compilation), defer execution by attaching it as an auxiliary handler runInIO <- askRunInIO - updateDirtyModuleHandlers uri $ \dmh -> dmh { dmhAuxiliaryHandler = dmhAuxiliaryHandler dmh >> runInIO h } + updateDirtyModuleHandlers uri $ \dmh -> dmh { auxiliaryHandler = dmh.auxiliaryHandler >> runInIO h } triggerDebouncer else do -- Module is clean (unedited since the last compilation), execute directly From cd9346ecb44fbfa3a773e420796354a2d8eef108 Mon Sep 17 00:00:00 2001 From: fwcd Date: Fri, 26 Jul 2024 18:45:19 +0200 Subject: [PATCH 4/6] Migrate Completion to record dot syntax --- .../Handlers/TextDocument/Completion.hs | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs index 3f81841..f2d7088 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, FlexibleContexts, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts, FlexibleInstances, MultiWayIf #-} module Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) where -- Curry Compiler Libraries + Dependencies @@ -48,7 +48,7 @@ completionHandler = S.requestHandler J.STextDocumentCompletion $ \req responder query <- MaybeT $ VFS.getCompletionPrefix pos vfile let opts = CompletionOptions - { cmoUseSnippets = cfg.useSnippetCompletions && fromMaybe False (do + { useSnippets = cfg.useSnippetCompletions && fromMaybe False (do docCapabilities <- capabilities ^. J.textDocument cmCapabilities <- docCapabilities ^. J.completion ciCapabilities <- cmCapabilities ^. J.completionItem @@ -125,15 +125,15 @@ data Tagged a = Tagged [J.CompletionItemTag] a data CompletionSymbol = CompletionSymbol { -- The index symbol - cmsSymbol :: I.Symbol + symbol :: I.Symbol -- The, possibly aliased, module name. Nothing means that the symbol is available unqualified. - , cmsModuleName :: Maybe T.Text + , moduleName :: Maybe T.Text -- Import edits to apply after the completion has been selected. Nothing means that the symbol does not require an import. - , cmsImportEdits :: Maybe [J.TextEdit] + , importEdits :: Maybe [J.TextEdit] } newtype CompletionOptions = CompletionOptions - { cmoUseSnippets :: Bool + { useSnippets :: Bool } -- | Turns an index symbol into completion symbols by analyzing the module's imports. @@ -144,16 +144,16 @@ toCompletionSymbols entry s = do impNames = S.fromList [ppToText mid' | CS.ImportDecl _ mid' _ _ _ <- imps] if | I.sKind s == I.Module -> return CompletionSymbol - { cmsSymbol = s - , cmsModuleName = Nothing - , cmsImportEdits = Nothing + { symbol = s + , moduleName = Nothing + , importEdits = Nothing } | (I.sParentIdent s == pre && pre `S.notMember` impNames) || I.sParentIdent s == ppToText mid -> do m <- [Nothing, Just $ I.sParentIdent s] return CompletionSymbol - { cmsSymbol = s - , cmsModuleName = m - , cmsImportEdits = Nothing + { symbol = s + , moduleName = m + , importEdits = Nothing } | otherwise -> do CS.ImportDecl _ mid' isQual alias spec <- imps @@ -167,9 +167,9 @@ toCompletionSymbols entry s = do m <- moduleNames return CompletionSymbol - { cmsSymbol = s - , cmsModuleName = m - , cmsImportEdits = if isImported $ I.sIdent s + { symbol = s + , moduleName = m + , importEdits = if isImported $ I.sIdent s then Nothing else case spec of Just (CS.Importing _ is) -> do @@ -187,8 +187,8 @@ toCompletionSymbols entry s = do fullName :: CompletionSymbol -> T.Text fullName cms | I.sKind s == I.Module = I.sQualIdent s | otherwise = maybe "" (<> ".") moduleName <> I.sIdent s - where s = cmsSymbol cms - moduleName = cmsModuleName cms + where s = cms.symbol + moduleName = cms.moduleName -- | The fully qualified prefix of the completion query. fullPrefix :: VFS.PosPrefixInfo -> T.Text @@ -219,8 +219,8 @@ class ToCompletionItems a where instance ToCompletionItems CompletionSymbol where -- | Converts a Curry value binding to a completion item. toCompletionItems opts query cms = [makeCompletion name ciKind detail doc insertText insertTextFormat edits] - where s = cmsSymbol cms - edits = cmsImportEdits cms + where s = cms.symbol + edits = cms.importEdits name = fromMaybe (fullName cms) $ T.stripPrefix (VFS.prefixModule query <> ".") $ fullName cms ciKind = case I.sKind s of I.ValueFunction | I.sArrowArity s == Just 0 -> J.CiConstant @@ -235,10 +235,10 @@ instance ToCompletionItems CompletionSymbol where I.TypeClass -> J.CiInterface I.TypeVar -> J.CiVariable I.Other -> J.CiText - insertText | cmoUseSnippets opts = Just $ makeSnippet name $ I.sPrintedArgumentTypes s - | otherwise = Just name - insertTextFormat | cmoUseSnippets opts = Just J.Snippet - | otherwise = Just J.PlainText + insertText | opts.useSnippets = Just $ makeSnippet name $ I.sPrintedArgumentTypes s + | otherwise = Just name + insertTextFormat | opts.useSnippets = Just J.Snippet + | otherwise = Just J.PlainText detail = I.sPrintedType s doc = Just $ T.intercalate "\n\n" $ filter (not . T.null) [ if isNothing edits then "" else "_requires import_" @@ -264,10 +264,10 @@ instance ToCompletionItems Local where detail = ppToText <$> t doc = Just "Local" argTypes = (ppToText <$>) $ CT.arrowArgs . CT.unpredType =<< maybeToList t - insertText | cmoUseSnippets opts = Just $ makeSnippet i argTypes - | otherwise = Just i - insertTextFormat | cmoUseSnippets opts = Just J.Snippet - | otherwise = Just J.PlainText + insertText | opts.useSnippets = Just $ makeSnippet i argTypes + | otherwise = Just i + insertTextFormat | opts.useSnippets = Just J.Snippet + | otherwise = Just J.PlainText edits = Nothing instance ToCompletionItems T.Text where From 399708b245e66ffb99b542c2c6b38457b6752682 Mon Sep 17 00:00:00 2001 From: fwcd Date: Fri, 26 Jul 2024 18:45:58 +0200 Subject: [PATCH 5/6] Apply hlint suggestion regarding (?~) --- src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs index f2d7088..81d260d 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs @@ -5,7 +5,7 @@ module Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) import qualified Curry.Syntax as CS import qualified Base.Types as CT -import Control.Lens ((^.), (.~)) +import Control.Lens ((^.), (?~)) import Control.Monad (join, guard) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans (lift) @@ -281,7 +281,7 @@ instance ToCompletionItems T.Text where edits = Nothing instance ToCompletionItems a => ToCompletionItems (Tagged a) where - toCompletionItems opts query (Tagged tags x) = (J.tags .~ Just (J.List tags)) <$> toCompletionItems opts query x + toCompletionItems opts query (Tagged tags x) = (J.tags ?~ J.List tags) <$> toCompletionItems opts query x -- | Creates a snippet with VSCode-style syntax. makeSnippet :: T.Text -> [T.Text] -> T.Text From d271bc397baebf6a5bc0f1e2989b6242649d788e Mon Sep 17 00:00:00 2001 From: fwcd Date: Sat, 27 Jul 2024 04:34:43 +0200 Subject: [PATCH 6/6] Migrate remaining modules to record dot syntax --- .../LanguageServer/Handlers/Diagnostics.hs | 6 +- .../Handlers/TextDocument/CodeAction.hs | 4 +- .../Handlers/TextDocument/CodeLens.hs | 4 +- .../Handlers/TextDocument/Completion.hs | 4 +- .../Handlers/TextDocument/Definition.hs | 6 +- .../Handlers/TextDocument/DocumentSymbol.hs | 4 +- .../Handlers/TextDocument/Hover.hs | 4 +- .../Handlers/TextDocument/SignatureHelp.hs | 4 +- src/Curry/LanguageServer/Index/Store.hs | 88 ++++++++++--------- 9 files changed, 64 insertions(+), 60 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/Diagnostics.hs b/src/Curry/LanguageServer/Handlers/Diagnostics.hs index d752b03..7f5abed 100644 --- a/src/Curry/LanguageServer/Handlers/Diagnostics.hs +++ b/src/Curry/LanguageServer/Handlers/Diagnostics.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Handlers.Diagnostics (emitDiagnostics, fetchDiagnostics) where import Control.Monad (unless) @@ -30,8 +30,8 @@ emitDiagnostics normUri entry = do fetchDiagnostics :: (MonadIO m, MonadLsp CFG.Config m) => J.NormalizedUri -> ModuleStoreEntry -> m [J.Diagnostic] fetchDiagnostics normUri entry = do - let warnings = map (curryMsg2Diagnostic J.DsWarning) $ mseWarningMessages entry - errors = map (curryMsg2Diagnostic J.DsError) $ mseErrorMessages entry + let warnings = map (curryMsg2Diagnostic J.DsWarning) entry.warningMessages + errors = map (curryMsg2Diagnostic J.DsError) entry.errorMessages diags = warnings ++ errors name = maybe "?" takeBaseName $ normalizedUriToFilePath normUri diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs b/src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs index 957e197..843a766 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Handlers.TextDocument.CodeAction (codeActionHandler) where -- Curry Compiler Libraries + Dependencies @@ -39,7 +39,7 @@ codeActionHandler = S.requestHandler J.STextDocumentCodeAction $ \req responder fetchCodeActions :: (MonadIO m, MonadLsp CFG.Config m) => J.Range -> I.ModuleStoreEntry -> m [J.CodeAction] fetchCodeActions range entry = do - actions <- maybe (pure []) (codeActions range) $ I.mseModuleAST entry + actions <- maybe (pure []) (codeActions range) entry.moduleAST debugM $ "Found " <> T.pack (show (length actions)) <> " code action(s)" return actions diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs b/src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs index da8d529..0674a8c 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Handlers.TextDocument.CodeLens (codeLensHandler) where -- Curry Compiler Libraries + Dependencies @@ -40,7 +40,7 @@ codeLensHandler = S.requestHandler J.STextDocumentCodeLens $ \req responder -> d fetchCodeLenses :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.CodeLens] fetchCodeLenses entry = do - lenses <- maybe (pure []) codeLenses $ I.mseModuleAST entry + lenses <- maybe (pure []) codeLenses entry.moduleAST infoM $ "Found " <> T.pack (show (length lenses)) <> " code lens(es)" return lenses diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs index 81d260d..e41cd38 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs @@ -101,7 +101,7 @@ importCompletions opts store query = do generalCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.ModuleStoreEntry -> I.IndexStore -> VFS.PosPrefixInfo -> m [J.CompletionItem] generalCompletions opts entry store query = do - let localIdentifiers = join <$> maybe M.empty (`findScopeAtPos` VFS.cursorPos query) (I.mseModuleAST entry) + let localIdentifiers = join <$> maybe M.empty (`findScopeAtPos` VFS.cursorPos query) entry.moduleAST localIdentifiers' = M.fromList $ map (first ppToText) $ M.toList localIdentifiers localCompletions = toMatchingCompletions opts query $ uncurry Local <$> M.toList localIdentifiers' symbols = filter (flip M.notMember localIdentifiers' . I.sIdent) $ nubOrdOn I.sQualIdent @@ -139,7 +139,7 @@ newtype CompletionOptions = CompletionOptions -- | Turns an index symbol into completion symbols by analyzing the module's imports. toCompletionSymbols :: I.ModuleStoreEntry -> I.Symbol -> [CompletionSymbol] toCompletionSymbols entry s = do - CS.Module _ _ _ mid _ imps _ <- maybeToList $ I.mseModuleAST entry + CS.Module _ _ _ mid _ imps _ <- maybeToList entry.moduleAST let pre = "Prelude" impNames = S.fromList [ppToText mid' | CS.ImportDecl _ mid' _ _ _ <- imps] diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs index 9348ab7..15270ba 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Handlers.TextDocument.Definition (definitionHandler) where import Control.Lens ((^.)) @@ -30,7 +30,7 @@ definitionHandler = S.requestHandler J.STextDocumentDefinition $ \req responder normUri <- normalizeUriWithPath uri store <- getStore defs <- runMaybeT $ do - lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys $ I.idxModules store)) + lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys store.modules)) entry <- I.getModule normUri lift $ fetchDefinitions store entry pos responder $ Right $ J.InR $ J.InR $ J.List $ fromMaybe [] defs @@ -38,7 +38,7 @@ definitionHandler = S.requestHandler J.STextDocumentDefinition $ \req responder fetchDefinitions :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m [J.LocationLink] fetchDefinitions store entry pos = do defs <- (fromMaybe [] <$>) $ runMaybeT $ do - ast <- liftMaybe $ I.mseModuleAST entry + ast <- liftMaybe entry.moduleAST definitions store ast pos infoM $ "Found " <> T.pack (show (length defs)) <> " definition(s)" return defs diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/DocumentSymbol.hs b/src/Curry/LanguageServer/Handlers/TextDocument/DocumentSymbol.hs index c4e5df5..45ab369 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/DocumentSymbol.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/DocumentSymbol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Handlers.TextDocument.DocumentSymbol (documentSymbolHandler) where import Control.Monad.IO.Class (MonadIO (..)) @@ -30,6 +30,6 @@ documentSymbolHandler = S.requestHandler J.STextDocumentDocumentSymbol $ \req re fetchDocumentSymbols :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.DocumentSymbol] fetchDocumentSymbols entry = do - let symbols = maybe [] documentSymbols $ I.mseModuleAST entry + let symbols = maybe [] documentSymbols entry.moduleAST debugM $ "Found document symbols " <> T.pack (show symbols) return symbols diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs index a1e7c5c..14307bb 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot, ViewPatterns #-} module Curry.LanguageServer.Handlers.TextDocument.Hover (hoverHandler) where -- Curry Compiler Libraries + Dependencies @@ -41,7 +41,7 @@ hoverHandler = S.requestHandler J.STextDocumentHover $ \req responder -> do fetchHover :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m (Maybe J.Hover) fetchHover store entry pos = runMaybeT $ do - ast <- liftMaybe $ I.mseModuleAST entry + ast <- liftMaybe entry.moduleAST hover <- liftMaybe $ qualIdentHover store ast pos <|> typedSpanInfoHover ast pos lift $ infoM $ "Found hover: " <> previewHover hover return hover diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs b/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs index 1594c45..dd75696 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, MonadComprehensions #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot, MonadComprehensions #-} module Curry.LanguageServer.Handlers.TextDocument.SignatureHelp (signatureHelpHandler) where -- Curry Compiler Libraries + Dependencies @@ -53,7 +53,7 @@ signatureHelpHandler = S.requestHandler J.STextDocumentSignatureHelp $ \req resp fetchSignatureHelp :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> VFS.VirtualFile -> J.Position -> m (Maybe J.SignatureHelp) fetchSignatureHelp store entry vfile pos@(J.Position l c) = runMaybeT $ do - ast <- liftMaybe $ I.mseModuleAST entry + ast <- liftMaybe entry.moduleAST let line = VFS.rangeLinesFromVfs vfile $ J.Range (J.Position l 0) (J.Position (l + 1) 0) c' = snapToLastTokenEnd (T.unpack line) c pos' = J.Position l c' diff --git a/src/Curry/LanguageServer/Index/Store.hs b/src/Curry/LanguageServer/Index/Store.hs index 24ecc32..af6fdc5 100644 --- a/src/Curry/LanguageServer/Index/Store.hs +++ b/src/Curry/LanguageServer/Index/Store.hs @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} module Curry.LanguageServer.Index.Store ( ModuleStoreEntry (..) , IndexStore (..) @@ -68,11 +71,11 @@ import Language.LSP.Server (MonadLsp) -- | An index store entry containing the parsed AST, the compilation environment -- and diagnostic messages. -data ModuleStoreEntry = ModuleStoreEntry { mseModuleAST :: Maybe ModuleAST - , mseErrorMessages :: [CM.Message] - , mseWarningMessages :: [CM.Message] - , mseProjectDir :: Maybe FilePath - , mseImportPaths :: [FilePath] +data ModuleStoreEntry = ModuleStoreEntry { moduleAST :: Maybe ModuleAST + , errorMessages :: [CM.Message] + , warningMessages :: [CM.Message] + , projectDir :: Maybe FilePath + , importPaths :: [FilePath] } @@ -81,35 +84,35 @@ data ModuleStoreEntry = ModuleStoreEntry { mseModuleAST :: Maybe ModuleAST -- unqualified symbol names to actual symbols/symbol information. -- Since (unqualified) symbol names can be ambiguous, a trie leaf -- holds a list of symbol entries rather than just a single one. -data IndexStore = IndexStore { idxModules :: M.Map J.NormalizedUri ModuleStoreEntry +data IndexStore = IndexStore { modules :: M.Map J.NormalizedUri ModuleStoreEntry -- Symbols keyed by unqualified name - , idxSymbols :: TR.Trie [Symbol] + , symbols :: TR.Trie [Symbol] -- Module symbols keyed by qualified name - , idxModuleSymbols :: TR.Trie [Symbol] + , moduleSymbols :: TR.Trie [Symbol] } instance Default ModuleStoreEntry where - def = ModuleStoreEntry { mseModuleAST = Nothing - , mseWarningMessages = [] - , mseErrorMessages = [] - , mseProjectDir = Nothing - , mseImportPaths = [] + def = ModuleStoreEntry { moduleAST = Nothing + , warningMessages = [] + , errorMessages = [] + , projectDir = Nothing + , importPaths = [] } instance Default IndexStore where - def = IndexStore { idxModules = M.empty, idxSymbols = TR.empty, idxModuleSymbols = TR.empty } + def = IndexStore { modules = M.empty, symbols = TR.empty, moduleSymbols = TR.empty } -- | Fetches the number of stored modules. storedModuleCount :: IndexStore -> Int -storedModuleCount = M.size . idxModules +storedModuleCount = M.size . (.modules) -- | Fetches the number of stored symbols. storedSymbolCount :: IndexStore -> Int -storedSymbolCount = TR.size . idxSymbols +storedSymbolCount = TR.size . (.symbols) -- | Fetches the given entry in the store. storedModule :: J.NormalizedUri -> IndexStore -> Maybe ModuleStoreEntry -storedModule uri = M.lookup uri . idxModules +storedModule uri = M.lookup uri . (.modules) -- | Fetches an entry in the store by module identifier. storedModuleByIdent :: CI.ModuleIdent -> IndexStore -> IO (Maybe ModuleStoreEntry) @@ -119,19 +122,19 @@ storedModuleByIdent mident store = flip storedModule store <$> uri -- | Fetches the entries in the store as a list. storedModules :: IndexStore -> [(J.NormalizedUri, ModuleStoreEntry)] -storedModules = M.toList . idxModules +storedModules = M.toList . (.modules) -- | Fetches all symbols. storedSymbols :: IndexStore -> [Symbol] -storedSymbols = join . TR.toListBy (const id) . idxSymbols +storedSymbols = join . TR.toListBy (const id) . (.symbols) -- | Fetches the given (unqualified) symbol names in the store. storedSymbolsByKey :: T.Text -> IndexStore -> [Symbol] -storedSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . idxSymbols +storedSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . (.symbols) -- | Fetches the list of symbols starting with the given prefix. storedSymbolsWithPrefix :: T.Text -> IndexStore -> [Symbol] -storedSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . idxSymbols +storedSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . (.symbols) -- | Fetches stored symbols by qualified identifier. storedSymbolsByQualIdent :: CI.QualIdent -> IndexStore -> [Symbol] @@ -140,7 +143,7 @@ storedSymbolsByQualIdent q = filter ((== ppToText q) . sQualIdent) . storedSymbo -- | Fetches the given (qualified) module symbol names in the store. storedModuleSymbolsByKey :: T.Text -> IndexStore -> [Symbol] -storedModuleSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . idxModuleSymbols +storedModuleSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . (.moduleSymbols) -- | Fetches stored symbols by qualified identifier. storedModuleSymbolsByModuleIdent :: CI.ModuleIdent -> IndexStore -> [Symbol] @@ -148,14 +151,14 @@ storedModuleSymbolsByModuleIdent = storedModuleSymbolsByKey . ppToText -- | Fetches stored module symbols starting with the given prefix. storedModuleSymbolsWithPrefix :: T.Text -> IndexStore -> [Symbol] -storedModuleSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . idxModuleSymbols +storedModuleSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . (.moduleSymbols) -- | Compiles the given directory recursively and stores its entries. addWorkspaceDir :: (MonadState IndexStore m, MonadIO m, MonadLsp CFG.Config m, MonadCatch m) => CFG.Config -> C.FileLoader -> FilePath -> m () addWorkspaceDir cfg fl dirPath = void $ runMaybeT $ do files <- lift $ findCurrySourcesInWorkspace cfg dirPath lift $ do - mapM_ (\(i, file) -> recompileFile i (length files) cfg fl (csfImportPaths file) (Just (csfProjectDir file)) (csfPath file)) (zip [1..] files) + mapM_ (\(i, file) -> recompileFile i (length files) cfg fl file.importPaths (Just file.projectDir) file.path) (zip [1..] files) infoM $ "Added workspace directory " <> T.pack dirPath -- | Recompiles the module entry with the given URI and stores the output. @@ -166,9 +169,9 @@ recompileModule cfg fl uri = void $ runMaybeT $ do recompileFile 1 1 cfg fl [] Nothing filePath debugM $ "Recompiled entry " <> T.pack (show uri) -data CurrySourceFile = CurrySourceFile { csfProjectDir :: FilePath - , csfImportPaths :: [FilePath] - , csfPath :: FilePath +data CurrySourceFile = CurrySourceFile { projectDir :: FilePath + , importPaths :: [FilePath] + , path :: FilePath } -- | Finds the Curry source files along with its import paths in a workspace. Recognizes CPM projects. @@ -180,7 +183,7 @@ findCurrySourcesInWorkspace cfg dirPath = do pathsJsonProjPaths <- walkCurryProjects [".curry", "language-server", "paths.json"] dirPath -- If nothing is found, default to the workspace directory let projPaths = fromMaybe [dirPath] $ nothingIfNull $ nubOrd $ cpmProjPaths ++ pathsJsonProjPaths - nubOrdOn csfPath <$> join <$> mapM (findCurrySourcesInProject cfg) projPaths + nubOrdOn (.path) . join <$> mapM (findCurrySourcesInProject cfg) projPaths -- | Finds the Curry source files in a (project) directory. findCurrySourcesInProject :: (MonadIO m, MonadLsp CFG.Config m) => CFG.Config -> FilePath -> m [CurrySourceFile] @@ -267,11 +270,12 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do infoM $ "[" <> T.pack (show i) <> " of " <> T.pack (show total) <> "] (Re)compiling file " <> T.pack (takeFileName filePath) uri <- filePathToNormalizedUri filePath - ms <- gets idxModules + ms <- gets (.modules) - let defEntry = def { mseProjectDir = dirPath, mseImportPaths = importPaths } + -- Regarding the ambiguous-fields warning, perhaps this is https://gitlab.haskell.org/ghc/ghc/-/issues/21443 ? + let defEntry = (def { projectDir = dirPath, importPaths = importPaths }) :: ModuleStoreEntry outDirPath = CFN.defaultOutDir "language-server" - importPaths' = outDirPath : mseImportPaths (M.findWithDefault defEntry uri ms) + importPaths' = outDirPath : (M.findWithDefault defEntry uri ms).importPaths aux = C.CompileAuxiliary { C.fileLoader = fl } (co, cs) <- catch @@ -297,12 +301,12 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do forM_ asts $ \(uri', (env, ast)) -> do -- Update module store let updateEntry e = e - { mseWarningMessages = M.findWithDefault [] uri' warns - , mseErrorMessages = M.findWithDefault [] uri' errors - , mseModuleAST = Just ast + { warningMessages = M.findWithDefault [] uri' warns + , errorMessages = M.findWithDefault [] uri' errors + , moduleAST = Just ast -- , mseCompilerEnv = Just env } - modify $ \s -> s { idxModules = modifyEntry updateEntry uri' $ idxModules s } + modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } -- Update symbol store valueSymbols <- join <$> mapM toSymbols (CT.allBindings $ CE.valueEnv env) @@ -312,8 +316,8 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do let symbolDelta = valueSymbols ++ typeSymbols ++ modSymbols combiner = unionBy ((==) `on` (\s' -> (sKind s', sQualIdent s', sIsFromCurrySource s'))) modify $ \s -> s - { idxSymbols = insertAllIntoTrieWith combiner ((\s' -> (TE.encodeUtf8 $ sIdent s', [s'])) <$> symbolDelta) $ idxSymbols s - , idxModuleSymbols = insertAllIntoTrieWith (unionBy ((==) `on` sQualIdent)) ((\s' -> (TE.encodeUtf8 $ sQualIdent s', [s'])) <$> modSymbols) $ idxModuleSymbols s + { symbols = insertAllIntoTrieWith combiner ((\s' -> (TE.encodeUtf8 $ sIdent s', [s'])) <$> symbolDelta) s.symbols + , moduleSymbols = insertAllIntoTrieWith (unionBy ((==) `on` sQualIdent)) ((\s' -> (TE.encodeUtf8 $ sQualIdent s', [s'])) <$> modSymbols) s.moduleSymbols } -- Update store with messages from files that were not successfully compiled @@ -322,12 +326,12 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do other = filter ((`S.notMember` uris) . fst) . M.toList forM_ (other warns) $ \(uri', msgs) -> do - let updateEntry e = e { mseWarningMessages = msgs } - modify $ \s -> s { idxModules = modifyEntry updateEntry uri' $ idxModules s } + let updateEntry e = e { warningMessages = msgs } + modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } forM_ (other errors) $ \(uri', msgs) -> do - let updateEntry e = e { mseErrorMessages = msgs } - modify $ \s -> s { idxModules = modifyEntry updateEntry uri' $ idxModules s } + let updateEntry e = e { errorMessages = msgs } + modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } -- | Fetches the number of module entries in the store in a monadic way. getModuleCount :: (MonadState IndexStore m) => m Int @@ -343,4 +347,4 @@ getModuleList = gets storedModules -- | Fetches the AST for a given URI in the store in a monadic way. getModuleAST :: (MonadState IndexStore m) => J.NormalizedUri -> MaybeT m ModuleAST -getModuleAST uri = (liftMaybe . mseModuleAST) =<< getModule uri +getModuleAST uri = (liftMaybe . (.moduleAST)) =<< getModule uri