From f265e938a6fd338bbf516ff17bae747433bb057f Mon Sep 17 00:00:00 2001 From: fwcd Date: Tue, 6 Aug 2024 16:54:24 +0200 Subject: [PATCH 1/3] Migrate Symbol to record dot syntax --- .../Handlers/TextDocument/Completion.hs | 56 +++++++++---------- .../Handlers/TextDocument/Definition.hs | 2 +- .../Handlers/TextDocument/Hover.hs | 2 +- .../Handlers/TextDocument/SignatureHelp.hs | 8 +-- .../Handlers/Workspace/Symbol.hs | 34 +++++------ src/Curry/LanguageServer/Index/Convert.hs | 42 +++++++------- src/Curry/LanguageServer/Index/Resolve.hs | 4 +- src/Curry/LanguageServer/Index/Store.hs | 8 +-- src/Curry/LanguageServer/Index/Symbol.hs | 50 ++++++++--------- 9 files changed, 103 insertions(+), 103 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs index e41cd38..c11a7e6 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs @@ -92,7 +92,7 @@ pragmaCompletions opts query importCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.IndexStore -> VFS.PosPrefixInfo -> m [J.CompletionItem] importCompletions opts store query = do - let modules = nubOrdOn I.sQualIdent $ I.storedModuleSymbolsWithPrefix (fullPrefix query) store + let modules = nubOrdOn (.qualIdent) $ I.storedModuleSymbolsWithPrefix (fullPrefix query) store moduleCompletions = toMatchingCompletions opts query $ (\s -> CompletionSymbol s Nothing Nothing) <$> modules keywordCompletions = toMatchingCompletions opts query $ Keyword <$> ["qualified", "as", "hiding"] completions = moduleCompletions ++ keywordCompletions @@ -104,8 +104,8 @@ generalCompletions opts entry store query = do 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 - $ I.storedSymbolsWithPrefix (VFS.prefixText query) store + symbols = filter (flip M.notMember localIdentifiers' . (.ident)) $ nubOrdOn (.qualIdent) + $ I.storedSymbolsWithPrefix (VFS.prefixText query) store symbolCompletions = toMatchingCompletions opts query $ toCompletionSymbols entry =<< symbols keywordCompletions = toMatchingCompletions opts query keywords completions = localCompletions ++ symbolCompletions ++ keywordCompletions @@ -143,13 +143,13 @@ toCompletionSymbols entry s = do let pre = "Prelude" impNames = S.fromList [ppToText mid' | CS.ImportDecl _ mid' _ _ _ <- imps] - if | I.sKind s == I.Module -> return CompletionSymbol + if | s.kind == I.Module -> return CompletionSymbol { 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] + | (I.symbolParentIdent s == pre && pre `S.notMember` impNames) || I.symbolParentIdent s == ppToText mid -> do + m <- [Nothing, Just $ I.symbolParentIdent s] return CompletionSymbol { symbol = s , moduleName = m @@ -157,7 +157,7 @@ toCompletionSymbols entry s = do } | otherwise -> do CS.ImportDecl _ mid' isQual alias spec <- imps - guard $ ppToText mid' == I.sParentIdent s + guard $ ppToText mid' == I.symbolParentIdent s let isImported = case spec of Just (CS.Importing _ is) -> flip S.member $ S.fromList $ ppToText <$> (identifiers =<< is) @@ -169,14 +169,14 @@ toCompletionSymbols entry s = do return CompletionSymbol { symbol = s , moduleName = m - , importEdits = if isImported $ I.sIdent s + , importEdits = if isImported s.ident then Nothing else case spec of Just (CS.Importing _ is) -> do J.Range _ pos <- currySpanInfo2Range =<< lastSafe is let range = J.Range pos pos - text | null is = I.sIdent s - | otherwise = ", " <> I.sIdent s + text | null is = s.ident + | otherwise = ", " <> s.ident edit = J.TextEdit range text return [edit] _ -> return [] @@ -185,8 +185,8 @@ toCompletionSymbols entry s = do -- | The fully qualified, possibly aliased, name of the completion symbol. fullName :: CompletionSymbol -> T.Text -fullName cms | I.sKind s == I.Module = I.sQualIdent s - | otherwise = maybe "" (<> ".") moduleName <> I.sIdent s +fullName cms | s.kind == I.Module = s.qualIdent + | otherwise = maybe "" (<> ".") moduleName <> s.ident where s = cms.symbol moduleName = cms.moduleName @@ -222,27 +222,27 @@ instance ToCompletionItems CompletionSymbol where 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 - | otherwise -> J.CiFunction - I.ValueConstructor | I.sArrowArity s == Just 0 -> J.CiEnumMember - | otherwise -> J.CiConstructor - I.Module -> J.CiModule - I.TypeData | length (I.sConstructors s) == 1 -> J.CiStruct - | otherwise -> J.CiEnum - I.TypeNew -> J.CiStruct - I.TypeAlias -> J.CiInterface - I.TypeClass -> J.CiInterface - I.TypeVar -> J.CiVariable - I.Other -> J.CiText - insertText | opts.useSnippets = Just $ makeSnippet name $ I.sPrintedArgumentTypes s + ciKind = case s.kind of + I.ValueFunction | s.arrowArity == Just 0 -> J.CiConstant + | otherwise -> J.CiFunction + I.ValueConstructor | s.arrowArity == Just 0 -> J.CiEnumMember + | otherwise -> J.CiConstructor + I.Module -> J.CiModule + I.TypeData | length s.constructors == 1 -> J.CiStruct + | otherwise -> J.CiEnum + I.TypeNew -> J.CiStruct + I.TypeAlias -> J.CiInterface + I.TypeClass -> J.CiInterface + I.TypeVar -> J.CiVariable + I.Other -> J.CiText + insertText | opts.useSnippets = Just $ makeSnippet name s.printedArgumentTypes | otherwise = Just name insertTextFormat | opts.useSnippets = Just J.Snippet | otherwise = Just J.PlainText - detail = I.sPrintedType s + detail = s.printedType doc = Just $ T.intercalate "\n\n" $ filter (not . T.null) [ if isNothing edits then "" else "_requires import_" - , T.intercalate ", " $ I.sConstructors s + , T.intercalate ", " s.constructors ] instance ToCompletionItems Keyword where diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs index 15270ba..c9350b2 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs @@ -47,5 +47,5 @@ definitions :: MonadIO m => I.IndexStore -> ModuleAST -> J.Position -> MaybeT m definitions store ast pos = do -- Look up identifier under cursor (symbols, srcRange) <- liftMaybe $ resolveAtPos store ast pos - let locations = mapMaybe I.sLocation symbols + let locations = mapMaybe (.location) symbols return [J.LocationLink (Just srcRange) destUri destRange destRange | J.Location destUri destRange <- locations] diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs index 14307bb..aa44078 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs @@ -51,7 +51,7 @@ qualIdentHover store ast pos = do (symbols, range) <- resolveAtPos store ast pos s <- listToMaybe symbols - let contents = J.HoverContents $ J.markedUpContent "curry" $ I.sQualIdent s <> maybe "" (" :: " <>) (I.sPrintedType s) + let contents = J.HoverContents $ J.markedUpContent "curry" $ s.qualIdent <> maybe "" (" :: " <>) s.printedType return $ J.Hover contents $ Just range diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs b/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs index dd75696..8d97fb1 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs @@ -60,18 +60,18 @@ fetchSignatureHelp store entry vfile pos@(J.Position l c) = runMaybeT $ do (sym, spi, args) <- liftMaybe $ findExpressionApplication store ast pos' <|> findTypeApplication store ast pos' - lift $ infoM $ "Found symbol " <> I.sQualIdent sym + lift $ infoM $ "Found symbol " <> sym.qualIdent symEnd <- liftMaybe [end | J.Range _ end <- currySpanInfo2Range spi] let defaultParam | pos >= symEnd = fromIntegral $ length args | otherwise = 0 activeParam = maybe defaultParam fst $ find (elementContains pos . snd) (zip [0..] args) activeSig = 0 - labelStart = I.sQualIdent sym <> " :: " + labelStart = sym.qualIdent <> " :: " paramSep = " -> " - paramLabels = I.sPrintedArgumentTypes sym + paramLabels = sym.printedArgumentTypes paramOffsets = reverse $ snd $ foldl (\(n, offs) lbl -> let n' = n + T.length lbl in (n' + T.length paramSep, (n, n') : offs)) (T.length labelStart, []) paramLabels params = flip J.ParameterInformation Nothing . uncurry J.ParameterLabelOffset . bimap fromIntegral fromIntegral <$> paramOffsets - label = labelStart <> T.intercalate paramSep (paramLabels ++ maybeToList (I.sPrintedResultType sym)) + label = labelStart <> T.intercalate paramSep (paramLabels ++ maybeToList sym.printedResultType) sig = J.SignatureInformation label Nothing (Just $ J.List params) (Just activeParam) sigs = [sig] return $ J.SignatureHelp (J.List sigs) (Just activeSig) (Just activeParam) diff --git a/src/Curry/LanguageServer/Handlers/Workspace/Symbol.hs b/src/Curry/LanguageServer/Handlers/Workspace/Symbol.hs index 9109f6f..4f07ea4 100644 --- a/src/Curry/LanguageServer/Handlers/Workspace/Symbol.hs +++ b/src/Curry/LanguageServer/Handlers/Workspace/Symbol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} module Curry.LanguageServer.Handlers.Workspace.Symbol (workspaceSymbolHandler) where import Control.Lens ((^.)) @@ -32,21 +32,21 @@ fetchWorkspaceSymbols store query = do return symbols toWorkspaceSymbol :: I.Symbol -> Maybe J.SymbolInformation -toWorkspaceSymbol s = (\loc -> J.SymbolInformation name kind tags deprecated loc containerName) <$> I.sLocation s - where name = I.sIdent s - kind = case I.sKind s of - I.ValueFunction | I.sArrowArity s == Just 0 -> J.SkConstant - | otherwise -> J.SkFunction - I.ValueConstructor | I.sArrowArity s == Just 0 -> J.SkEnumMember - | otherwise -> J.SkConstructor - I.Module -> J.SkModule - I.TypeData | length (I.sConstructors s) == 1 -> J.SkStruct - | otherwise -> J.SkEnum - I.TypeNew -> J.SkStruct - I.TypeAlias -> J.SkInterface - I.TypeClass -> J.SkInterface - I.TypeVar -> J.SkVariable - I.Other -> J.SkNamespace +toWorkspaceSymbol s = (\loc -> J.SymbolInformation name kind tags deprecated loc containerName) <$> s.location + where name = s.ident + kind = case s.kind of + I.ValueFunction | s.arrowArity == Just 0 -> J.SkConstant + | otherwise -> J.SkFunction + I.ValueConstructor | s.arrowArity == Just 0 -> J.SkEnumMember + | otherwise -> J.SkConstructor + I.Module -> J.SkModule + I.TypeData | length s.constructors == 1 -> J.SkStruct + | otherwise -> J.SkEnum + I.TypeNew -> J.SkStruct + I.TypeAlias -> J.SkInterface + I.TypeClass -> J.SkInterface + I.TypeVar -> J.SkVariable + I.Other -> J.SkNamespace tags = Nothing deprecated = Nothing - containerName = Just $ I.sParentIdent s + containerName = Just $ I.symbolParentIdent s diff --git a/src/Curry/LanguageServer/Index/Convert.hs b/src/Curry/LanguageServer/Index/Convert.hs index 0d225d9..b33b6e0 100644 --- a/src/Curry/LanguageServer/Index/Convert.hs +++ b/src/Curry/LanguageServer/Index/Convert.hs @@ -30,7 +30,7 @@ class ToSymbols s where instance ToSymbols (CI.QualIdent, CEV.ValueInfo) where toSymbols (q, vinfo) | CI.isQualified q' = pure <$> case vinfo of - CEV.DataConstructor _ _ ls t -> (\s -> s { sConstructors = ppToText <$> ls }) + CEV.DataConstructor _ _ ls t -> (\s -> s { constructors = ppToText <$> ls }) <$> makeValueSymbol ValueConstructor q' t CEV.NewtypeConstructor _ _ t -> makeValueSymbol ValueConstructor q' t CEV.Value _ _ _ t -> makeValueSymbol ValueFunction q' t @@ -55,10 +55,10 @@ instance ToSymbols CI.ModuleIdent where return $ do quals <- tail $ inits $ T.pack <$> CI.midQualifiers mid return def - { sKind = Module - , sQualIdent = T.intercalate "." quals - , sIdent = fromMaybe "" $ lastSafe quals - , sLocation = loc + { kind = Module + , qualIdent = T.intercalate "." quals + , ident = fromMaybe "" $ lastSafe quals + , location = loc } qualifyWithModuleFrom :: CTE.Entity a => a -> CI.QualIdent -> CI.QualIdent @@ -68,32 +68,32 @@ makeValueSymbol :: MonadIO m => SymbolKind -> CI.QualIdent -> CT.TypeScheme -> m makeValueSymbol k q t = do loc <- runMaybeT $ currySpanInfo2Location $ CI.qidIdent q return def - { sKind = k - , sQualIdent = ppToText q - , sIdent = ppToText $ CI.qidIdent q - , sPrintedType = Just $ ppToText t + { kind = k + , qualIdent = ppToText q + , ident = ppToText $ CI.qidIdent q + , printedType = Just $ ppToText t -- We explicitly perform the Type -> TypeExpr conversion here since -- the Pretty Type instance ignores the precedence. - , sPrintedArgumentTypes = ppToTextPrec 2 . CTS.fromType CI.identSupply <$> CT.arrowArgs (CT.rawType t) - , sPrintedResultType = Just $ ppToText $ CT.arrowBase (CT.rawType t) - , sArrowArity = Just $ CT.arrowArity $ CT.rawType t - , sLocation = loc + , printedArgumentTypes = ppToTextPrec 2 . CTS.fromType CI.identSupply <$> CT.arrowArgs (CT.rawType t) + , printedResultType = Just $ ppToText $ CT.arrowBase (CT.rawType t) + , arrowArity = Just $ CT.arrowArity $ CT.rawType t + , location = loc } makeTypeSymbol :: MonadIO m => SymbolKind -> CI.QualIdent -> CK.Kind -> m Symbol makeTypeSymbol k q k' = do loc <- runMaybeT $ currySpanInfo2Location $ CI.qidIdent q return def - { sKind = k - , sQualIdent = ppToText q - , sIdent = ppToText $ CI.qidIdent q - , sPrintedType = Just $ ppToText k' + { kind = k + , qualIdent = ppToText q + , ident = ppToText $ CI.qidIdent q + , printedType = Just $ ppToText k' -- We explicitly perform the Kind conversion here since -- the Pretty Kind instance ignores the precedence. - , sPrintedArgumentTypes = ppToTextPrec 2 . CKS.fromKind <$> CK.kindArgs k' - , sPrintedResultType = Just $ ppToText $ kindBase k' - , sArrowArity = Just $ CK.kindArity k' - , sLocation = loc + , printedArgumentTypes = ppToTextPrec 2 . CKS.fromKind <$> CK.kindArgs k' + , printedResultType = Just $ ppToText $ kindBase k' + , arrowArity = Just $ CK.kindArity k' + , location = loc } where kindBase (CK.KindArrow _ k'') = kindBase k'' kindBase k'' = k'' diff --git a/src/Curry/LanguageServer/Index/Resolve.hs b/src/Curry/LanguageServer/Index/Resolve.hs index 138c86a..126043c 100644 --- a/src/Curry/LanguageServer/Index/Resolve.hs +++ b/src/Curry/LanguageServer/Index/Resolve.hs @@ -51,5 +51,5 @@ resolveModuleIdent store mid = tryFilterFromCurrySource $ I.storedModuleSymbolsB -- | Tries filtering symbols from a Curry source file. tryFilterFromCurrySource :: [I.Symbol] -> [I.Symbol] -tryFilterFromCurrySource symbols | any I.sIsFromCurrySource symbols = filter I.sIsFromCurrySource symbols - | otherwise = symbols +tryFilterFromCurrySource symbols | any I.symbolIsFromCurrySource symbols = filter I.symbolIsFromCurrySource symbols + | otherwise = symbols diff --git a/src/Curry/LanguageServer/Index/Store.hs b/src/Curry/LanguageServer/Index/Store.hs index af6fdc5..3cf7014 100644 --- a/src/Curry/LanguageServer/Index/Store.hs +++ b/src/Curry/LanguageServer/Index/Store.hs @@ -138,7 +138,7 @@ storedSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . -- | Fetches stored symbols by qualified identifier. storedSymbolsByQualIdent :: CI.QualIdent -> IndexStore -> [Symbol] -storedSymbolsByQualIdent q = filter ((== ppToText q) . sQualIdent) . storedSymbolsByKey name +storedSymbolsByQualIdent q = filter ((== ppToText q) . (.qualIdent)) . storedSymbolsByKey name where name = T.pack $ CI.idName $ CI.qidIdent q -- | Fetches the given (qualified) module symbol names in the store. @@ -314,10 +314,10 @@ recompileFile i total cfg fl importPaths dirPath filePath = void $ do modSymbols <- toSymbols (moduleIdentifier ast) let symbolDelta = valueSymbols ++ typeSymbols ++ modSymbols - combiner = unionBy ((==) `on` (\s' -> (sKind s', sQualIdent s', sIsFromCurrySource s'))) + combiner = unionBy ((==) `on` (\s' -> (s'.kind, s'.qualIdent, symbolIsFromCurrySource s'))) modify $ \s -> 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 + { symbols = insertAllIntoTrieWith combiner ((\s' -> (TE.encodeUtf8 s'.ident, [s'])) <$> symbolDelta) s.symbols + , moduleSymbols = insertAllIntoTrieWith (unionBy ((==) `on` (.qualIdent))) ((\s' -> (TE.encodeUtf8 s'.qualIdent, [s'])) <$> modSymbols) s.moduleSymbols } -- Update store with messages from files that were not successfully compiled diff --git a/src/Curry/LanguageServer/Index/Symbol.hs b/src/Curry/LanguageServer/Index/Symbol.hs index 1e66d61..4756c6b 100644 --- a/src/Curry/LanguageServer/Index/Symbol.hs +++ b/src/Curry/LanguageServer/Index/Symbol.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot #-} module Curry.LanguageServer.Index.Symbol ( SymbolKind (..) , Symbol (..) - , sParentIdent - , sIsFromCurrySource + , symbolParentIdent + , symbolIsFromCurrySource ) where import Control.Lens ((^.)) @@ -27,33 +27,33 @@ data SymbolKind = ValueFunction -- | A module, type or value. If it's a type, the 'printed type' will be the printed kind. data Symbol = Symbol - { sKind :: SymbolKind - , sQualIdent :: T.Text - , sIdent :: T.Text - , sPrintedType :: Maybe T.Text - , sPrintedArgumentTypes :: [T.Text] - , sPrintedResultType :: Maybe T.Text - , sArrowArity :: Maybe Int - , sConstructors :: [T.Text] - , sLocation :: Maybe J.Location + { kind :: SymbolKind + , qualIdent :: T.Text + , ident :: T.Text + , printedType :: Maybe T.Text + , printedArgumentTypes :: [T.Text] + , printedResultType :: Maybe T.Text + , arrowArity :: Maybe Int + , constructors :: [T.Text] + , location :: Maybe J.Location } deriving (Show, Eq) instance Default Symbol where def = Symbol - { sKind = Other - , sQualIdent = "" - , sIdent = "" - , sPrintedType = Nothing - , sPrintedArgumentTypes = [] - , sPrintedResultType = Nothing - , sArrowArity = Nothing - , sConstructors = [] - , sLocation = Nothing + { kind = Other + , qualIdent = "" + , ident = "" + , printedType = Nothing + , printedArgumentTypes = [] + , printedResultType = Nothing + , arrowArity = Nothing + , constructors = [] + , location = Nothing } -sParentIdent :: Symbol -> T.Text -sParentIdent s = fromMaybe "" $ T.stripSuffix ("." <> sIdent s) $ sQualIdent s +symbolParentIdent :: Symbol -> T.Text +symbolParentIdent s = fromMaybe "" $ T.stripSuffix ("." <> s.ident) s.qualIdent -sIsFromCurrySource :: Symbol -> Bool -sIsFromCurrySource s = maybe False ((".curry" `T.isSuffixOf`) . J.getUri . (^. J.uri)) $ sLocation s +symbolIsFromCurrySource :: Symbol -> Bool +symbolIsFromCurrySource s = maybe False ((".curry" `T.isSuffixOf`) . J.getUri . (^. J.uri)) s.location From 3976f542ef0a89e8f4aebff7aecbd5ca3a99acf7 Mon Sep 17 00:00:00 2001 From: fwcd Date: Tue, 6 Aug 2024 16:56:18 +0200 Subject: [PATCH 2/3] Migrate WalkConfiguration to record dot syntax --- src/Curry/LanguageServer/Index/Store.hs | 8 +++---- src/Curry/LanguageServer/Utils/General.hs | 28 +++++++++++------------ 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Curry/LanguageServer/Index/Store.hs b/src/Curry/LanguageServer/Index/Store.hs index 3cf7014..73a6a61 100644 --- a/src/Curry/LanguageServer/Index/Store.hs +++ b/src/Curry/LanguageServer/Index/Store.hs @@ -241,13 +241,13 @@ walkCurrySourceFiles = (filter ((== ".curry") . takeExtension) <$>) . walkIgnori -- to aggregate the state across recursive calls, perhaps by requiring a Monoid instance?) walkIgnoringHidden :: (MonadIO m, MonadLsp CFG.Config m) => FilePath -> m [FilePath] walkIgnoringHidden = walkFilesWith WalkConfiguration - { wcOnEnter = \fp -> do + { onEnter = \fp -> do ignorePaths <- filterM (liftIO . doesFileExist) $ (fp ) <$> [".curry-language-server-ignore", ".gitignore"] ignored <- join <$> mapM readIgnoreFile ignorePaths unless (null ignored) $ infoM $ "In '" <> T.pack (takeFileName fp) <> "' ignoring " <> T.pack (show (G.decompile <$> ignored)) return $ Just ignored - , wcShouldIgnore = \ignored fp -> do + , shouldIgnore = \ignored fp -> do isDir <- liftIO $ doesDirectoryExist fp let fn = takeFileName fp matchesFn pat = any (G.match pat) $ catMaybes [Just fn, if isDir then Just (fn ++ "/") else Nothing] @@ -255,8 +255,8 @@ walkIgnoringHidden = walkFilesWith WalkConfiguration unless (null matchingIgnores) $ debugM $ "Ignoring '" <> T.pack fn <> "' since it matches " <> T.pack (show (G.decompile <$> matchingIgnores)) return $ not (null matchingIgnores) || "." `isPrefixOf` fn - , wcIncludeDirectories = True - , wcIncludeFiles = True + , includeDirectories = True + , includeFiles = True } -- | Reads the given ignore file, fetching the ignored (relative) paths. diff --git a/src/Curry/LanguageServer/Utils/General.hs b/src/Curry/LanguageServer/Utils/General.hs index 7cfe66a..273c6d8 100644 --- a/src/Curry/LanguageServer/Utils/General.hs +++ b/src/Curry/LanguageServer/Utils/General.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, MultiWayIf, NoFieldSelectors, OverloadedRecordDot #-} -- | General utilities. module Curry.LanguageServer.Utils.General ( lastSafe @@ -132,22 +132,22 @@ data WalkConfiguration m a = WalkConfiguration { -- | Executed when entering a new directory. Fetches some directory-specific -- state for later use during filtering, e.g. an ignore file. Returning -- Nothing causes the walker to skip the the directory. - wcOnEnter :: FilePath -> m (Maybe a) + onEnter :: FilePath -> m (Maybe a) -- | Tests whether a file or directory should be ignored using the state of -- the directory containing the path. - , wcShouldIgnore :: a -> FilePath -> m Bool + , shouldIgnore :: a -> FilePath -> m Bool -- | Whether the walk should include directories. - , wcIncludeDirectories :: Bool + , includeDirectories :: Bool -- | Whether the walk should include files. - , wcIncludeFiles :: Bool + , includeFiles :: Bool } instance (Default a, Monad m) => Default (WalkConfiguration m a) where def = WalkConfiguration - { wcOnEnter = const $ return $ Just def - , wcShouldIgnore = const $ const $ return False - , wcIncludeDirectories = False - , wcIncludeFiles = True + { onEnter = const $ return $ Just def + , shouldIgnore = const $ const $ return False + , includeDirectories = False + , includeFiles = True } -- | An empty walk configuration. @@ -161,7 +161,7 @@ walkFiles = walkFilesWith emptyWalkConfiguration -- | Lists files in the directory recursively, ignoring files matching the given predicate. walkFilesIgnoring :: MonadIO m => (FilePath -> Bool) -> FilePath -> m [FilePath] walkFilesIgnoring ignore = walkFilesWith emptyWalkConfiguration - { wcShouldIgnore = const $ return . ignore + { shouldIgnore = const $ return . ignore } -- | Lists files in the directory recursively with the given configuration. @@ -170,11 +170,11 @@ walkFilesWith wc fp = (fromMaybe [] <$>) $ runMaybeT $ do isDirectory <- liftIO $ unsafeInterleaveIO $ doesDirectoryExist fp isFile <- liftIO $ unsafeInterleaveIO $ doesFileExist fp if | isDirectory -> do - state <- MaybeT $ wcOnEnter wc fp + state <- MaybeT $ wc.onEnter fp contents <- liftIO $ listDirectory fp - contents' <- map (fp ) <$> filterM ((not <$>) . lift . wcShouldIgnore wc state) contents - ([fp | wcIncludeDirectories wc] ++) . join <$> mapM (lift . walkFilesWith wc) contents' - | isFile -> return [fp | wcIncludeFiles wc] + contents' <- map (fp ) <$> filterM ((not <$>) . lift . wc.shouldIgnore state) contents + ([fp | wc.includeDirectories] ++) . join <$> mapM (lift . walkFilesWith wc) contents' + | isFile -> return [fp | wc.includeFiles] | otherwise -> liftMaybe Nothing -- | Lifts a Maybe into a Maybe transformer. From c130887ebb707afe1450578449f56dfef975ed84 Mon Sep 17 00:00:00 2001 From: fwcd Date: Tue, 6 Aug 2024 16:58:10 +0200 Subject: [PATCH 3/3] Migrate ScopeState to record dot syntax --- src/Curry/LanguageServer/Utils/Lookup.hs | 26 ++++++++++++------------ 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Curry/LanguageServer/Utils/Lookup.hs b/src/Curry/LanguageServer/Utils/Lookup.hs index fdc6893..c69f29a 100644 --- a/src/Curry/LanguageServer/Utils/Lookup.hs +++ b/src/Curry/LanguageServer/Utils/Lookup.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, ViewPatterns #-} -- | Position lookup in the AST. module Curry.LanguageServer.Utils.Lookup ( findQualIdentAtPos @@ -50,10 +50,10 @@ findTypeAtPos ast pos = elementAt pos $ typedSpanInfos ast -- | Finds all accessible identifiers at the given position, using the innermost shadowed one. findScopeAtPos :: CS.Module a -> J.Position -> Scope a -findScopeAtPos ast pos = sstMatchingEnv $ execState (collectScope ast) $ ScopeState - { sstCurrentEnv = [M.empty] - , sstMatchingEnv = M.empty - , sstPosition = pos +findScopeAtPos ast pos = (.matchingEnv) $ execState (collectScope ast) $ ScopeState + { currentEnv = [M.empty] + , matchingEnv = M.empty + , position = pos } withSpanInfo :: CSPI.HasSpanInfo a => a -> (a, CSPI.SpanInfo) @@ -73,31 +73,31 @@ flattenScopes = foldr M.union M.empty -- | Stores nested scopes and a cursor position. The head of the list is always the innermost collectScope. data ScopeState a = ScopeState - { sstCurrentEnv :: [Scope a] - , sstMatchingEnv :: Scope a - , sstPosition :: J.Position + { currentEnv :: [Scope a] + , matchingEnv :: Scope a + , position :: J.Position } type ScopeM a = State (ScopeState a) beginScope :: ScopeM a () -beginScope = modify $ \s -> s { sstCurrentEnv = M.empty : sstCurrentEnv s } +beginScope = modify $ \s -> s { currentEnv = M.empty : s.currentEnv } endScope :: ScopeM a () -endScope = modify $ \s -> s { sstCurrentEnv = let e = tail $ sstCurrentEnv s in if null e then error "Cannot end top-level scope!" else e } +endScope = modify $ \s -> s { currentEnv = let e = tail s.currentEnv in if null e then error "Cannot end top-level scope!" else e } withScope :: ScopeM a () -> ScopeM a () withScope x = beginScope >> x >> endScope bind :: CI.Ident -> Maybe a -> ScopeM a () bind i t = do - modify $ \s -> s { sstCurrentEnv = bindInScopes i t $ sstCurrentEnv s } + modify $ \s -> s { currentEnv = bindInScopes i t s.currentEnv } updateEnvs :: CSPI.HasSpanInfo e => e -> ScopeM a () updateEnvs (CSPI.getSpanInfo -> spi) = do - pos <- gets sstPosition + pos <- gets (.position) when (spi `containsPos` pos) $ - modify $ \s -> s { sstMatchingEnv = M.union (flattenScopes $ sstCurrentEnv s) $ sstMatchingEnv s } + modify $ \s -> s { matchingEnv = M.union (flattenScopes s.currentEnv) s.matchingEnv } class CollectScope e a where collectScope :: e -> ScopeM a ()