diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index f5a9b6a2a4..d016849953 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -168,8 +168,7 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule hsc keep_lbls $ enableTopLevelWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -390,14 +389,6 @@ demoteTypeErrorsToWarnings = . (`gopt_set` Opt_DeferTypedHoles) . (`gopt_set` Opt_DeferOutOfScopeVariables) -enableTopLevelWarnings :: ParsedModule -> ParsedModule -enableTopLevelWarnings = - (update_pm_mod_summary . update_hspp_opts) - ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) . - (`wopt_set` Opt_WarnMissingSignatures)) - -- the line below would show also warnings for let bindings without signature - -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))) - update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index ac7bcf5df8..3fe9b7bb71 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -49,8 +49,11 @@ import Development.IDE.GHC.Util (prettyPrint, printRdrName) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + GlobalBindingTypeSigsResult, + suggestSignature) import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location @@ -97,13 +100,15 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $ - (,,,,,) <$> getIdeOptions + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings, join -> gblSigs) <- runAction "CodeAction" state $ + (,,,,,,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile <*> use GetAnnotatedParsedSource `traverse` mbFile <*> use TypeCheck `traverse` mbFile <*> use GetHieAst `traverse` mbFile + <*> use GetBindings `traverse` mbFile + <*> use GetGlobalBindingTypeSigs `traverse` mbFile -- This is quite expensive 0.6-0.7s on GHC pkgExports <- maybe mempty envPackageExports env localExports <- readVar (exportsMap $ shakeExtras state) @@ -112,7 +117,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod df = ms_hspp_opts . pm_mod_summary <$> parsedModule actions = [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x + | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri @@ -144,12 +149,14 @@ suggestAction -> Maybe (Annotated ParsedSource) -> Maybe TcModuleResult -> Maybe HieAstResult + -> Maybe Bindings + -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag = +suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings gblSigs diag = concat -- Order these suggestions by priority - [ suggestSignature True diag + [ suggestSignature True gblSigs tcM bindings diag , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag , rewrite df annSource $ \df ps -> suggestImportDisambiguation df text ps diag diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d9cdc4c220..40bd1390bb 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,41 +1,85 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies #-} + -- | An HLS plugin to provide code lenses for type signatures -module Development.IDE.Plugin.TypeLenses - ( descriptor, - suggestSignature, - typeLensCommandId, - ) -where - -import Control.Monad.IO.Class -import Data.Aeson.Types (Value (..), toJSON) -import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T -import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.Service (getDiagnostics) -import Development.IDE.Core.Shake (getHiddenDiagnostics, use) -import Development.IDE.Types.Location (Position (Position, _character, _line), - Range (Range, _end, _start), - toNormalizedFilePath', - uriToFilePath') -import Ide.PluginUtils (mkLspCommand) -import Ide.Types (CommandFunction, - CommandId (CommandId), - PluginCommand (PluginCommand), - PluginDescriptor (..), - PluginId, - defaultPluginDescriptor, - mkPluginHandler) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), List (..), - ResponseError, SMethod (..), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit)) -import Text.Regex.TDFA ((=~)) +module Development.IDE.Plugin.TypeLenses ( + descriptor, + suggestSignature, + typeLensCommandId, + GlobalBindingTypeSig (..), + GetGlobalBindingTypeSigs (..), + GlobalBindingTypeSigsResult (..), +) where + +import Avail (availsToNameSet) +import Control.DeepSeq (rwhnf) +import Control.Monad (join) +import Control.Monad.Extra (whenMaybe) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson as A +import Data.Aeson.Types (Value (..), toJSON) +import qualified Data.Aeson.Types as A +import qualified Data.HashMap.Strict as Map +import Data.List (find) +import Data.Maybe (catMaybes, fromJust, + fromMaybe) +import qualified Data.Text as T +import Development.IDE (GhcSession (..), + HscEnvEq (hscEnv), + RuleResult, Rules, define, + srcSpanToRange) +import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Rules (IdeState, runAction) +import Development.IDE.Core.Service (getDiagnostics) +import Development.IDE.Core.Shake (getHiddenDiagnostics, use) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util (printName) +import Development.IDE.Spans.Common (safeTyThingType) +import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) +import Development.IDE.Types.Location (Position (Position, _character, _line), + Range (Range, _end, _start), + toNormalizedFilePath', + uriToFilePath') +import Development.Shake.Classes +import GHC.Generics (Generic) +import GhcPlugins (GlobalRdrEnv, + HscEnv (hsc_dflags), SDoc, + elemNameSet, getSrcSpan, + idName, lookupTypeEnv, + mkRealSrcLoc, + realSrcLocSpan, + tidyOpenType) +import HscTypes (mkPrintUnqualified) +import Ide.Plugin.Config (Config, + PluginConfig (plcConfig)) +import Ide.PluginUtils (getPluginConfig, + mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginCommand (PluginCommand), + PluginDescriptor (..), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams, _textDocument), + Diagnostic (..), + List (..), ResponseError, + SMethod (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit)) +import Outputable (showSDocForUser) +import PatSyn (patSynName) +import TcEnv (tcInitTidyEnv) +import TcRnMonad (initTcWithGbl) +import TcRnTypes (TcGblEnv (..)) +import TcType (pprSigmaType) +import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -43,67 +87,191 @@ typeLensCommandId = "typesignature.add" descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, - pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + , pluginRules = rules } codeLensProvider :: IdeState -> PluginId -> CodeLensParams -> - LSP.LspM c (Either ResponseError (List CodeLens)) -codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do + LSP.LspM Config (Either ResponseError (List CodeLens)) +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do + (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do - _ <- runAction "codeLens" ideState (use TypeCheck filePath) + tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) + bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) + gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath) + diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState - sequence - [ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, - dFile == filePath, - (title, tedit) <- suggestSignature False dDiag, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] + + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + generateLensForGlobal sig@GlobalBindingTypeSig{..} = do + range <- srcSpanToRange $ gbSrcSpan sig + tedit <- gblBindingTypeSigToEdit sig + let wedit = toWorkSpaceEdit [tedit] + pure $ generateLens pId range (T.pack gbRendered) wedit + gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs + generateLensFromDiags f = + sequence + [ pure $ generateLens pId _range title edit + | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag + , dFile == filePath + , (title, tedit) <- f dDiag + , let edit = toWorkSpaceEdit tedit + ] + + case mode of + Always -> + pure (catMaybes $ generateLensForGlobal <$> gblSigs') + <> generateLensFromDiags (suggestLocalSignature False tmr bindings) -- we still need diagnostics for local bindings + Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' + Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings Nothing -> pure [] -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens -generateLens pId _range title edit = do +generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens +generateLens pId _range title edit = let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - return $ CodeLens _range (Just cId) Nothing + in CodeLens _range (Just cId) Nothing commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null -suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..} +-------------------------------------------------------------------------------- + +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix mGblSigs mTmr mBindings diag = + suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag + +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] +suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} | _message - =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = - let signature = - removeInitialForAll $ - T.takeWhile (\x -> x /= '*' && x /= '•') $ - T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message - startOfLine = Position (_line _start) startCharacter - beforeLine = Range startOfLine startOfLine - title = if isQuickFix then "add signature: " <> signature else signature - action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " - in [(title, [action])] - where - removeInitialForAll :: T.Text -> T.Text - removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty)) - | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty)) - | otherwise = nm <> ty - startCharacter - | "Polymorphic local binding" `T.isPrefixOf` _message = - _character _start - | otherwise = - 0 -suggestSignature _ _ = [] - -unifySpaces :: T.Text -> T.Text -unifySpaces = T.unwords . T.words - -filterNewlines :: T.Text -> T.Text -filterNewlines = T.concat . T.lines + =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) + , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs + , signature <- T.pack $ gbRendered sig + , title <- if isQuickFix then "add signature: " <> signature else signature + , Just action <- gblBindingTypeSigToEdit sig = + [(title, [action])] + | otherwise = [] + +suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} + | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- + (T.unwords . T.words $ _message) + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) + , Just bindings <- mBindings + , localScope <- getFuzzyScope bindings _start _end + , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name + Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy + , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr + , -- not a top-level thing, to avoid duplication + not $ name `elemNameSet` tcg_sigs + , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty + , signature <- T.pack $ printName name <> " :: " <> tyMsg + , startCharacter <- _character _start + , startOfLine <- Position (_line _start) startCharacter + , beforeLine <- Range startOfLine startOfLine + , title <- if isQuickFix then "add signature: " <> signature else signature + , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " = + [(title, [action])] + | otherwise = [] + +sameThing :: SrcSpan -> Range -> Bool +sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) + +gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit +gblBindingTypeSigToEdit GlobalBindingTypeSig{..} + | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName + , startOfLine <- Position (_line _start) 0 + , beforeLine <- Range startOfLine startOfLine = + Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" + | otherwise = Nothing + +data Mode + = -- | always displays type lenses of global bindings, no matter what GHC flags are set + Always + | -- | similar to 'Always', but only displays for exported global bindings + Exported + | -- | follows error messages produced by GHC + Diagnostics + deriving (Eq, Ord, Show, Read, Enum) + +instance A.FromJSON Mode where + parseJSON = A.withText "Mode" $ \s -> + case T.toLower s of + "always" -> pure Always + "exported" -> pure Exported + "diagnostics" -> pure Diagnostics + _ -> A.unexpected (A.String s) + +-------------------------------------------------------------------------------- + +showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) + +data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) + +data GlobalBindingTypeSig = GlobalBindingTypeSig + { gbName :: Name + , gbRendered :: String + , gbExported :: Bool + } + +gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan +gbSrcSpan GlobalBindingTypeSig{gbName} = getSrcSpan gbName + +newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig] + +instance Show GlobalBindingTypeSigsResult where + show _ = "" + +instance NFData GlobalBindingTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult + +rules :: Rules () +rules = do + define $ \GetGlobalBindingTypeSigs nfp -> do + tmr <- use TypeCheck nfp + -- we need session here for tidying types + hsc <- use GhcSession nfp + result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) + pure ([], result) + +parseCustomConfig :: A.Object -> Maybe Mode +parseCustomConfig = A.parseMaybe (A..: "mode") + +gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) +gblBindingType (Just hsc) (Just gblEnv) = do + let exports = availsToNameSet $ tcg_exports gblEnv + sigs = tcg_sigs gblEnv + binds = collectHsBindsBinders $ tcg_binds gblEnv + patSyns = tcg_patsyns gblEnv + dflags = hsc_dflags hsc + rdrEnv = tcg_rdr_env gblEnv + showDoc = showDocRdrEnv dflags rdrEnv + hasSig :: (Monad m) => Name -> m a -> m (Maybe a) + hasSig name f = whenMaybe (name `elemNameSet` sigs) f + bindToSig id = do + let name = idName id + hasSig name $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + patToSig p = do + let name = patSynName p + -- we don't use pprPatSynType, since it always prints forall + ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType + hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ mapM bindToSig binds + patterns <- catMaybes <$> mapM patToSig patSyns + pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns +gblBindingType _ _ = pure Nothing diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 855c27c7b2..d03e81c978 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -25,7 +25,6 @@ import qualified Data.Text as T import GHC.Generics import ConLike -import DataCon import DynFlags import GHC import NameEnv @@ -66,9 +65,9 @@ safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc -safeTyThingId _ = Nothing +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike +safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 25a269ff71..ab5a2a4387 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3154,41 +3154,60 @@ removeExportTests = testGroup "remove export actions" template = exportTemplate Nothing addSigLensesTests :: TestTree -addSigLensesTests = let - missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" - notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C" - other = T.unlines ["f :: Integer -> Integer", "f x = 3"] - before withMissing def - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] - after' withMissing def sig - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] - - sigSession withMissing def sig = testSession (T.unpack def) $ do - let originalCode = before withMissing def - let expectedCode = after' withMissing def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - [CodeLens {_command = Just c}] <- getCodeLenses doc - executeCommand c - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ testGroup title - [ sigSession enableWarnings "abc = True" "abc :: Bool" - , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" - , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" - ] - | (title, enableWarnings) <- - [("with warnings enabled", True) - ,("with warnings disabled", False) +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] ] - ] linkToLocation :: [LocationLink] -> [Location] linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange)