From 017843c21b99085edc8d7fadc5f5307fd434eaff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 21 Dec 2021 14:37:54 +0100 Subject: [PATCH 1/2] Reduce usages of Prelude.head --- ghcide/bench/lib/Experiments.hs | 3 +- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 17 ++- ghcide/src/Development/IDE/Core/Shake.hs | 9 +- .../src/Development/IDE/GHC/Compat/Units.hs | 5 +- ghcide/src/Development/IDE/Main.hs | 5 +- .../src/Development/IDE/Plugin/CodeAction.hs | 131 +++++++++--------- .../IDE/Plugin/CodeAction/ExactPrint.hs | 7 +- .../src/Development/IDE/Plugin/Completions.hs | 3 +- .../IDE/Plugin/Completions/Logic.hs | 6 +- .../Development/IDE/Spans/Documentation.hs | 5 +- ghcide/test/exe/Main.hs | 11 +- .../Development/IDE/Graph/Internal/Action.hs | 1 - .../Development/IDE/Graph/Internal/Profile.hs | 1 - .../src/Ide/Plugin/Floskell.hs | 5 +- plugins/hls-pragmas-plugin/test/Main.hs | 29 ++-- .../hls-tactics-plugin.cabal | 1 + .../src/Wingman/CaseSplit.hs | 3 +- .../hls-tactics-plugin/src/Wingman/Context.hs | 5 +- .../src/Wingman/Judgements.hs | 18 ++- .../src/Wingman/Machinery.hs | 20 ++- .../src/Wingman/Metaprogramming/Parser.hs | 6 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 3 - .../src/Wingman/Simplify.hs | 13 +- .../hls-tactics-plugin/src/Wingman/Tactics.hs | 18 ++- .../hls-tactics-plugin/src/Wingman/Types.hs | 6 +- .../src/Development/Benchmark/Rules.hs | 19 +-- test/functional/Completion.hs | 48 ++++--- test/functional/FunctionalCodeAction.hs | 3 +- 29 files changed, 211 insertions(+), 191 deletions(-) diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 3aeed09e66..782b922d57 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -49,6 +49,7 @@ import Language.LSP.Types hiding import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative +import Safe (headNote) import System.Directory import System.Environment.Blank (getEnv) import System.FilePath ((<.>), ()) @@ -474,7 +475,7 @@ runBench runSess b = handleAny (\e -> print e >> return badRun) output $ "Setting up document contents took " <> showDuration d -- wait again, as the progress is restarted once while loading the cradle -- make an edit, to ensure this doesn't block - let DocumentPositions{..} = head docs + let DocumentPositions{..} = headNote "Experiments.runBench" docs changeDoc doc [charEdit stringLiteralP] waitForProgressDone return docs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e4095e239d..ad4b886fed 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -461,6 +461,7 @@ executable ghcide-bench lsp-types, optparse-applicative, process, + safe, safe-exceptions, hls-graph, shake, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4488c23cb8..d03b68d1bd 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -35,6 +35,8 @@ import qualified Data.HashMap.Strict as HM import Data.Hashable import Data.IORef import Data.List +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T @@ -303,9 +305,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- compilation but these are the true source of -- information. new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info - : maybe [] snd oldDeps + :| maybe [] snd oldDeps -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId new_deps + inplace = fmap rawComponentUnitId new_deps new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do -- Remove all inplace dependencies from package flags for @@ -347,7 +349,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- . The information for the new component which caused this cache miss -- . The modified information (without -inplace flags) for -- existing packages - pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) + pure ( Map.insert hieYaml (newHscEnv, NE.toList new_deps) m + , (newHscEnv, NE.head new_deps', NE.tail new_deps') + ) let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) @@ -495,13 +499,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - returnWithVersion $ \file -> do - opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + returnWithVersion $ \file -> + liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do -- If the cradle is not finished, then wait for it to finish. void $ wait as as <- async $ getOptions file return (as, wait as) - pure opts -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -758,7 +761,7 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs -- ID. Therefore we create a fake one and give them all the same unit id. removeInplacePackages :: UnitId -- ^ fake uid to use for our internal component - -> [UnitId] + -> NonEmpty UnitId -> DynFlags -> (DynFlags, [UnitId]) removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0dda58478e..1192a09116 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -168,6 +168,7 @@ import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) import qualified "list-t" ListT import qualified StmContainers.Map as STM +import Safe (headNote) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -853,18 +854,18 @@ defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothin -- | Request a Rule result if available use :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) -use key file = head <$> uses key [file] +use key file = headNote "Development.IDE.Core.Shake.use" <$> uses key [file] -- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -useWithStale key file = head <$> usesWithStale key [file] +useWithStale key file = headNote "Development.IDE.Core.Shake.useWithStale" <$> usesWithStale key [file] -- | Request a Rule result, it not available return the last computed result which may be stale. -- Errors out if none available. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) -useWithStale_ key file = head <$> usesWithStale_ key [file] +useWithStale_ key file = headNote "Development.IDE.Core.Shake.useWithStale_" <$> usesWithStale_ key [file] -- | Plural version of 'useWithStale_' usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] @@ -932,7 +933,7 @@ useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v -use_ key file = head <$> uses_ key [file] +use_ key file = headNote "Development.IDE.Core.Shake.use_" <$> uses_ key [file] useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 61f8d82644..d7e1df36dc 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -89,6 +89,7 @@ import Data.Map (Map) #endif import Data.Either import Data.Version +import qualified Data.List.NonEmpty as NE #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId @@ -324,7 +325,7 @@ moduleUnit = Module.moduleUnitId #endif -filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) +filterInplaceUnits :: NE.NonEmpty UnitId -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags = partitionEithers (map isInplace packageFlags) where @@ -335,7 +336,7 @@ filterInplaceUnits us packageFlags = then Left $ toUnitId u else Right p #else - if u `elem` us + if u `elem` NE.toList us then Left u else Right p #endif diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 541e7385b8..5c3e43b999 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,8 +77,7 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (Key(Key), - fromKeyType) +import Development.IDE.Types.Shake (fromKeyType) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -283,7 +282,7 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- setInitialDynFlags logger dir argsSessionLoadingOptions - `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + `catchAny` (\e -> logDebug logger (T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 6a7a636e55..3ff0763046 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -169,7 +169,7 @@ findSigOfBind range bind = findSigOfGRHSs :: GRHSs p (LHsExpr p) -> Maybe (Sig p) findSigOfGRHSs grhs = do - if _start range `isInsideSrcSpan` (getLoc $ grhssLocalBinds grhs) + if _start range `isInsideSrcSpan` getLoc (grhssLocalBinds grhs) then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause else do grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) @@ -222,12 +222,12 @@ findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) -- imported from ‘Data.Text’ at B.hs:7:1-16 suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagnostic {_message, _range} - | Just [identifier, modName, s] <- + | Just (identifier:|[modName, s]) <- matchRegexUnifySpaces _message "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = suggests identifier modName s - | Just [identifier] <- + | Just (identifier:|[]) <- matchRegexUnifySpaces _message "This binding for ‘([^`]+)’ shadows the existing bindings", @@ -289,7 +289,7 @@ isUnusedImportedId suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant - | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" + | Just (_:|[bindings]) <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports , Just c <- contents , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) @@ -411,7 +411,7 @@ suggestDeleteUnusedBinding contents Diagnostic{_range=_range,..} -- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ - | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + | Just (name:|[]) <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" , Just indexedContent <- indexedByPosition . T.unpack <$> contents = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) @@ -530,7 +530,7 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul -- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ -- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ | Just source <- srcOpt - , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + , Just (name :|[]) <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) @@ -560,9 +560,9 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul opLetter = ":!#$%&*+./<=>?@\\^|-~" parenthesizeIfNeeds :: Bool -> T.Text -> T.Text - parenthesizeIfNeeds needsTypeKeyword x - | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" - | otherwise = x + parenthesizeIfNeeds needsTypeKeyword x = case T.uncons x of + Just (c,_) | c `elem` opLetter -> (if needsTypeKeyword then "type (" else "(") <> x <>")" + _ -> x matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool matchWithDiagnostic Range{_start=l,_end=r} x = @@ -615,12 +615,12 @@ suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,. -- In the expression: seq "test" seq "test" (traceShow "test") -- In an equation for ‘f’: -- f = seq "test" seq "test" (traceShow "test") - | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) + | Just (ty :| [lit]) <- matchRegexUnifySpaces _message (pat False False True False) <|> matchRegexUnifySpaces _message (pat False False False True) <|> matchRegexUnifySpaces _message (pat False False False False) = codeEdit ty lit (makeAnnotatedLit ty lit) | Just source <- sourceOpt - , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) + , Just (ty :| [lit]) <- matchRegexUnifySpaces _message (pat True True False False) = let lit' = makeAnnotatedLit ty lit; tir = textInRange _range source in codeEdit ty lit (T.replace lit lit' tir) @@ -663,9 +663,9 @@ suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} -- * Variable not in scope: -- suggestAcion :: Maybe T.Text -> Range -> Range - | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" + | Just (name :| [typ]) <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" = newDefinitionAction ideOptions parsedModule _range name typ - | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" + | Just (name :| [typ]) <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] | otherwise = [] @@ -706,9 +706,10 @@ suggestModuleTypo Diagnostic{_range=_range,..} -- Could not find module ‘Data.Cha’ -- Perhaps you meant Data.Char (from base-4.12.0.0) | "Could not find module" `T.isInfixOf` _message - , "Perhaps you meant" `T.isInfixOf` _message = let - findSuggestedModules = map (head . T.words) . drop 2 . T.lines - proposeModule mod = ("replace with " <> mod, TextEdit _range mod) + , "Perhaps you meant" `T.isInfixOf` _message = + -- TODO findSuggestedModules never extracts module name - fix the parsing logic + let findSuggestedModules = map (head . T.words) . drop 2 . T.lines + proposeModule mod = ("replace with " <> mod, TextEdit _range mod) in map proposeModule $ nubOrd $ findSuggestedModules _message | otherwise = [] @@ -721,11 +722,13 @@ suggestFillHole Diagnostic{_range=_range,..} ++ map (proposeHoleFit holeName True isInfixHole) refFits | otherwise = [] where - extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + extractHoleName msg = regexSingleMatch msg "Found hole: ([^ ]*)" addBackticks text = "`" <> text <> "`" addParens text = "(" <> text <> ")" proposeHoleFit holeName parenthise isInfixHole name = - let isInfixOperator = T.head name == '(' + let isInfixOperator = case T.uncons name of + Just ('(',_) -> True + _ -> False name' = getOperatorNotation isInfixHole isInfixOperator name in ( "replace " <> holeName <> " with " <> name , TextEdit _range (if parenthise then addParens name' else name') @@ -796,7 +799,7 @@ indentation = T.length . T.takeWhile isSpace suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} - | Just [binding, mod, srcspan] <- + | Just (binding:|[mod, srcspan]) <- matchRegexUnifySpaces _message "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" = suggestions hsmodImports binding mod srcspan @@ -829,8 +832,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ -- let ident with parent be in front of the one without. , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch - , (not . null) idents -- Ensure fallback while `idents` is empty - , ident <- head idents + , (ident:_) <- idents -- Ensure fallback while `idents` is empty = Just ident -- fallback to using GHC suggestion even though it is not always correct @@ -859,6 +861,8 @@ targetImports :: ModuleTarget -> [LImportDecl GhcPs] targetImports (ExistingImp ne) = NE.toList ne targetImports (ImplicitPrelude xs) = xs +-- >>> oneAndOthers [1,2,3] +-- [(1,[2,3]),(2,[1,3]),(3,[1,2])] oneAndOthers :: [a] -> [(a, [a])] oneAndOthers = go where @@ -877,7 +881,7 @@ suggestImportDisambiguation :: Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..} - | Just [ambiguous] <- + | Just (ambiguous:|[]) <- matchRegexUnifySpaces _message "Ambiguous occurrence ‘([^’]+)’" @@ -906,7 +910,7 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileC parensed = "(" `T.isPrefixOf` T.strip (textInRange _range txt) -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] - removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort + removeAllDuplicates = mapMaybe (\case [x] -> Just x; _ -> Nothing) . group . sort hasDuplicate xs = length xs /= length (S.fromList xs) suggestions symbol mods local | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of @@ -945,9 +949,11 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileC ] ++ [HideOthers restImports | not (null restImports)] ] ++ [ ( renderUniquify mode T.empty symbol True - , disambiguateSymbol ps fileContents diag symbol mode - ) | local, not (null targetsWithRestImports) - , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) + , disambiguateSymbol ps fileContents diag symbol mode + ) + | local + , not (null targetsWithRestImports) + , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) ] renderUniquify HideOthers {} modName symbol local = "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports" @@ -1021,7 +1027,7 @@ suggestFixConstructorImport Diagnostic{_range=_range,..} -- import Data.Aeson.Types( Result( Success ) ) -- or -- import Data.Aeson.Types( Result(..) ) (lsp-ui) - | Just [constructor, typ] <- + | Just (constructor:|[typ]) <- matchRegexUnifySpaces _message "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" = let fixedImport = typ <> "(" <> constructor <> ")" @@ -1043,7 +1049,7 @@ suggestConstraint df parsedModule diag@Diagnostic {..} regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" match = matchRegexUnifySpaces t regex matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams - in match <|> matchImplicitParams <&> last + in match <|> matchImplicitParams <&> NE.last -- | Suggests a constraint for an instance declaration for which a constraint is missing. suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1060,7 +1066,7 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing -- • In the expression: x == y -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y -- In the instance declaration for ‘Eq (Wrap a)’ - | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" + | Just (instanceDeclaration:|[]) <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls = Just instHead -- Suggests a constraint for an instance declaration with one or more existing constraints. @@ -1072,7 +1078,7 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing -- In the expression: x == y && x' == y' -- In an equation for ‘==’: -- (Pair x x') == (Pair y y') = x == y && x' == y' - | Just [instanceLineStr, constraintFirstCharStr] + | Just (instanceLineStr :| [constraintFirstCharStr]) <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls @@ -1092,7 +1098,7 @@ suggestImplicitParameter :: Diagnostic -> [(T.Text, Rewrite)] suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} - | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + | Just (implicitT:|[]) <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls = @@ -1101,7 +1107,7 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _rang | otherwise = [] findTypeSignatureName :: T.Text -> Maybe T.Text -findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head +findTypeSignatureName t = regexSingleMatch t "([^ ]+) :: " -- | Suggests a constraint for a type signature with any number of existing constraints. suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1173,12 +1179,9 @@ removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} else constraints findRedundantConstraints :: T.Text -> Maybe [T.Text] - findRedundantConstraints t = t - & T.lines - & head - & T.strip - & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") - <&> (head >>> parseConstraints) + findRedundantConstraints t = case T.lines t of + (ln:_) -> parseConstraints <$> regexSingleMatch (T.strip ln) "Redundant constraints?: (.+)" + [] -> Nothing formatConstraints :: [T.Text] -> T.Text formatConstraints [] = "" @@ -1197,7 +1200,7 @@ removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} - | Just [methodName, className] <- + | Just (methodName :|[className]) <- matchRegexUnifySpaces _message "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", @@ -1250,13 +1253,13 @@ suggestNewImport packageExportsMap ps@(L _ HsModule {..}) fileContents Diagnosti suggestNewImport _ _ _ _ = [] constructNewImportSuggestions - :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)] + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe (NonEmpty T.Text) -> [(CodeActionKind, NewImport)] constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd [ suggestion | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) , canUseIdent thingMissing identInfo - , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules + , moduleNameText identInfo `notElem` maybe [] NE.toList notTheseModules , suggestion <- renderNewImport identInfo ] where @@ -1390,27 +1393,25 @@ notInScope (NotInScopeThing t) = t extractNotInScopeName :: T.Text -> Maybe NotInScope extractNotInScopeName x - | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" + | Just name <- regexSingleMatch x "Data constructor not in scope: ([^ ]+)" = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" + | Just name <- regexSingleMatch x "Not in scope: data constructor [^‘]*‘([^’]*)’" = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" + | Just name <- regexSingleMatch x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" = Just $ NotInScopeTypeConstructorOrClass name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" + | Just name <- regexSingleMatch x "ot in scope: \\(([^‘ ]+)\\)" = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" + | Just name <- regexSingleMatch x "ot in scope: ([^‘ ]+)" = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" + | Just name <- regexSingleMatch x "ot in scope:[^‘]*‘([^’]*)’" = Just $ NotInScopeThing name | otherwise = Nothing extractQualifiedModuleName :: T.Text -> Maybe T.Text -extractQualifiedModuleName x - | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" - = Just m - | otherwise - = Nothing +extractQualifiedModuleName x = + regexSingleMatch x "module named [^‘]*‘([^’]*)’" + -- | If a module has been imported qualified, and we want to ues the same qualifier for other modules -- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier @@ -1436,13 +1437,10 @@ extractQualifiedModuleName x -- Neither ‘Data.Function’, -- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. extractDoesNotExportModuleName :: T.Text -> Maybe T.Text -extractDoesNotExportModuleName x - | Just [m] <- - matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" - <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" - = Just m - | otherwise - = Nothing +extractDoesNotExportModuleName x = + regexSingleMatch x "Module ‘([^’]*)’ does not export" + <|> regexSingleMatch x "nor ‘([^’]*)’ exports" + ------------------------------------------------------------------------------------------------- @@ -1553,7 +1551,7 @@ rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) rangesForBinding' _ _ = [] -- | 'matchRegex' combined with 'unifySpaces' -matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] +matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe (NonEmpty T.Text) matchRegexUnifySpaces message = matchRegex (unifySpaces message) -- | 'allMatchRegex' combined with 'unifySpaces' @@ -1562,9 +1560,9 @@ allMatchRegexUnifySpaces message = allMatchRegex (unifySpaces message) -- | Returns Just (the submatches) for the first capture, or Nothing. -matchRegex :: T.Text -> T.Text -> Maybe [T.Text] +matchRegex :: T.Text -> T.Text -> Maybe (NonEmpty T.Text) matchRegex message regex = case message =~~ regex of - Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings + Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> NE.nonEmpty bindings Nothing -> Nothing -- | Returns Just (all matches) for the first capture, or Nothing. @@ -1579,9 +1577,8 @@ unifySpaces = T.unwords . T.words -- | Returns the first match if found regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text -regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of - Just (h:_) -> Just h - _ -> Nothing +regexSingleMatch msg regex = + NE.head <$> matchRegexUnifySpaces msg regex -- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and -- | return (Data.Map, app/ModuleB.hs:2:1-18) @@ -1608,8 +1605,8 @@ matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) matchRegExMultipleImports message = do let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" (binding, imports) <- case matchRegexUnifySpaces message pat of - Just [x, xs] -> Just (x, xs) - _ -> Nothing + Just (x:|[xs]) -> Just (x, xs) + _ -> Nothing imps <- regExImports imports return (binding, imps) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index b79775c8c4..07764d903d 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -40,6 +40,7 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.LSP.Types +import Safe (headNote) ------------------------------------------------------------------------------ @@ -321,7 +322,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child isParentOperator = hasParen parent when hasSibling $ - addTrailingCommaT (head pre) + addTrailingCommaT (headNote "Development.IDE.Plugin.CodeAction.ExactPrint.extendImportViaParent" pre) let parentLIE = L srcParent $ (if isParentOperator then IEType else IEName) parentRdr childLIE = L srcChild $ IEName childRdr x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] @@ -396,9 +397,9 @@ extendHiding symbol (L l idecls) mlies df = do if hasSibling then when hasSibling $ do addTrailingCommaT x - addSimpleAnnT (head lies) (DP (0, 1)) [] + addSimpleAnnT (headNote "Development.IDE.Plugin.CodeAction.ExactPrint.extendHiding1" lies) (DP (0, 1)) [] unless (null $ tail lies) $ - addTrailingCommaT (head lies) -- Why we need this? + addTrailingCommaT (headNote "Development.IDE.Plugin.CodeAction.ExactPrint.extendHiding2" lies) -- Why we need this? else forM_ mlies $ \lies0 -> do transferAnn lies0 singleHide id return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ea8a025197..77bffeed31 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -48,6 +48,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (..)) +import Safe (headNote) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -210,7 +211,7 @@ extendImportHandler :: CommandFunction IdeState ExtendImport extendImportHandler ideState edit@ExtendImport {..} = do res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList + let (_, List (headNote "Development.IDE.Plugin.Completions.extendImportHandler" -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList srcSpan = rangeToSrcSpan nfp _range LSP.sendNotification SWindowShowMessage $ ShowMessageParams MtInfo $ diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index ebf52a0cc1..3f0a6cc701 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -626,10 +626,10 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu if -- TODO: handle multiline imports | "import " `T.isPrefixOf` fullLine - && (List.length (words (T.unpack fullLine)) >= 2) - && "(" `isInfixOf` T.unpack fullLine + && List.length (T.words fullLine) >= 2 + && T.any (=='(') fullLine -> do - let moduleName = T.pack $ words (T.unpack fullLine) !! 1 + let moduleName = T.words fullLine !! 1 funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap funs = map (show . name) $ HashSet.toList funcs return $ filterModuleExports moduleName $ map T.pack funs diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 8afe4f72fe..09f519e616 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -28,6 +28,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.Spans.Common +import Safe (headNote) import System.Directory import System.FilePath @@ -63,7 +64,9 @@ lookupKind env mod = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc env mod n = + headNote "Development.IDE.Spans.Documentation.getDocumentationTryGhc" + <$> getDocumentationsTryGhc env mod [n] getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env mod names = do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index dfb6e8e026..9351b98672 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4067,7 +4067,7 @@ cppTests = -- The error locations differ depending on which C-preprocessor is used. -- Some give the column number and others don't (hence -1). Assert either -- of them. - (run $ expectError content (2, -1)) + run (expectError content (2, -1)) `catch` ( \e -> do let _ = e :: HUnitFailure run $ expectError content (2, 1) @@ -4886,7 +4886,9 @@ projectCompletionTests = "import ALocal" ] compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls + item <- case find (\c -> c ^. Lens.label == "ALocalModule") compls of + Nothing -> liftIO . assertFail $ "No completion with label ALocalModule found in : " <> show compls + Just c -> pure c liftIO $ do item ^. Lens.label @?= "ALocalModule", testSession' "auto complete functions from qualified imports without alias" $ \dir-> do @@ -5912,7 +5914,7 @@ expectSameLocations actual expected = do , location ^. L.range . L.start . L.character)) $ Set.fromList actual expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do + forM expected (\(file, l, c) -> do fp <- canonicalizePath file return (filePathToUri fp, l, c)) actual' @?= expected' @@ -6054,8 +6056,7 @@ findCodeActions' op errMsg doc range expectedTitles = do ++ show expectedTitles liftIO $ case matches of Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) + Just m -> pure m findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction findCodeAction doc range t = head <$> findCodeActions doc range [t] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 5deadb5f98..2bb22a9c54 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 0823070216..78db2e5f05 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index 70fe309b66..a528cd68da 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -14,6 +14,7 @@ import Floskell import Ide.PluginUtils import Ide.Types import Language.LSP.Types +import Data.Foldable (find) -- --------------------------------------------------------------------- @@ -49,7 +50,9 @@ findConfigOrDefault file = do case mbConf of Just confFile -> readAppConfig confFile Nothing -> - let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles) + let gibiansky = case find (\s -> styleName s == "gibiansky") styles of + Just gibStyle -> gibStyle + Nothing -> error "Ide.Plugin.Floskell.findConfigOrDefault: Style with name 'gibiansky' not found" in pure $ defaultAppConfig { appStyle = gibiansky } -- --------------------------------------------------------------------- diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 4c7965a340..d931e5f075 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -4,6 +4,7 @@ module Main ) where import Control.Lens ((^.)) +import Data.Foldable (find) import qualified Data.Text as T import qualified Ide.Plugin.Pragmas as Pragmas import qualified Language.LSP.Types.Lens as L @@ -99,27 +100,29 @@ codeActionTests' = completionTests :: TestTree completionTests = testGroup "completions" - [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} ") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] - , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] - , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] - , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing [0, 0, 0, 0, 0, 24] - , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing [0, 24, 0, 31, 0, 24] - , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24] - , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16] - , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23] + [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} ") (Just "{-# LANGUAGE #-}") (0, 4, 0, 31, 0, 4) + , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") (0, 4, 0, 32, 0, 4) + , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") (0, 4, 0, 33, 0, 4) + , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24) + , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24) + , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24) + , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) + , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing (0, 13, 0, 31, 0, 23) ] -completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [Int] -> TestTree -completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] = +completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> (Int, Int, Int, Int, Int, Int) -> TestTree +completionTest testComment fileName te' label textFormat insertText detail (a, b, c, d, x, y) = testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do doc <- openDoc fileName "haskell" _ <- waitForDiagnostics let te = TextEdit (Range (Position a b) (Position c d)) te' _ <- applyEdit doc te compls <- getCompletions doc (Position x y) - let item = head $ filter ((== label) . (^. L.label)) compls + item <- case find (\c -> c ^. L.label == label) compls of + Just c -> pure c + Nothing -> liftIO . assertFailure $ "No completion with label " <> show label <> " found in " <> show compls liftIO $ do item ^. L.label @?= label item ^. L.kind @?= Just CiKeyword diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index d4a00bb96f..48939252df 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -94,6 +94,7 @@ library , prettyprinter , refinery ^>=0.4 , retrie >=0.1.1.0 + , safe , syb , unagi-chan , text diff --git a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs index 180229cf02..b2cc63c74e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs @@ -12,6 +12,7 @@ import qualified Data.Set as S import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) import GHC.SourceGen (funBindsWithFixity, match, wildP) +import Safe (atNote) import Wingman.GHC import Wingman.Types @@ -105,5 +106,5 @@ splitToDecl fixity name ams = do iterateSplit :: AgdaMatch -> [AgdaMatch] iterateSplit am = let iterated = iterate (agdaSplit =<<) $ pure am - in fmap wildify . head . drop 5 $ iterated + in fmap wildify . (\xs -> atNote "Wingman.CaseSplit.iterateSplit" xs 5) $ iterated diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs index 9aea0bf5eb..a7ecb4c045 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs @@ -28,8 +28,7 @@ mkContext cfg locals tcg hscenv eps ev = fix $ \ctx -> , ctxModuleFuncs = fmap (second (coerce $ normalizeType ctx) . splitId) . mappend (locallyDefinedMethods tcg) - . (getFunBindId =<<) - . fmap unLoc + . (getFunBindId . unLoc =<<) . bagToList $ tcg_binds tcg , ctxConfig = cfg @@ -102,5 +101,5 @@ hasClassInstance predty = do let (con, apps) = tcSplitTyConApp predty case tyConClass_maybe con of Nothing -> pure False - Just cls -> fmap isJust $ getInstance cls apps + Just cls -> isJust <$> getInstance cls apps diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 1b5a88999b..d04f7b22e1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -34,6 +34,9 @@ buildHypothesis where go (occName -> occ, t) | Just ty <- t + -- TODO what's the intention behind this check? + -- can it be replace with something like `not . isSymOcc`? + -- https://hackage.haskell.org/package/ghc-9.2.1/docs/GHC-Plugins.html#v:isSymOcc , isAlpha . head . occNameString $ occ = Just $ HyInfo occ UserPrv $ CType ty | otherwise = Nothing @@ -140,7 +143,7 @@ hasPositionalAncestry -- otherwise nothing hasPositionalAncestry ancestors jdg name | not $ null ancestors - = case any (== name) ancestors of + = case name `elem` ancestors of True -> Just True False -> case M.lookup name $ jAncestryMap jdg of @@ -162,8 +165,7 @@ filterAncestry ancestry reason jdg = disallowing reason (M.keysSet $ M.filterWithKey go $ hyByName $ jHypothesis jdg) jdg where go name _ - = not - . isJust + = isNothing $ hasPositionalAncestry ancestry jdg name @@ -233,14 +235,12 @@ filterSameTypeFromOtherPositions dcon pos jdg = -- | Return the ancestry of a 'PatVal', or 'mempty' otherwise. getAncestry :: Judgement' a -> OccName -> Set OccName getAncestry jdg name = - case M.lookup name $ jPatHypothesis jdg of - Just pv -> pv_ancestry pv - Nothing -> mempty + maybe mempty pv_ancestry . M.lookup name $ jPatHypothesis jdg jAncestryMap :: Judgement' a -> Map OccName (Set OccName) jAncestryMap jdg = - flip M.map (jPatHypothesis jdg) pv_ancestry + M.map pv_ancestry (jPatHypothesis jdg) provAncestryOf :: Provenance -> Set OccName @@ -365,9 +365,7 @@ hyNamesInScope = M.keysSet . hyByName -- | Are there any top-level function argument bindings in this judgement? jHasBoundArgs :: Judgement' a -> Bool jHasBoundArgs - = not - . null - . filter (isTopLevel . hi_provenance) + = any (isTopLevel . hi_provenance) . unHypothesis . jLocalHypothesis diff --git a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs index 56fd9f7b2e..735b33638f 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} @@ -18,7 +17,7 @@ import Data.Generics (everything, gcount, mkQ) import Data.Generics.Product (field') import Data.List (sortBy) import qualified Data.Map as M -import Data.Maybe (mapMaybe, isJust) +import Data.Maybe (mapMaybe, isNothing) import Data.Monoid (getSum) import Data.Ord (Down (..), comparing) import qualified Data.Set as S @@ -29,6 +28,7 @@ import Refinery.Future import Refinery.ProofState import Refinery.Tactic import Refinery.Tactic.Internal +import Safe (headNote) import System.Timeout (timeout) import Wingman.Context (getInstance) import Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars) @@ -69,14 +69,14 @@ newSubgoal j = do tacticToRule :: Judgement -> TacticsM () -> Rule -tacticToRule jdg (TacticT tt) = RuleT $ flip execStateT jdg tt >>= flip Subgoal Axiom +tacticToRule jdg (TacticT tt) = RuleT $ execStateT tt jdg >>= flip Subgoal Axiom consumeChan :: OutChan (Maybe a) -> IO [a] consumeChan chan = do tryReadChan chan >>= tryRead >>= \case Nothing -> pure [] - Just (Just a) -> (:) <$> pure a <*> consumeChan chan + Just (Just a) -> (a:) <$> consumeChan chan Just Nothing -> pure [] @@ -107,7 +107,7 @@ runTactic duration ctx jdg t = do (in_proofs, out_proofs) <- newChan (in_errs, out_errs) <- newChan timed_out <- - fmap (not. isJust) $ timeout duration $ consume stream $ \case + fmap isNothing $ timeout duration $ consume stream $ \case Left err -> writeChan in_errs $ Just err Right proof -> writeChan in_proofs $ Just proof writeChan in_proofs Nothing @@ -128,7 +128,7 @@ runTactic duration ctx jdg t = do , rtr_ctx = ctx , rtr_timed_out = timed_out } - _ -> fmap Left $ consumeChan out_errs + _ -> Left <$> consumeChan out_errs tracePrim :: String -> Trace @@ -342,7 +342,7 @@ lookupNameInContext name = do getDefiningType :: TacticsM CType getDefiningType = do - calling_fun_name <- fst . head <$> asks ctxDefiningFuncs + calling_fun_name <- asks (fst . headNote "Wingman.Machinery.getDefiningType" . ctxDefiningFuncs) maybe (failure $ NotInScope calling_fun_name) pure @@ -365,13 +365,11 @@ getTyThing getTyThing occ = do ctx <- ask case lookupOccEnv (ctx_occEnv ctx) occ of - Just (elt : _) -> do - mvar <- lift + Just (elt : _) -> lift $ ExtractM $ lift $ lookupName (ctx_hscEnv ctx) (ctx_module ctx) $ gre_name elt - pure mvar _ -> pure Nothing @@ -409,7 +407,7 @@ getCurrentDefinitions :: TacticsM [(OccName, CType)] getCurrentDefinitions = do ctx_funcs <- asks ctxDefiningFuncs for ctx_funcs $ \res@(occ, _) -> - pure . maybe res (occ,) =<< lookupNameInContext occ + maybe res (occ,) <$> lookupNameInContext occ ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs index 96c93da2d1..327068f0a9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Wingman.Metaprogramming.Parser where import qualified Control.Monad.Combinators.Expr as P +import Data.Either (fromRight) import Data.Functor import Data.Maybe (listToMaybe) import qualified Data.Text as T @@ -415,7 +415,7 @@ oneTactic = tactic :: Parser (TacticsM ()) -tactic = flip P.makeExprParser operators oneTactic +tactic = P.makeExprParser oneTactic operators operators :: [[P.Operator Parser (TacticsM ())]] operators = @@ -473,7 +473,7 @@ attempt_it rsl ctx jdg program = parseMetaprogram :: T.Text -> TacticsM () parseMetaprogram - = either (const $ pure ()) id + = fromRight (pure ()) . P.runParser tacticProgram "" diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 909ee6c26e..d01bdbbc92 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -- | A plugin that uses tactics to synthesize code module Wingman.Plugin where diff --git a/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs b/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs index 882d4dd897..02ee574bc3 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs @@ -10,6 +10,7 @@ import Data.Monoid (Endo (..)) import Development.IDE.GHC.Compat import GHC.SourceGen (var) import GHC.SourceGen.Expr (lambda) +import Safe (atNote) import Wingman.CodeGen.Utils import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet) @@ -35,9 +36,9 @@ pattern Lambda pats body <- -- | Simlify an expression. simplify :: LHsExpr GhcPs -> LHsExpr GhcPs simplify - = head - . drop 3 -- Do three passes; this should be good enough for the limited - -- amount of gas we give to auto + = -- Do three passes; this should be good enough for the limited + -- amount of gas we give to auto + (\xs -> atNote "Wingman.Simplify.simplify" xs 3) . iterate (everywhere $ foldEndo [ simplifyEtaReduce , simplifyRemoveParens @@ -62,7 +63,7 @@ simplifyEtaReduce = mkT $ \case (HsVar _ (L _ a)) | pat == a -> var "id" Lambda - (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (unsnoc -> Just (pats, VarPat _ (L _ pat))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. @@ -84,8 +85,8 @@ simplifySingleLet = mkT $ \case simplifyCompose :: GenericT simplifyCompose = mkT $ \case Lambda - (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) - (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) + (unsnoc -> Just (pats, VarPat _ (L _ pat))) + (unroll -> (fs@(_:_), HsVar _ (L _ a))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. , not (containsHsVar pat fs) -> diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index d6909a11ca..8e83080e6e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -8,8 +8,7 @@ module Wingman.Tactics import Control.Applicative (Alternative(empty), (<|>)) import Control.Lens ((&), (%~), (<>~)) -import Control.Monad (filterM) -import Control.Monad (unless) +import Control.Monad (filterM, unless) import Control.Monad.Extra (anyM) import Control.Monad.Reader.Class (MonadReader (ask)) import Control.Monad.State.Strict (StateT(..), runStateT) @@ -95,7 +94,7 @@ recursion = requireConcreteHole $ tracing "recursion" $ do -- Make sure that the recursive call contains at least one already-bound -- pattern value. This ensures it is structurally smaller, and thus -- suggests termination. - case (any (flip M.member pat_vals) $ syn_used_vals ext) of + case any (flip M.member pat_vals) $ syn_used_vals ext of True -> Nothing False -> Just UnhelpfulRecursion @@ -233,7 +232,7 @@ homo hi = requireConcreteHole . tracing "homo" $ do -- Ensure that every data constructor in the domain type is covered in the -- codomain; otherwise 'homo' will produce an ill-typed program. - case (uncoveredDataCons (coerce $ hi_type hi) (coerce g)) of + case uncoveredDataCons (coerce $ hi_type hi) (coerce g) of Just uncovered_dcs -> unless (S.null uncovered_dcs) $ failure $ TacticPanic "Can't cover every datacon in domain" @@ -243,7 +242,7 @@ homo hi = requireConcreteHole . tracing "homo" $ do $ destruct' False (\dc jdg -> buildDataCon False jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg) - $ hi + hi ------------------------------------------------------------------------------ @@ -266,7 +265,7 @@ homoLambdaCase = $ jGoal jdg -data Saturation = Unsaturated Int +newtype Saturation = Unsaturated Int deriving (Eq, Ord, Show) pattern Saturated :: Saturation @@ -519,8 +518,8 @@ applyByType ty = tracing ("applyByType " <> show ty) $ do rule $ \jdg -> do unify g (CType ret) ext - <- fmap unzipTrace - $ traverse ( newSubgoal + <- unzipTrace + <$> traverse ( newSubgoal . blacklistingDestruct . flip withNewGoal jdg . CType @@ -582,8 +581,7 @@ letBind occs = do $ \occ -> fmap (occ, ) $ fmap (<$ jdg) - $ fmap CType - $ newUnivar + $ fmap CType newUnivar rule $ nonrecLet occ_tys diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 63c30a82ae..df64258f46 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -333,12 +333,12 @@ instance MonadExtract Int (Synthesized (LHsExpr GhcPs)) TacticError TacticState instance MonadReader r m => MonadReader r (TacticT jdg ext err s m) where - ask = TacticT $ lift $ Effect $ fmap pure ask + ask = TacticT $ lift $ Effect $ asks pure local f (TacticT m) = TacticT $ Strict.StateT $ \jdg -> Effect $ local f $ pure $ Strict.runStateT m jdg instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where - ask = RuleT $ Effect $ fmap Axiom ask + ask = RuleT $ Effect $ asks Axiom local f (RuleT m) = RuleT $ Effect $ local f $ pure m mkMetaHoleName :: Int -> RdrName @@ -463,7 +463,7 @@ data Context = Context } instance Show Context where - show (Context {..}) = mconcat + show Context{..} = mconcat [ "Context " , showsPrec 10 ctxDefiningFuncs "" , showsPrec 10 ctxModuleFuncs "" diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index 92f5c13f63..4d710e042a 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -336,15 +336,16 @@ benchRules build MkBenchRules{..} = do -- extend csv output with allocation data csvContents <- liftIO $ lines <$> readFile outcsv - let header = head csvContents - results = tail csvContents - header' = header <> ", maxResidency, allocatedBytes" - results' <- forM results $ \row -> do - (maxResidency, allocations) <- liftIO - (parseMaxResidencyAndAllocations <$> readFile outGc) - return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) - let csvContents' = header' : results' - writeFileLines outcsv csvContents' + case csvContents of + [] -> error $ "empty csv file : " <> outcsv + (header:results) -> do + let header' = header <> ", maxResidency, allocatedBytes" + results' <- forM results $ \row -> do + (maxResidency, allocations) <- liftIO + (parseMaxResidencyAndAllocations <$> readFile outGc) + return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) + let csvContents' = header' : results' + writeFileLines outcsv csvContents' where showMB :: Int -> String showMB x = show (x `div` 2^(20::Int)) <> "MB" diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 05d02e09f2..281e23699f 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -4,6 +4,7 @@ module Completion(tests) where import Control.Lens hiding ((.=)) import Data.Aeson (object, (.=)) +import Data.Foldable (find) import qualified Data.Text as T import Ide.Plugin.Config (maxCompletions) import Language.LSP.Types.Lens hiding (applyEdit) @@ -19,7 +20,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 9) - let item = head $ filter ((== "putStrLn") . (^. label)) compls + item <- findCompletionWithLabel "putStrLn" compls liftIO $ do item ^. label @?= "putStrLn" item ^. kind @?= Just CiFunction @@ -35,7 +36,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 9) - let item = head $ filter ((== "putStrLn") . (^. label)) compls + item <- findCompletionWithLabel "putStrLn" compls resolvedRes <- request SCompletionItemResolve item let Right resolved = resolvedRes ^. result liftIO $ print resolved @@ -55,7 +56,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 1 23) - let item = head $ filter ((== "Maybe") . (^. label)) compls + item <- findCompletionWithLabel "Maybe" compls liftIO $ do item ^. label @?= "Maybe" item ^. detail @?= Just "Data.Maybe" @@ -70,7 +71,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 2 24) - let item = head $ filter ((== "List") . (^. label)) compls + item <- findCompletionWithLabel "List" compls liftIO $ do item ^. label @?= "List" item ^. detail @?= Just "Data.List" @@ -90,7 +91,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 4) - let item = head $ filter (\c -> c^.label == "accessor") compls + item <- findCompletionWithLabel "accessor" compls liftIO $ do item ^. label @?= "accessor" item ^. kind @?= Just CiFunction @@ -100,7 +101,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" _ <- applyEdit doc te compls <- getCompletions doc (Position 5 9) - let item = head $ filter ((== "id") . (^. label)) compls + item <- findCompletionWithLabel "id" compls liftIO $ do item ^. detail @?= Just ":: a -> a" @@ -110,7 +111,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" _ <- applyEdit doc te compls <- getCompletions doc (Position 5 11) - let item = head $ filter ((== "flip") . (^. label)) compls + item <- findCompletionWithLabel "flip" compls liftIO $ item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c" @@ -127,7 +128,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 0 31) - let item = head $ filter ((== "Alternative") . (^. label)) compls + item <- findCompletionWithLabel "Alternative" compls liftIO $ do item ^. label @?= "Alternative" item ^. kind @?= Just CiFunction @@ -140,7 +141,7 @@ tests = testGroup "completions" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 0 41) - let item = head $ filter ((== "liftA") . (^. label)) compls + item <- findCompletionWithLabel "liftA" compls liftIO $ do item ^. label @?= "liftA" item ^. kind @?= Just CiFunction @@ -158,7 +159,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 14) - let item = head $ filter ((== "Nothing") . (^. label)) compls + item <- findCompletionWithLabel "Nothing" compls liftIO $ do item ^. insertTextFormat @?= Just Snippet item ^. insertText @?= Just "Nothing " @@ -170,7 +171,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 11) - let item = head $ filter ((== "foldl") . (^. label)) compls + item <- findCompletionWithLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" item ^. kind @?= Just CiFunction @@ -184,7 +185,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 11) - let item = head $ filter ((== "mapM") . (^. label)) compls + item <- findCompletionWithLabel "mapM" compls liftIO $ do item ^. label @?= "mapM" item ^. kind @?= Just CiFunction @@ -198,7 +199,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 18) - let item = head $ filter ((== "filter") . (^. label)) compls + item <- findCompletionWithLabel "filter" compls liftIO $ do item ^. label @?= "filter" item ^. kind @?= Just CiFunction @@ -212,7 +213,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 18) - let item = head $ filter ((== "filter") . (^. label)) compls + item <- findCompletionWithLabel "filter" compls liftIO $ do item ^. label @?= "filter" item ^. kind @?= Just CiFunction @@ -226,7 +227,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 29) - let item = head $ filter ((== "intersperse") . (^. label)) compls + item <- findCompletionWithLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" item ^. kind @?= Just CiFunction @@ -240,7 +241,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 29) - let item = head $ filter ((== "intersperse") . (^. label)) compls + item <- findCompletionWithLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" item ^. kind @?= Just CiFunction @@ -267,7 +268,9 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 1 6) - let item = head $ filter (\c -> (c ^. label == "MkFoo") && maybe False ("MkFoo {" `T.isPrefixOf`) (c ^. insertText)) compls + item <- case find (\c -> (c ^. label == "MkFoo") && maybe False ("MkFoo {" `T.isPrefixOf`) (c ^. insertText)) compls of + Just c -> pure c + Nothing -> liftIO . assertFailure $ "No completion with label/insertText MkFoo found in " ++ show compls liftIO $ do item ^. insertTextFormat @?= Just Snippet item ^. insertText @?= Just "MkFoo {arg1=${1:_arg1}, arg2=${2:_arg2}, arg3=${3:_arg3}, arg4=${4:_arg4}, arg5=${5:_arg5}}" @@ -278,7 +281,7 @@ snippetTests = testGroup "snippets" [ _ <- applyEdit doc te compls <- getCompletions doc (Position 5 11) - let item = head $ filter ((== "foldl") . (^. label)) compls + item <- findCompletionWithLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" item ^. kind @?= Just CiFunction @@ -297,6 +300,15 @@ snippetTests = testGroup "snippets" [ ) fullCaps + +findCompletionWithLabel :: T.Text -> [CompletionItem] -> Session CompletionItem +findCompletionWithLabel desiredLabel compls = + case find (\ ci -> ci ^. label == desiredLabel) compls of + Nothing -> liftIO . assertFailure $ + "Completion with label " ++ show desiredLabel ++ " not found in " ++ show compls + Just ci -> pure ci + + contextTests :: TestTree contextTests = testGroup "contexts" [ testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index cf368b0613..fa34d66e2e 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -135,7 +135,8 @@ packageTests = testGroup "add package suggestions" [ -- ignore the first empty hlint diagnostic publish [_,_:diag:_] <- count 2 $ waitForDiagnosticsFrom doc - let prefixes = [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6 + let prefixes = + [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6 , "Could not find module `Codec.Compression.GZip'" -- Windows , "Could not load module ‘Codec.Compression.GZip’" -- GHC >= 8.6 , "Could not find module ‘Codec.Compression.GZip’" From 9ea5898a4ae6bb3b8f41f35a623b09e06175e1dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 21 Dec 2021 14:53:49 +0100 Subject: [PATCH 2/2] Fix function name --- ghcide/test/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9351b98672..ffee060263 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4887,7 +4887,7 @@ projectCompletionTests = ] compls <- getCompletions doc (Position 1 13) item <- case find (\c -> c ^. Lens.label == "ALocalModule") compls of - Nothing -> liftIO . assertFail $ "No completion with label ALocalModule found in : " <> show compls + Nothing -> liftIO . assertFailure $ "No completion with label ALocalModule found in : " <> show compls Just c -> pure c liftIO $ do item ^. Lens.label @?= "ALocalModule",